|
version 1.971, 2008/11/12 20:01:15
|
version 1.1075, 2010/07/23 14:59:24
|
|
Line 29
|
Line 29
|
| |
|
| =pod |
=pod |
| |
|
| |
=head1 NAME |
| |
|
| |
Apache::lonnet.pm |
| |
|
| |
=head1 SYNOPSIS |
| |
|
| |
This file is an interface to the lonc processes of |
| |
the LON-CAPA network as well as set of elaborated functions for handling information |
| |
necessary for navigating through a given cluster of LON-CAPA machines within a |
| |
domain. There are over 40 specialized functions in this module which handle the |
| |
reading and transmission of metadata, user information (ids, names, environments, roles, |
| |
logs), file information (storage, reading, directories, extensions, replication, embedded |
| |
styles and descriptors), educational resources (course descriptions, section names and |
| |
numbers), url hashing (to assign roles on a url basis), and translating abbreviated symbols to |
| |
and from more descriptive phrases or explanations. |
| |
|
| |
This is part of the LearningOnline Network with CAPA project |
| |
described at http://www.lon-capa.org. |
| |
|
| =head1 Package Variables |
=head1 Package Variables |
| |
|
| These are largely undocumented, so if you decipher one please note it here. |
These are largely undocumented, so if you decipher one please note it here. |
|
Line 54 package Apache::lonnet;
|
Line 73 package Apache::lonnet;
|
| use strict; |
use strict; |
| use LWP::UserAgent(); |
use LWP::UserAgent(); |
| use HTTP::Date; |
use HTTP::Date; |
| # use Date::Parse; |
use Image::Magick; |
| |
|
| use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir |
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir |
| $_64bit %env %protocol); |
$_64bit %env %protocol %loncaparevs %serverhomeIDs); |
| |
|
| my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash, |
my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash, |
| %userrolehash, $processmarker, $dumpcount, %coursedombuf, |
%userrolehash, $processmarker, $dumpcount, %coursedombuf, |
|
Line 72 use Time::HiRes qw( gettimeofday tv_inte
|
Line 92 use Time::HiRes qw( gettimeofday tv_inte
|
| use Cache::Memcached; |
use Cache::Memcached; |
| use Digest::MD5; |
use Digest::MD5; |
| use Math::Random; |
use Math::Random; |
| |
use File::MMagic; |
| use LONCAPA qw(:DEFAULT :match); |
use LONCAPA qw(:DEFAULT :match); |
| use LONCAPA::Configuration; |
use LONCAPA::Configuration; |
| |
|
|
Line 127 sub logthis {
|
Line 148 sub logthis {
|
| my $now=time; |
my $now=time; |
| my $local=localtime($now); |
my $local=localtime($now); |
| if (open(my $fh,">>$execdir/logs/lonnet.log")) { |
if (open(my $fh,">>$execdir/logs/lonnet.log")) { |
| print $fh "$local ($$): $message\n"; |
my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string. |
| |
print $fh $logstring; |
| close($fh); |
close($fh); |
| } |
} |
| return 1; |
return 1; |
|
Line 158 sub create_connection {
|
Line 180 sub create_connection {
|
| return 0; |
return 0; |
| } |
} |
| |
|
| |
sub get_server_timezone { |
| |
my ($cnum,$cdom) = @_; |
| |
my $home=&homeserver($cnum,$cdom); |
| |
if ($home ne 'no_host') { |
| |
my $cachetime = 24*3600; |
| |
my ($timezone,$cached)=&is_cached_new('servertimezone',$home); |
| |
if (defined($cached)) { |
| |
return $timezone; |
| |
} else { |
| |
my $timezone = &reply('servertimezone',$home); |
| |
return &do_cache_new('servertimezone',$home,$timezone,$cachetime); |
| |
} |
| |
} |
| |
} |
| |
|
| |
sub get_server_loncaparev { |
| |
my ($dom,$lonhost,$ignore_cache,$caller) = @_; |
| |
if (defined($lonhost)) { |
| |
if (!defined(&hostname($lonhost))) { |
| |
undef($lonhost); |
| |
} |
| |
} |
| |
if (!defined($lonhost)) { |
| |
if (defined(&domain($dom,'primary'))) { |
| |
$lonhost=&domain($dom,'primary'); |
| |
if ($lonhost eq 'no_host') { |
| |
undef($lonhost); |
| |
} |
| |
} |
| |
} |
| |
if (defined($lonhost)) { |
| |
my $cachetime = 12*3600; |
| |
if (!$ignore_cache) { |
| |
my ($loncaparev,$cached)=&is_cached_new('serverloncaparev',$lonhost); |
| |
if (defined($cached)) { |
| |
return $loncaparev; |
| |
} |
| |
} |
| |
my ($answer,$loncaparev); |
| |
my @ids=¤t_machine_ids(); |
| |
if (grep(/^\Q$lonhost\E$/,@ids)) { |
| |
$answer = $perlvar{'lonVersion'}; |
| |
if ($answer =~ /^[\'\"]?([\d.\-]+)[\'\"]?$/) { |
| |
$loncaparev = $1; |
| |
} |
| |
} else { |
| |
$answer = &reply('serverloncaparev',$lonhost); |
| |
if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) { |
| |
if ($caller eq 'loncron') { |
| |
my $ua=new LWP::UserAgent; |
| |
$ua->timeout(20); |
| |
my $protocol = $protocol{$lonhost}; |
| |
$protocol = 'http' if ($protocol ne 'https'); |
| |
my $url = $protocol.'://'.&hostname($lonhost).'/adm/about.html'; |
| |
my $request=new HTTP::Request('GET',$url); |
| |
my $response=$ua->request($request); |
| |
unless ($response->is_error()) { |
| |
my $content = $response->content; |
| |
if ($content =~ /<p>VERSION\:\s*([\d.\-]+)<\/p>/) { |
| |
$loncaparev = $1; |
| |
} |
| |
} |
| |
} else { |
| |
$loncaparev = $loncaparevs{$lonhost}; |
| |
} |
| |
} elsif ($answer =~ /^[\'\"]?([\d.\-]+)[\'\"]?$/) { |
| |
$loncaparev = $1; |
| |
} |
| |
} |
| |
return &do_cache_new('serverloncaparev',$lonhost,$loncaparev,$cachetime); |
| |
} |
| |
} |
| |
|
| |
sub get_server_homeID { |
| |
my ($hostname,$ignore_cache,$caller) = @_; |
| |
unless ($ignore_cache) { |
| |
my ($serverhomeID,$cached)=&is_cached_new('serverhomeID',$hostname); |
| |
if (defined($cached)) { |
| |
return $serverhomeID; |
| |
} |
| |
} |
| |
my $cachetime = 12*3600; |
| |
my $serverhomeID; |
| |
if ($caller eq 'loncron') { |
| |
my @machine_ids = &machine_ids($hostname); |
| |
foreach my $id (@machine_ids) { |
| |
my $response = &reply('serverhomeID',$id); |
| |
unless (($response eq 'unknown_cmd') || ($response eq 'con_lost')) { |
| |
$serverhomeID = $response; |
| |
last; |
| |
} |
| |
} |
| |
if ($serverhomeID eq '') { |
| |
$serverhomeID = $machine_ids[-1]; |
| |
} |
| |
} else { |
| |
$serverhomeID = $serverhomeIDs{$hostname}; |
| |
} |
| |
return &do_cache_new('serverhomeID',$hostname,$serverhomeID,$cachetime); |
| |
} |
| |
|
| # -------------------------------------------------- Non-critical communication |
# -------------------------------------------------- Non-critical communication |
| sub subreply { |
sub subreply { |
|
Line 489 sub appenv {
|
Line 611 sub appenv {
|
| # ----------------------------------------------------- Delete from Environment |
# ----------------------------------------------------- Delete from Environment |
| |
|
| sub delenv { |
sub delenv { |
| my $delthis=shift; |
my ($delthis,$regexp) = @_; |
| if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { |
if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { |
| &logthis("<font color=\"blue\">WARNING: ". |
&logthis("<font color=\"blue\">WARNING: ". |
| "Attempt to delete from environment ".$delthis); |
"Attempt to delete from environment ".$delthis); |
|
Line 502 sub delenv {
|
Line 624 sub delenv {
|
| tie(my %disk_env,'GDBM_File',$env{'user.environment'}, |
tie(my %disk_env,'GDBM_File',$env{'user.environment'}, |
| (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { |
(&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { |
| foreach my $key (keys(%disk_env)) { |
foreach my $key (keys(%disk_env)) { |
| if ($key=~/^$delthis/) { |
if ($regexp) { |
| delete($env{$key}); |
if ($key=~/^$delthis/) { |
| delete($disk_env{$key}); |
delete($env{$key}); |
| } |
delete($disk_env{$key}); |
| |
} |
| |
} else { |
| |
if ($key=~/^\Q$delthis\E/) { |
| |
delete($env{$key}); |
| |
delete($disk_env{$key}); |
| |
} |
| |
} |
| } |
} |
| untie(%disk_env); |
untie(%disk_env); |
| } |
} |
|
Line 595 sub userload {
|
Line 724 sub userload {
|
| return $userloadpercent; |
return $userloadpercent; |
| } |
} |
| |
|
| # ------------------------------------------ Fight off request when overloaded |
|
| |
|
| sub overloaderror { |
|
| my ($r,$checkserver)=@_; |
|
| unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; } |
|
| my $loadavg; |
|
| if ($checkserver eq $perlvar{'lonHostID'}) { |
|
| open(my $loadfile,'/proc/loadavg'); |
|
| $loadavg=<$loadfile>; |
|
| $loadavg =~ s/\s.*//g; |
|
| $loadavg = 100*$loadavg/$perlvar{'lonLoadLim'}; |
|
| close($loadfile); |
|
| } else { |
|
| $loadavg=&reply('load',$checkserver); |
|
| } |
|
| my $overload=$loadavg-100; |
|
| if ($overload>0) { |
|
| $r->err_headers_out->{'Retry-After'}=$overload; |
|
| $r->log_error('Overload of '.$overload.' on '.$checkserver); |
|
| return 413; |
|
| } |
|
| return ''; |
|
| } |
|
| |
|
| # ------------------------------ Find server with least workload from spare.tab |
# ------------------------------ Find server with least workload from spare.tab |
| |
|
| sub spareserver { |
sub spareserver { |
|
Line 647 sub spareserver {
|
Line 752 sub spareserver {
|
| if ($protocol{$spare_server} eq 'https') { |
if ($protocol{$spare_server} eq 'https') { |
| $protocol = $protocol{$spare_server}; |
$protocol = $protocol{$spare_server}; |
| } |
} |
| $spare_server = $protocol.'://'.&hostname($spare_server); |
if (defined($spare_server)) { |
| |
my $hostname = &hostname($spare_server); |
| |
if (defined($hostname)) { |
| |
$spare_server = $protocol.'://'.$hostname; |
| |
} |
| |
} |
| } |
} |
| return $spare_server; |
return $spare_server; |
| } |
} |
|
Line 659 sub compare_server_load {
|
Line 769 sub compare_server_load {
|
| my $userloadans = &reply('userload',$try_server); |
my $userloadans = &reply('userload',$try_server); |
| |
|
| if ($loadans !~ /\d/ && $userloadans !~ /\d/) { |
if ($loadans !~ /\d/ && $userloadans !~ /\d/) { |
| next; #didn't get a number from the server |
return; #didn't get a number from the server |
| } |
} |
| |
|
| my $load; |
my $load; |
|
Line 708 sub changepass {
|
Line 818 sub changepass {
|
| my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_; |
my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_; |
| $currentpass = &escape($currentpass); |
$currentpass = &escape($currentpass); |
| $newpass = &escape($newpass); |
$newpass = &escape($newpass); |
| my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context", |
my $lonhost = $perlvar{'lonHostID'}; |
| |
my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context:$lonhost", |
| $server); |
$server); |
| if (! $answer) { |
if (! $answer) { |
| &logthis("No reply on password change request to $server ". |
&logthis("No reply on password change request to $server ". |
|
Line 733 sub changepass {
|
Line 844 sub changepass {
|
| } elsif ($answer =~ "^refused") { |
} elsif ($answer =~ "^refused") { |
| &logthis("$server refused to change $uname in $udom password because ". |
&logthis("$server refused to change $uname in $udom password because ". |
| "it was sent an unencrypted request to change the password."); |
"it was sent an unencrypted request to change the password."); |
| |
} elsif ($answer =~ "invalid_client") { |
| |
&logthis("$server refused to change $uname in $udom password because ". |
| |
"it was a reset by e-mail originating from an invalid server."); |
| } |
} |
| return $answer; |
return $answer; |
| } |
} |
|
Line 756 sub queryauthenticate {
|
Line 870 sub queryauthenticate {
|
| # --------- Try to authenticate user from domain's lib servers (first this one) |
# --------- Try to authenticate user from domain's lib servers (first this one) |
| |
|
| sub authenticate { |
sub authenticate { |
| my ($uname,$upass,$udom,$checkdefauth)=@_; |
my ($uname,$upass,$udom,$checkdefauth,$clientcancheckhost)=@_; |
| $upass=&escape($upass); |
$upass=&escape($upass); |
| $uname= &LONCAPA::clean_username($uname); |
$uname= &LONCAPA::clean_username($uname); |
| my $uhome=&homeserver($uname,$udom,1); |
my $uhome=&homeserver($uname,$udom,1); |
|
Line 779 sub authenticate {
|
Line 893 sub authenticate {
|
| return 'no_host'; |
return 'no_host'; |
| } |
} |
| } |
} |
| my $answer=reply("encrypt:auth:$udom:$uname:$upass:$checkdefauth",$uhome); |
my $answer=reply("encrypt:auth:$udom:$uname:$upass:$checkdefauth:$clientcancheckhost",$uhome); |
| if ($answer eq 'authorized') { |
if ($answer eq 'authorized') { |
| if ($newhome) { |
if ($newhome) { |
| &logthis("User $uname at $udom authorized by $uhome, but needs account"); |
&logthis("User $uname at $udom authorized by $uhome, but needs account"); |
|
Line 797 sub authenticate {
|
Line 911 sub authenticate {
|
| return 'no_host'; |
return 'no_host'; |
| } |
} |
| |
|
| |
sub can_host_session { |
| |
my ($udom,$lonhost,$remoterev,$remotesessions,$hostedsessions) = @_; |
| |
my $canhost = 1; |
| |
my $host_idn = &Apache::lonnet::internet_dom($lonhost); |
| |
if (ref($remotesessions) eq 'HASH') { |
| |
if (ref($remotesessions->{'excludedomain'}) eq 'ARRAY') { |
| |
if (grep(/^\Q$host_idn\E$/,@{$remotesessions->{'excludedomain'}})) { |
| |
$canhost = 0; |
| |
} else { |
| |
$canhost = 1; |
| |
} |
| |
} |
| |
if (ref($remotesessions->{'includedomain'}) eq 'ARRAY') { |
| |
if (grep(/^\Q$host_idn\E$/,@{$remotesessions->{'includedomain'}})) { |
| |
$canhost = 1; |
| |
} else { |
| |
$canhost = 0; |
| |
} |
| |
} |
| |
if ($canhost) { |
| |
if ($remotesessions->{'version'} ne '') { |
| |
my ($reqmajor,$reqminor) = ($remotesessions->{'version'} =~ /^(\d+)\.(\d+)$/); |
| |
if ($reqmajor ne '' && $reqminor ne '') { |
| |
if ($remoterev =~ /^\'?(\d+)\.(\d+)/) { |
| |
my $major = $1; |
| |
my $minor = $2; |
| |
if (($major < $reqmajor ) || |
| |
(($major == $reqmajor) && ($minor < $reqminor))) { |
| |
$canhost = 0; |
| |
} |
| |
} else { |
| |
$canhost = 0; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if ($canhost) { |
| |
if (ref($hostedsessions) eq 'HASH') { |
| |
if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') { |
| |
if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'excludedomain'}})) { |
| |
$canhost = 0; |
| |
} else { |
| |
$canhost = 1; |
| |
} |
| |
} |
| |
if (ref($hostedsessions->{'includedomain'}) eq 'ARRAY') { |
| |
if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'includedomain'}})) { |
| |
$canhost = 1; |
| |
} else { |
| |
$canhost = 0; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return $canhost; |
| |
} |
| |
|
| # ---------------------- Find the homebase for a user from domain's lib servers |
# ---------------------- Find the homebase for a user from domain's lib servers |
| |
|
| my %homecache; |
my %homecache; |
|
Line 882 sub idput {
|
Line 1054 sub idput {
|
| } |
} |
| } |
} |
| |
|
| # ------------------------------------------- get items from domain db files |
# ------------------------------dump from db file owned by domainconfig user |
| |
sub dump_dom { |
| |
my ($namespace,$udom,$regexp,$range)=@_; |
| |
if (!$udom) { |
| |
$udom=$env{'user.domain'}; |
| |
} |
| |
my %returnhash; |
| |
if ($udom) { |
| |
my $uname = &get_domainconfiguser($udom); |
| |
%returnhash = &dump($namespace,$udom,$uname,$regexp,$range); |
| |
} |
| |
return %returnhash; |
| |
} |
| |
|
| |
# ------------------------------------------ get items from domain db files |
| |
|
| sub get_dom { |
sub get_dom { |
| my ($namespace,$storearr,$udom,$uhome)=@_; |
my ($namespace,$storearr,$udom,$uhome)=@_; |
|
Line 956 sub put_dom {
|
Line 1142 sub put_dom {
|
| } |
} |
| } |
} |
| |
|
| |
# --------------------- newput for items in db file owned by domainconfig user |
| |
sub newput_dom { |
| |
my ($namespace,$storehash,$udom) = @_; |
| |
my $result; |
| |
if (!$udom) { |
| |
$udom=$env{'user.domain'}; |
| |
} |
| |
if ($udom) { |
| |
my $uname = &get_domainconfiguser($udom); |
| |
$result = &newput($namespace,$storehash,$udom,$uname); |
| |
} |
| |
return $result; |
| |
} |
| |
|
| |
# --------------------- delete for items in db file owned by domainconfig user |
| |
sub del_dom { |
| |
my ($namespace,$storearr,$udom)=@_; |
| |
if (ref($storearr) eq 'ARRAY') { |
| |
if (!$udom) { |
| |
$udom=$env{'user.domain'}; |
| |
} |
| |
if ($udom) { |
| |
my $uname = &get_domainconfiguser($udom); |
| |
return &del($namespace,$storearr,$udom,$uname); |
| |
} |
| |
} |
| |
} |
| |
|
| |
# ----------------------------------construct domainconfig user for a domain |
| |
sub get_domainconfiguser { |
| |
my ($udom) = @_; |
| |
return $udom.'-domainconfig'; |
| |
} |
| |
|
| sub retrieve_inst_usertypes { |
sub retrieve_inst_usertypes { |
| my ($udom) = @_; |
my ($udom) = @_; |
| my (%returnhash,@order); |
my (%returnhash,@order); |
| if (defined(&domain($udom,'primary'))) { |
my %domdefs = &Apache::lonnet::get_domain_defaults($udom); |
| my $uhome=&domain($udom,'primary'); |
if ((ref($domdefs{'inststatustypes'}) eq 'HASH') && |
| my $rep=&reply("inst_usertypes:$udom",$uhome); |
(ref($domdefs{'inststatusorder'}) eq 'ARRAY')) { |
| if ($rep =~ /^(con_lost|error|no_such_host|refused)/) { |
%returnhash = %{$domdefs{'inststatustypes'}}; |
| &logthis("get_dom failed - $rep returned from $uhome in domain: $udom"); |
@order = @{$domdefs{'inststatusorder'}}; |
| return (\%returnhash,\@order); |
|
| } |
|
| my ($hashitems,$orderitems) = split(/:/,$rep); |
|
| my @pairs=split(/\&/,$hashitems); |
|
| foreach my $item (@pairs) { |
|
| my ($key,$value)=split(/=/,$item,2); |
|
| $key = &unescape($key); |
|
| next if ($key =~ /^error: 2 /); |
|
| $returnhash{$key}=&thaw_unescape($value); |
|
| } |
|
| my @esc_order = split(/\&/,$orderitems); |
|
| foreach my $item (@esc_order) { |
|
| push(@order,&unescape($item)); |
|
| } |
|
| } else { |
} else { |
| &logthis("get_dom failed - no primary domain server for $udom"); |
if (defined(&domain($udom,'primary'))) { |
| |
my $uhome=&domain($udom,'primary'); |
| |
my $rep=&reply("inst_usertypes:$udom",$uhome); |
| |
if ($rep =~ /^(con_lost|error|no_such_host|refused)/) { |
| |
&logthis("get_dom failed - $rep returned from $uhome in domain: $udom"); |
| |
return (\%returnhash,\@order); |
| |
} |
| |
my ($hashitems,$orderitems) = split(/:/,$rep); |
| |
my @pairs=split(/\&/,$hashitems); |
| |
foreach my $item (@pairs) { |
| |
my ($key,$value)=split(/=/,$item,2); |
| |
$key = &unescape($key); |
| |
next if ($key =~ /^error: 2 /); |
| |
$returnhash{$key}=&thaw_unescape($value); |
| |
} |
| |
my @esc_order = split(/\&/,$orderitems); |
| |
foreach my $item (@esc_order) { |
| |
push(@order,&unescape($item)); |
| |
} |
| |
} else { |
| |
&logthis("get_dom failed - no primary domain server for $udom"); |
| |
} |
| } |
} |
| return (\%returnhash,\@order); |
return (\%returnhash,\@order); |
| } |
} |
|
Line 1203 sub inst_userrules {
|
Line 1430 sub inst_userrules {
|
| return (\%ruleshash,\@ruleorder); |
return (\%ruleshash,\@ruleorder); |
| } |
} |
| |
|
| # ------------------------- Get Authentication and Language Defaults for Domain |
# ------------- Get Authentication, Language and User Tools Defaults for Domain |
| |
|
| sub get_domain_defaults { |
sub get_domain_defaults { |
| my ($domain) = @_; |
my ($domain) = @_; |
| my $cachetime = 60*60*24; |
my $cachetime = 60*60*24; |
| my ($defauthtype,$defautharg,$deflang); |
|
| my ($result,$cached)=&is_cached_new('domdefaults',$domain); |
my ($result,$cached)=&is_cached_new('domdefaults',$domain); |
| if (defined($cached)) { |
if (defined($cached)) { |
| if (ref($result) eq 'HASH') { |
if (ref($result) eq 'HASH') { |
|
Line 1217 sub get_domain_defaults {
|
Line 1443 sub get_domain_defaults {
|
| } |
} |
| my %domdefaults; |
my %domdefaults; |
| my %domconfig = |
my %domconfig = |
| &Apache::lonnet::get_dom('configuration',['defaults'],$domain); |
&Apache::lonnet::get_dom('configuration',['defaults','quotas', |
| |
'requestcourses','inststatus', |
| |
'coursedefaults','usersessions'],$domain); |
| if (ref($domconfig{'defaults'}) eq 'HASH') { |
if (ref($domconfig{'defaults'}) eq 'HASH') { |
| $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; |
$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; |
| $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'}; |
$domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'}; |
| $domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'}; |
$domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'}; |
| |
$domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'}; |
| |
$domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'}; |
| } else { |
} else { |
| $domdefaults{'lang_def'} = &domain($domain,'lang_def'); |
$domdefaults{'lang_def'} = &domain($domain,'lang_def'); |
| $domdefaults{'auth_def'} = &domain($domain,'auth_def'); |
$domdefaults{'auth_def'} = &domain($domain,'auth_def'); |
| $domdefaults{'auth_arg_def'} = &domain($domain,'auth_arg_def'); |
$domdefaults{'auth_arg_def'} = &domain($domain,'auth_arg_def'); |
| } |
} |
| |
if (ref($domconfig{'quotas'}) eq 'HASH') { |
| |
if (ref($domconfig{'quotas'}{'defaultquota'}) eq 'HASH') { |
| |
$domdefaults{'defaultquota'} = $domconfig{'quotas'}{'defaultquota'}; |
| |
} else { |
| |
$domdefaults{'defaultquota'} = $domconfig{'quotas'}; |
| |
} |
| |
my @usertools = ('aboutme','blog','portfolio'); |
| |
foreach my $item (@usertools) { |
| |
if (ref($domconfig{'quotas'}{$item}) eq 'HASH') { |
| |
$domdefaults{$item} = $domconfig{'quotas'}{$item}; |
| |
} |
| |
} |
| |
} |
| |
if (ref($domconfig{'requestcourses'}) eq 'HASH') { |
| |
foreach my $item ('official','unofficial','community') { |
| |
$domdefaults{$item} = $domconfig{'requestcourses'}{$item}; |
| |
} |
| |
} |
| |
if (ref($domconfig{'inststatus'}) eq 'HASH') { |
| |
foreach my $item ('inststatustypes','inststatusorder') { |
| |
$domdefaults{$item} = $domconfig{'inststatus'}{$item}; |
| |
} |
| |
} |
| |
if (ref($domconfig{'coursedefaults'}) eq 'HASH') { |
| |
foreach my $item ('canuse_pdfforms') { |
| |
$domdefaults{$item} = $domconfig{'coursedefaults'}{$item}; |
| |
} |
| |
} |
| |
if (ref($domconfig{'usersessions'}) eq 'HASH') { |
| |
if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') { |
| |
$domdefaults{'remotesessions'} = $domconfig{'usersessions'}{'remote'}; |
| |
} |
| |
if (ref($domconfig{'usersessions'}{'hosted'}) eq 'HASH') { |
| |
$domdefaults{'hostedsessions'} = $domconfig{'usersessions'}{'hosted'}; |
| |
} |
| |
} |
| &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults, |
&Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults, |
| $cachetime); |
$cachetime); |
| return %domdefaults; |
return %domdefaults; |
|
Line 1551 sub purge_remembered {
|
Line 1817 sub purge_remembered {
|
| |
|
| sub userenvironment { |
sub userenvironment { |
| my ($udom,$unam,@what)=@_; |
my ($udom,$unam,@what)=@_; |
| |
my $items; |
| |
foreach my $item (@what) { |
| |
$items.=&escape($item).'&'; |
| |
} |
| |
$items=~s/\&$//; |
| my %returnhash=(); |
my %returnhash=(); |
| my @answer=split(/\&/, |
my $uhome = &homeserver($unam,$udom); |
| &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what), |
unless ($uhome eq 'no_host') { |
| &homeserver($unam,$udom))); |
my @answer=split(/\&/, |
| my $i; |
&reply('get:'.$udom.':'.$unam.':environment:'.$items,$uhome)); |
| for ($i=0;$i<=$#what;$i++) { |
if ($#answer==0 && $answer[0] =~ /^(con_lost|error:|no_such_host)/i) { |
| $returnhash{$what[$i]}=&unescape($answer[$i]); |
return %returnhash; |
| |
} |
| |
my $i; |
| |
for ($i=0;$i<=$#what;$i++) { |
| |
$returnhash{$what[$i]}=&unescape($answer[$i]); |
| |
} |
| } |
} |
| return %returnhash; |
return %returnhash; |
| } |
} |
|
Line 1750 sub ssi_body {
|
Line 2026 sub ssi_body {
|
| } |
} |
| my $output=''; |
my $output=''; |
| my $response; |
my $response; |
| if ($filelink=~/^http\:/) { |
if ($filelink=~/^https?\:/) { |
| ($output,$response)=&externalssi($filelink); |
($output,$response)=&externalssi($filelink); |
| } else { |
} else { |
| |
$filelink .= $filelink=~/\?/ ? '&' : '?'; |
| |
$filelink .= 'inhibitmenu=yes'; |
| ($output,$response)=&ssi($filelink,%form); |
($output,$response)=&ssi($filelink,%form); |
| } |
} |
| $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs; |
$output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs; |
|
Line 1796 sub ssi {
|
Line 2074 sub ssi {
|
| &Apache::lonenc::check_encrypt(\$fn); |
&Apache::lonenc::check_encrypt(\$fn); |
| if (%form) { |
if (%form) { |
| $request=new HTTP::Request('POST',&absolute_url().$fn); |
$request=new HTTP::Request('POST',&absolute_url().$fn); |
| $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form)); |
$request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys(%form))); |
| } else { |
} else { |
| $request=new HTTP::Request('GET',&absolute_url().$fn); |
$request=new HTTP::Request('GET',&absolute_url().$fn); |
| } |
} |
|
Line 1894 sub process_coursefile {
|
Line 2172 sub process_coursefile {
|
| print $fh $env{'form.'.$source}; |
print $fh $env{'form.'.$source}; |
| close($fh); |
close($fh); |
| if ($parser eq 'parse') { |
if ($parser eq 'parse') { |
| my $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase); |
my $mm = new File::MMagic; |
| unless ($parse_result eq 'ok') { |
my $mime_type = $mm->checktype_filename($filepath.'/'.$fname); |
| &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result); |
if ($mime_type eq 'text/html') { |
| |
my $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase); |
| |
unless ($parse_result eq 'ok') { |
| |
&logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result); |
| |
} |
| } |
} |
| } |
} |
| $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, |
$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, |
|
Line 1973 sub clean_filename {
|
Line 2255 sub clean_filename {
|
| $fname=~s/\.(\d+)(?=\.)/_$1/g; |
$fname=~s/\.(\d+)(?=\.)/_$1/g; |
| return $fname; |
return $fname; |
| } |
} |
| |
# This Function checks if an Image's dimensions exceed either $resizewidth (width) |
| |
# or $resizeheight (height) - both pixels. If so, the image is scaled to produce an |
| |
# image with the same aspect ratio as the original, but with dimensions which do |
| |
# not exceed $resizewidth and $resizeheight. |
| |
|
| |
sub resizeImage { |
| |
my ($img_path,$resizewidth,$resizeheight) = @_; |
| |
my $ima = Image::Magick->new; |
| |
my $resized; |
| |
if (-e $img_path) { |
| |
$ima->Read($img_path); |
| |
if (($resizewidth =~ /^\d+$/) && ($resizeheight > 0)) { |
| |
my $width = $ima->Get('width'); |
| |
my $height = $ima->Get('height'); |
| |
if ($width > $resizewidth) { |
| |
my $factor = $width/$resizewidth; |
| |
my $newheight = $height/$factor; |
| |
$ima->Scale(width=>$resizewidth,height=>$newheight); |
| |
$resized = 1; |
| |
} |
| |
} |
| |
if (($resizeheight =~ /^\d+$/) && ($resizeheight > 0)) { |
| |
my $width = $ima->Get('width'); |
| |
my $height = $ima->Get('height'); |
| |
if ($height > $resizeheight) { |
| |
my $factor = $height/$resizeheight; |
| |
my $newwidth = $width/$factor; |
| |
$ima->Scale(width=>$newwidth,height=>$resizeheight); |
| |
$resized = 1; |
| |
} |
| |
} |
| |
if ($resized) { |
| |
$ima->Write($img_path); |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| # --------------- Take an uploaded file and put it into the userfiles directory |
# --------------- Take an uploaded file and put it into the userfiles directory |
| # input: $formname - the contents of the file are in $env{"form.$formname"} |
# input: $formname - the contents of the file are in $env{"form.$formname"} |
|
Line 1987 sub clean_filename {
|
Line 2306 sub clean_filename {
|
| # $dsetudom - domain for permanaent storage of uploaded file |
# $dsetudom - domain for permanaent storage of uploaded file |
| # $thumbwidth - width (pixels) of thumbnail to make for uploaded image |
# $thumbwidth - width (pixels) of thumbnail to make for uploaded image |
| # $thumbheight - height (pixels) of thumbnail to make for uploaded image |
# $thumbheight - height (pixels) of thumbnail to make for uploaded image |
| |
# $resizewidth - width (pixels) to which to resize uploaded image |
| |
# $resizeheight - height (pixels) to which to resize uploaded image |
| # |
# |
| # output: url of file in userspace, or error: <message> |
# output: url of file in userspace, or error: <message> |
| # or /adm/notfound.html if failure to upload occurse |
# or /adm/notfound.html if failure to upload occurse |
| |
|
| |
|
| sub userfileupload { |
sub userfileupload { |
| my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname, |
my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname, |
| $destudom,$thumbwidth,$thumbheight)=@_; |
$destudom,$thumbwidth,$thumbheight,$resizewidth,$resizeheight)=@_; |
| if (!defined($subdir)) { $subdir='unknown'; } |
if (!defined($subdir)) { $subdir='unknown'; } |
| my $fname=$env{'form.'.$formname.'.filename'}; |
my $fname=$env{'form.'.$formname.'.filename'}; |
| $fname=&clean_filename($fname); |
$fname=&clean_filename($fname); |
|
Line 2032 sub userfileupload {
|
Line 2352 sub userfileupload {
|
| close($fh); |
close($fh); |
| return $fullpath.'/'.$fname; |
return $fullpath.'/'.$fname; |
| } |
} |
| |
if ($subdir eq 'scantron') { |
| |
$fname = 'scantron_orig_'.$fname; |
| |
} else { |
| # Create the directory if not present |
# Create the directory if not present |
| $fname="$subdir/$fname"; |
$fname="$subdir/$fname"; |
| |
} |
| if ($coursedoc) { |
if ($coursedoc) { |
| my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; |
my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; |
| my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; |
my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; |
| if ($env{'form.folder'} =~ m/^(default|supplemental)/) { |
if ($env{'form.folder'} =~ m/^(default|supplemental)/) { |
| return &finishuserfileupload($docuname,$docudom, |
return &finishuserfileupload($docuname,$docudom, |
| $formname,$fname,$parser,$allfiles, |
$formname,$fname,$parser,$allfiles, |
| $codebase,$thumbwidth,$thumbheight); |
$codebase,$thumbwidth,$thumbheight, |
| |
$resizewidth,$resizeheight); |
| } else { |
} else { |
| $fname=$env{'form.folder'}.'/'.$fname; |
$fname=$env{'form.folder'}.'/'.$fname; |
| return &process_coursefile('uploaddoc',$docuname,$docudom, |
return &process_coursefile('uploaddoc',$docuname,$docudom, |
|
Line 2053 sub userfileupload {
|
Line 2377 sub userfileupload {
|
| my $docudom=$destudom; |
my $docudom=$destudom; |
| return &finishuserfileupload($docuname,$docudom,$formname,$fname, |
return &finishuserfileupload($docuname,$docudom,$formname,$fname, |
| $parser,$allfiles,$codebase, |
$parser,$allfiles,$codebase, |
| $thumbwidth,$thumbheight); |
$thumbwidth,$thumbheight, |
| |
$resizewidth,$resizeheight); |
| |
|
| } else { |
} else { |
| my $docuname=$env{'user.name'}; |
my $docuname=$env{'user.name'}; |
|
Line 2064 sub userfileupload {
|
Line 2389 sub userfileupload {
|
| } |
} |
| return &finishuserfileupload($docuname,$docudom,$formname,$fname, |
return &finishuserfileupload($docuname,$docudom,$formname,$fname, |
| $parser,$allfiles,$codebase, |
$parser,$allfiles,$codebase, |
| $thumbwidth,$thumbheight); |
$thumbwidth,$thumbheight, |
| |
$resizewidth,$resizeheight); |
| } |
} |
| } |
} |
| |
|
| sub finishuserfileupload { |
sub finishuserfileupload { |
| my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase, |
my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase, |
| $thumbwidth,$thumbheight) = @_; |
$thumbwidth,$thumbheight,$resizewidth,$resizeheight) = @_; |
| my $path=$docudom.'/'.$docuname.'/'; |
my $path=$docudom.'/'.$docuname.'/'; |
| my $filepath=$perlvar{'lonDocRoot'}; |
my $filepath=$perlvar{'lonDocRoot'}; |
| |
|
| my ($fnamepath,$file,$fetchthumb); |
my ($fnamepath,$file,$fetchthumb); |
| $file=$fname; |
$file=$fname; |
| if ($fname=~m|/|) { |
if ($fname=~m|/|) { |
|
Line 2087 sub finishuserfileupload {
|
Line 2414 sub finishuserfileupload {
|
| mkdir($filepath,0777); |
mkdir($filepath,0777); |
| } |
} |
| } |
} |
| |
|
| # Save the file |
# Save the file |
| { |
{ |
| if (!open(FH,'>'.$filepath.'/'.$file)) { |
if (!open(FH,'>'.$filepath.'/'.$file)) { |
|
Line 2100 sub finishuserfileupload {
|
Line 2428 sub finishuserfileupload {
|
| return '/adm/notfound.html'; |
return '/adm/notfound.html'; |
| } |
} |
| close(FH); |
close(FH); |
| |
if ($resizewidth && $resizeheight) { |
| |
my $mm = new File::MMagic; |
| |
my $mime_type = $mm->checktype_filename($filepath.'/'.$file); |
| |
if ($mime_type =~ m{^image/}) { |
| |
&resizeImage($filepath.'/'.$file,$resizewidth,$resizeheight); |
| |
} |
| |
} |
| } |
} |
| if ($parser eq 'parse') { |
if ($parser eq 'parse') { |
| my $parse_result = &extract_embedded_items($filepath.'/'.$file,$allfiles, |
my $mm = new File::MMagic; |
| $codebase); |
my $mime_type = $mm->checktype_filename($filepath.'/'.$file); |
| unless ($parse_result eq 'ok') { |
if ($mime_type eq 'text/html') { |
| &logthis('Failed to parse '.$filepath.$file. |
my $parse_result = &extract_embedded_items($filepath.'/'.$file, |
| ' for embedded media: '.$parse_result); |
$allfiles,$codebase); |
| |
unless ($parse_result eq 'ok') { |
| |
&logthis('Failed to parse '.$filepath.$file. |
| |
' for embedded media: '.$parse_result); |
| |
} |
| } |
} |
| } |
} |
| if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) { |
if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) { |
|
Line 2121 sub finishuserfileupload {
|
Line 2460 sub finishuserfileupload {
|
| |
|
| # Notify homeserver to grep it |
# Notify homeserver to grep it |
| # |
# |
| my $docuhome=&homeserver($docuname,$docudom); |
my $docuhome=&homeserver($docuname,$docudom); |
| my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); |
my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); |
| if ($fetchresult eq 'ok') { |
if ($fetchresult eq 'ok') { |
| if ($fetchthumb) { |
if ($fetchthumb) { |
|
Line 2253 sub add_filetype {
|
Line 2592 sub add_filetype {
|
| } |
} |
| |
|
| sub removeuploadedurl { |
sub removeuploadedurl { |
| my ($url)=@_; |
my ($url)=@_; |
| my (undef,undef,$udom,$uname,$fname)=split('/',$url,5); |
my (undef,undef,$udom,$uname,$fname)=split('/',$url,5); |
| return &removeuserfile($uname,$udom,$fname); |
return &removeuserfile($uname,$udom,$fname); |
| } |
} |
| |
|
| sub removeuserfile { |
sub removeuserfile { |
| my ($docuname,$docudom,$fname)=@_; |
my ($docuname,$docudom,$fname)=@_; |
| my $home=&homeserver($docuname,$docudom); |
my $home=&homeserver($docuname,$docudom); |
| my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home); |
my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home); |
| if ($result eq 'ok') { |
if ($result eq 'ok') { |
| if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) { |
if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) { |
| my $metafile = $fname.'.meta'; |
my $metafile = $fname.'.meta'; |
| my $metaresult = &removeuserfile($docuname,$docudom,$metafile); |
my $metaresult = &removeuserfile($docuname,$docudom,$metafile); |
| my $url = "/uploaded/$docudom/$docuname/$fname"; |
my $url = "/uploaded/$docudom/$docuname/$fname"; |
| my ($file,$group) = (&parse_portfolio_url($url))[3,4]; |
my ($file,$group) = (&parse_portfolio_url($url))[3,4]; |
| my $sqlresult = |
my $sqlresult = |
| &update_portfolio_table($docuname,$docudom,$file, |
&update_portfolio_table($docuname,$docudom,$file, |
| 'portfolio_metadata',$group, |
'portfolio_metadata',$group, |
|
Line 2410 sub flushcourselogs {
|
Line 2749 sub flushcourselogs {
|
| # Reverse lookup of domain roles (dc, ad, li, sc, au) |
# Reverse lookup of domain roles (dc, ad, li, sc, au) |
| # |
# |
| my %domrolebuffer = (); |
my %domrolebuffer = (); |
| foreach my $entry (keys %domainrolehash) { |
foreach my $entry (keys(%domainrolehash)) { |
| my ($role,$uname,$udom,$runame,$rudom,$rsec)=split(/:/,$entry); |
my ($role,$uname,$udom,$runame,$rudom,$rsec)=split(/:/,$entry); |
| if ($domrolebuffer{$rudom}) { |
if ($domrolebuffer{$rudom}) { |
| $domrolebuffer{$rudom}.='&'.&escape($entry). |
$domrolebuffer{$rudom}.='&'.&escape($entry). |
|
Line 2470 sub courseacclog {
|
Line 2809 sub courseacclog {
|
| # FIXME: Probably ought to escape things.... |
# FIXME: Probably ought to escape things.... |
| foreach my $key (keys(%env)) { |
foreach my $key (keys(%env)) { |
| if ($key=~/^form\.(.*)/) { |
if ($key=~/^form\.(.*)/) { |
| $what.=':'.$1.'='.$env{$key}; |
my $formitem = $1; |
| |
if ($formitem =~ /^HWFILE(?:SIZE|TOOBIG)/) { |
| |
$what.=':'.$formitem.'='.$env{$key}; |
| |
} elsif ($formitem !~ /^HWFILE(?:[^.]+)$/) { |
| |
$what.=':'.$formitem.'='.$env{$key}; |
| |
} |
| } |
} |
| } |
} |
| } elsif ($fnsymb =~ m:^/adm/searchcat:) { |
} elsif ($fnsymb =~ m:^/adm/searchcat:) { |
|
Line 2510 sub userrolelog {
|
Line 2854 sub userrolelog {
|
| if (($trole=~/^ca/) || ($trole=~/^aa/) || |
if (($trole=~/^ca/) || ($trole=~/^aa/) || |
| ($trole=~/^in/) || ($trole=~/^cc/) || |
($trole=~/^in/) || ($trole=~/^cc/) || |
| ($trole=~/^ep/) || ($trole=~/^cr/) || |
($trole=~/^ep/) || ($trole=~/^cr/) || |
| ($trole=~/^ta/)) { |
($trole=~/^ta/) || ($trole=~/^co/)) { |
| my (undef,$rudom,$runame,$rsec)=split(/\//,$area); |
my (undef,$rudom,$runame,$rsec)=split(/\//,$area); |
| $userrolehash |
$userrolehash |
| {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} |
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} |
|
Line 2519 sub userrolelog {
|
Line 2863 sub userrolelog {
|
| if (($env{'request.role'} =~ /dc\./) && |
if (($env{'request.role'} =~ /dc\./) && |
| (($trole=~/^au/) || ($trole=~/^in/) || |
(($trole=~/^au/) || ($trole=~/^in/) || |
| ($trole=~/^cc/) || ($trole=~/^ep/) || |
($trole=~/^cc/) || ($trole=~/^ep/) || |
| ($trole=~/^cr/) || ($trole=~/^ta/))) { |
($trole=~/^cr/) || ($trole=~/^ta/) || |
| |
($trole=~/^co/))) { |
| $userrolehash |
$userrolehash |
| {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'} |
{$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'} |
| =$tend.':'.$tstart; |
=$tend.':'.$tstart; |
|
Line 2540 sub courserolelog {
|
Line 2885 sub courserolelog {
|
| if (($trole eq 'cc') || ($trole eq 'in') || |
if (($trole eq 'cc') || ($trole eq 'in') || |
| ($trole eq 'ep') || ($trole eq 'ad') || |
($trole eq 'ep') || ($trole eq 'ad') || |
| ($trole eq 'ta') || ($trole eq 'st') || |
($trole eq 'ta') || ($trole eq 'st') || |
| ($trole=~/^cr/) || ($trole eq 'gr')) { |
($trole=~/^cr/) || ($trole eq 'gr') || |
| |
($trole eq 'co')) { |
| if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) { |
if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) { |
| my $cdom = $1; |
my $cdom = $1; |
| my $cnum = $2; |
my $cnum = $2; |
|
Line 2560 sub courserolelog {
|
Line 2906 sub courserolelog {
|
| $storehash{'section'} = $sec; |
$storehash{'section'} = $sec; |
| } |
} |
| &instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom); |
&instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom); |
| |
if (($trole ne 'st') || ($sec ne '')) { |
| |
&devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum); |
| |
} |
| } |
} |
| } |
} |
| return; |
return; |
|
Line 2569 sub get_course_adv_roles {
|
Line 2918 sub get_course_adv_roles {
|
| my ($cid,$codes) = @_; |
my ($cid,$codes) = @_; |
| $cid=$env{'request.course.id'} unless (defined($cid)); |
$cid=$env{'request.course.id'} unless (defined($cid)); |
| my %coursehash=&coursedescription($cid); |
my %coursehash=&coursedescription($cid); |
| |
my $crstype = &Apache::loncommon::course_type($cid); |
| my %nothide=(); |
my %nothide=(); |
| foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { |
foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { |
| if ($user !~ /:/) { |
if ($user !~ /:/) { |
|
Line 2581 sub get_course_adv_roles {
|
Line 2931 sub get_course_adv_roles {
|
| my %dumphash= |
my %dumphash= |
| &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'}); |
&dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'}); |
| my $now=time; |
my $now=time; |
| foreach my $entry (keys %dumphash) { |
my %privileged; |
| |
foreach my $entry (keys(%dumphash)) { |
| my ($tend,$tstart)=split(/\:/,$dumphash{$entry}); |
my ($tend,$tstart)=split(/\:/,$dumphash{$entry}); |
| if (($tstart) && ($tstart<0)) { next; } |
if (($tstart) && ($tstart<0)) { next; } |
| if (($tend) && ($tend<$now)) { next; } |
if (($tend) && ($tend<$now)) { next; } |
| if (($tstart) && ($now<$tstart)) { next; } |
if (($tstart) && ($now<$tstart)) { next; } |
| my ($role,$username,$domain,$section)=split(/\:/,$entry); |
my ($role,$username,$domain,$section)=split(/\:/,$entry); |
| if ($username eq '' || $domain eq '') { next; } |
if ($username eq '' || $domain eq '') { next; } |
| if ((&privileged($username,$domain)) && |
unless (ref($privileged{$domain}) eq 'HASH') { |
| (!$nothide{$username.':'.$domain})) { next; } |
my %dompersonnel = |
| |
&Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now); |
| |
$privileged{$domain} = {}; |
| |
foreach my $server (keys(%dompersonnel)) { |
| |
if (ref($dompersonnel{$server}) eq 'HASH') { |
| |
foreach my $user (keys(%{$dompersonnel{$server}})) { |
| |
my ($trole,$uname,$udom) = split(/:/,$user); |
| |
$privileged{$udom}{$uname} = 1; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if ((exists($privileged{$domain}{$username})) && |
| |
(!$nothide{$username.':'.$domain})) { next; } |
| if ($role eq 'cr') { next; } |
if ($role eq 'cr') { next; } |
| if ($codes) { |
if ($codes) { |
| if ($section) { $role .= ':'.$section; } |
if ($section) { $role .= ':'.$section; } |
|
Line 2599 sub get_course_adv_roles {
|
Line 2963 sub get_course_adv_roles {
|
| $returnhash{$role}=$username.':'.$domain; |
$returnhash{$role}=$username.':'.$domain; |
| } |
} |
| } else { |
} else { |
| my $key=&plaintext($role); |
my $key=&plaintext($role,$crstype); |
| if ($section) { $key.=' (Section '.$section.')'; } |
if ($section) { $key.=' ('.&Apache::lonlocal::mt('Section [_1]',$section).')'; } |
| if ($returnhash{$key}) { |
if ($returnhash{$key}) { |
| $returnhash{$key}.=','.$username.':'.$domain; |
$returnhash{$key}.=','.$username.':'.$domain; |
| } else { |
} else { |
|
Line 2634 sub get_my_roles {
|
Line 2998 sub get_my_roles {
|
| } |
} |
| my %returnhash=(); |
my %returnhash=(); |
| my $now=time; |
my $now=time; |
| |
my %privileged; |
| foreach my $entry (keys(%dumphash)) { |
foreach my $entry (keys(%dumphash)) { |
| my ($role,$tend,$tstart); |
my ($role,$tend,$tstart); |
| if ($context eq 'userroles') { |
if ($context eq 'userroles') { |
|
Line 2682 sub get_my_roles {
|
Line 3047 sub get_my_roles {
|
| } |
} |
| } |
} |
| if ($hidepriv) { |
if ($hidepriv) { |
| if ((&privileged($username,$domain)) && |
if ($context eq 'userroles') { |
| (!$nothide{$username.':'.$domain})) { |
if ((&privileged($username,$domain)) && |
| next; |
(!$nothide{$username.':'.$domain})) { |
| |
next; |
| |
} |
| |
} else { |
| |
unless (ref($privileged{$domain}) eq 'HASH') { |
| |
my %dompersonnel = |
| |
&Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now); |
| |
$privileged{$domain} = {}; |
| |
if (keys(%dompersonnel)) { |
| |
foreach my $server (keys(%dompersonnel)) { |
| |
if (ref($dompersonnel{$server}) eq 'HASH') { |
| |
foreach my $user (keys(%{$dompersonnel{$server}})) { |
| |
my ($trole,$uname,$udom) = split(/:/,$user); |
| |
$privileged{$udom}{$uname} = $trole; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if (exists($privileged{$domain}{$username})) { |
| |
if (!$nothide{$username.':'.$domain}) { |
| |
next; |
| |
} |
| |
} |
| } |
} |
| } |
} |
| if ($withsec) { |
if ($withsec) { |
|
Line 2732 sub getannounce {
|
Line 3120 sub getannounce {
|
| |
|
| sub courseidput { |
sub courseidput { |
| my ($domain,$storehash,$coursehome,$caller) = @_; |
my ($domain,$storehash,$coursehome,$caller) = @_; |
| |
return unless (ref($storehash) eq 'HASH'); |
| my $outcome; |
my $outcome; |
| if ($caller eq 'timeonly') { |
if ($caller eq 'timeonly') { |
| my $cids = ''; |
my $cids = ''; |
|
Line 2770 sub courseidput {
|
Line 3159 sub courseidput {
|
| sub courseiddump { |
sub courseiddump { |
| my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter, |
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter, |
| $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok, |
$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok, |
| $selfenrollonly,$catfilter,$showhidden,$caller)=@_; |
$selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone, |
| |
$cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner)=@_; |
| my $as_hash = 1; |
my $as_hash = 1; |
| my %returnhash; |
my %returnhash; |
| if (!$domfilter) { $domfilter=''; } |
if (!$domfilter) { $domfilter=''; } |
|
Line 2789 sub courseiddump {
|
Line 3179 sub courseiddump {
|
| ':'.&escape($coursefilter).':'.&escape($typefilter). |
':'.&escape($coursefilter).':'.&escape($typefilter). |
| ':'.&escape($regexp_ok).':'.$as_hash.':'. |
':'.&escape($regexp_ok).':'.$as_hash.':'. |
| &escape($selfenrollonly).':'.&escape($catfilter).':'. |
&escape($selfenrollonly).':'.&escape($catfilter).':'. |
| $showhidden.':'.$caller,$tryserver); |
$showhidden.':'.$caller.':'.&escape($cloner).':'. |
| |
&escape($cc_clone).':'.$cloneonly.':'. |
| |
&escape($createdbefore).':'.&escape($createdafter).':'. |
| |
&escape($creationcontext).':'.$domcloner, |
| |
$tryserver); |
| my @pairs=split(/\&/,$rep); |
my @pairs=split(/\&/,$rep); |
| foreach my $item (@pairs) { |
foreach my $item (@pairs) { |
| my ($key,$value)=split(/\=/,$item,2); |
my ($key,$value)=split(/\=/,$item,2); |
|
Line 2804 sub courseiddump {
|
Line 3198 sub courseiddump {
|
| for (my $i=0; $i<@responses; $i++) { |
for (my $i=0; $i<@responses; $i++) { |
| $returnhash{$key}{$items[$i]} = &unescape($responses[$i]); |
$returnhash{$key}{$items[$i]} = &unescape($responses[$i]); |
| } |
} |
| } |
} |
| } |
} |
| } |
} |
| } |
} |
|
Line 2812 sub courseiddump {
|
Line 3206 sub courseiddump {
|
| return %returnhash; |
return %returnhash; |
| } |
} |
| |
|
| |
sub courselastaccess { |
| |
my ($cdom,$cnum,$hostidref) = @_; |
| |
my %returnhash; |
| |
if ($cdom && $cnum) { |
| |
my $chome = &homeserver($cnum,$cdom); |
| |
if ($chome ne 'no_host') { |
| |
my $rep = &reply('courselastaccess:'.$cdom.':'.$cnum,$chome); |
| |
&extract_lastaccess(\%returnhash,$rep); |
| |
} |
| |
} else { |
| |
if (!$cdom) { $cdom=''; } |
| |
my %libserv = &all_library(); |
| |
foreach my $tryserver (keys(%libserv)) { |
| |
if (ref($hostidref) eq 'ARRAY') { |
| |
next unless (grep(/^\Q$tryserver\E$/,@{$hostidref})); |
| |
} |
| |
if (($cdom eq '') || (&host_domain($tryserver) eq $cdom)) { |
| |
my $rep = &reply('courselastaccess:'.&host_domain($tryserver).':',$tryserver); |
| |
&extract_lastaccess(\%returnhash,$rep); |
| |
} |
| |
} |
| |
} |
| |
return %returnhash; |
| |
} |
| |
|
| |
sub extract_lastaccess { |
| |
my ($returnhash,$rep) = @_; |
| |
if (ref($returnhash) eq 'HASH') { |
| |
unless ($rep eq 'unknown_command' || $rep eq 'no_such_host' || |
| |
$rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' || |
| |
$rep eq '') { |
| |
my @pairs=split(/\&/,$rep); |
| |
foreach my $item (@pairs) { |
| |
my ($key,$value)=split(/\=/,$item,2); |
| |
$key = &unescape($key); |
| |
next if ($key =~ /^error: 2 /); |
| |
$returnhash->{$key} = &thaw_unescape($value); |
| |
} |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| # ---------------------------------------------------------- DC e-mail |
# ---------------------------------------------------------- DC e-mail |
| |
|
| sub dcmailput { |
sub dcmailput { |
|
Line 2844 sub dcmaildump {
|
Line 3281 sub dcmaildump {
|
| |
|
| sub get_domain_roles { |
sub get_domain_roles { |
| my ($dom,$roles,$startdate,$enddate)=@_; |
my ($dom,$roles,$startdate,$enddate)=@_; |
| if (undef($startdate) || $startdate eq '') { |
if ((!defined($startdate)) || ($startdate eq '')) { |
| $startdate = '.'; |
$startdate = '.'; |
| } |
} |
| if (undef($enddate) || $enddate eq '') { |
if ((!defined($enddate)) || ($enddate eq '')) { |
| $enddate = '.'; |
$enddate = '.'; |
| } |
} |
| my $rolelist; |
my $rolelist; |
|
Line 2872 sub get_domain_roles {
|
Line 3309 sub get_domain_roles {
|
| return %personnel; |
return %personnel; |
| } |
} |
| |
|
| # ----------------------------------------------------------- Check out an item |
# ----------------------------------------------------------- Interval timing |
| |
|
| sub get_first_access { |
sub get_first_access { |
| my ($type,$argsymb)=@_; |
my ($type,$argsymb)=@_; |
|
Line 2908 sub set_first_access {
|
Line 3345 sub set_first_access {
|
| return 'already_set'; |
return 'already_set'; |
| } |
} |
| |
|
| sub checkout { |
|
| my ($symb,$tuname,$tudom,$tcrsid)=@_; |
|
| my $now=time; |
|
| my $lonhost=$perlvar{'lonHostID'}; |
|
| my $infostr=&escape( |
|
| 'CHECKOUTTOKEN&'. |
|
| $tuname.'&'. |
|
| $tudom.'&'. |
|
| $tcrsid.'&'. |
|
| $symb.'&'. |
|
| $now.'&'.$ENV{'REMOTE_ADDR'}); |
|
| my $token=&reply('tmpput:'.$infostr,$lonhost); |
|
| if ($token=~/^error\:/) { |
|
| &logthis("<font color=\"blue\">WARNING: ". |
|
| "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb. |
|
| "</font>"); |
|
| return ''; |
|
| } |
|
| |
|
| $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/; |
|
| $token=~tr/a-z/A-Z/; |
|
| |
|
| my %infohash=('resource.0.outtoken' => $token, |
|
| 'resource.0.checkouttime' => $now, |
|
| 'resource.0.outremote' => $ENV{'REMOTE_ADDR'}); |
|
| |
|
| unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') { |
|
| return ''; |
|
| } else { |
|
| &logthis("<font color=\"blue\">WARNING: ". |
|
| "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb. |
|
| "</font>"); |
|
| } |
|
| |
|
| if (&log($tudom,$tuname,&homeserver($tuname,$tudom), |
|
| &escape('Checkout '.$infostr.' - '. |
|
| $token)) ne 'ok') { |
|
| return ''; |
|
| } else { |
|
| &logthis("<font color=\"blue\">WARNING: ". |
|
| "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb. |
|
| "</font>"); |
|
| } |
|
| return $token; |
|
| } |
|
| |
|
| # ------------------------------------------------------------ Check in an item |
|
| |
|
| sub checkin { |
|
| my $token=shift; |
|
| my $now=time; |
|
| my ($ta,$tb,$lonhost)=split(/\*/,$token); |
|
| $lonhost=~tr/A-Z/a-z/; |
|
| my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb; |
|
| $dtoken=~s/\W/\_/g; |
|
| my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)= |
|
| split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost))); |
|
| |
|
| unless (($tuname) && ($tudom)) { |
|
| &logthis('Check in '.$token.' ('.$dtoken.') failed'); |
|
| return ''; |
|
| } |
|
| |
|
| unless (&allowed('mgr',$tcrsid)) { |
|
| &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '. |
|
| $env{'user.name'}.' - '.$env{'user.domain'}); |
|
| return ''; |
|
| } |
|
| |
|
| my %infohash=('resource.0.intoken' => $token, |
|
| 'resource.0.checkintime' => $now, |
|
| 'resource.0.inremote' => $ENV{'REMOTE_ADDR'}); |
|
| |
|
| unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') { |
|
| return ''; |
|
| } |
|
| |
|
| if (&log($tudom,$tuname,&homeserver($tuname,$tudom), |
|
| &escape('Checkin - '.$token)) ne 'ok') { |
|
| return ''; |
|
| } |
|
| |
|
| return ($symb,$tuname,$tudom,$tcrsid); |
|
| } |
|
| |
|
| # --------------------------------------------- Set Expire Date for Spreadsheet |
# --------------------------------------------- Set Expire Date for Spreadsheet |
| |
|
| sub expirespread { |
sub expirespread { |
|
Line 3254 sub tmpreset {
|
Line 3606 sub tmpreset {
|
| if (tie(%hash,'GDBM_File', |
if (tie(%hash,'GDBM_File', |
| $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', |
$path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', |
| &GDBM_WRCREAT(),0640)) { |
&GDBM_WRCREAT(),0640)) { |
| foreach my $key (keys %hash) { |
foreach my $key (keys(%hash)) { |
| if ($key=~ /:$symb/) { |
if ($key=~ /:$symb/) { |
| delete($hash{$key}); |
delete($hash{$key}); |
| } |
} |
|
Line 3537 sub privileged {
|
Line 3889 sub privileged {
|
| my ($username,$domain)=@_; |
my ($username,$domain)=@_; |
| my $rolesdump=&reply("dump:$domain:$username:roles", |
my $rolesdump=&reply("dump:$domain:$username:roles", |
| &homeserver($username,$domain)); |
&homeserver($username,$domain)); |
| if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return 0; } |
if (($rolesdump eq 'con_lost') || ($rolesdump eq '') || |
| |
($rolesdump =~ /^error:/)) { |
| |
return 0; |
| |
} |
| my $now=time; |
my $now=time; |
| if ($rolesdump ne '') { |
if ($rolesdump ne '') { |
| foreach my $entry (split(/&/,$rolesdump)) { |
foreach my $entry (split(/&/,$rolesdump)) { |
|
Line 3565 sub privileged {
|
Line 3920 sub privileged {
|
| |
|
| sub rolesinit { |
sub rolesinit { |
| my ($domain,$username,$authhost)=@_; |
my ($domain,$username,$authhost)=@_; |
| my %userroles; |
my $now=time; |
| |
my %userroles = ('user.login.time' => $now); |
| my $rolesdump=reply("dump:$domain:$username:roles",$authhost); |
my $rolesdump=reply("dump:$domain:$username:roles",$authhost); |
| if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return \%userroles; } |
if (($rolesdump eq 'con_lost') || ($rolesdump eq '') || |
| |
($rolesdump =~ /^error:/)) { |
| |
return \%userroles; |
| |
} |
| my %allroles=(); |
my %allroles=(); |
| my %allgroups=(); |
my %allgroups=(); |
| my $now=time; |
|
| %userroles = ('user.login.time' => $now); |
|
| my $group_privs; |
my $group_privs; |
| |
|
| if ($rolesdump ne '') { |
if ($rolesdump ne '') { |
|
Line 3637 sub custom_roleprivs {
|
Line 3994 sub custom_roleprivs {
|
| if (($rdummy ne 'con_lost') && ($roledef ne '')) { |
if (($rdummy ne 'con_lost') && ($roledef ne '')) { |
| my ($syspriv,$dompriv,$coursepriv)=split(/\_/,$roledef); |
my ($syspriv,$dompriv,$coursepriv)=split(/\_/,$roledef); |
| if (defined($syspriv)) { |
if (defined($syspriv)) { |
| |
if ($trest =~ /^$match_community$/) { |
| |
$syspriv =~ s/bre\&S//; |
| |
} |
| $$allroles{'cm./'}.=':'.$syspriv; |
$$allroles{'cm./'}.=':'.$syspriv; |
| $$allroles{$spec.'./'}.=':'.$syspriv; |
$$allroles{$spec.'./'}.=':'.$syspriv; |
| } |
} |
|
Line 3685 sub standard_roleprivs {
|
Line 4045 sub standard_roleprivs {
|
| } |
} |
| |
|
| sub set_userprivs { |
sub set_userprivs { |
| my ($userroles,$allroles,$allgroups) = @_; |
my ($userroles,$allroles,$allgroups,$groups_roles) = @_; |
| my $author=0; |
my $author=0; |
| my $adv=0; |
my $adv=0; |
| my %grouproles = (); |
my %grouproles = (); |
| if (keys(%{$allgroups}) > 0) { |
if (keys(%{$allgroups}) > 0) { |
| foreach my $role (keys %{$allroles}) { |
my @groupkeys; |
| my ($trole,$area,$sec,$extendedarea); |
foreach my $role (keys(%{$allroles})) { |
| if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) { |
push(@groupkeys,$role); |
| $trole = $1; |
} |
| $area = $2; |
if (ref($groups_roles) eq 'HASH') { |
| $sec = $3; |
foreach my $key (keys(%{$groups_roles})) { |
| $extendedarea = $area.$sec; |
unless (grep(/^\Q$key\E$/,@groupkeys)) { |
| if (exists($$allgroups{$area})) { |
push(@groupkeys,$key); |
| foreach my $group (keys(%{$$allgroups{$area}})) { |
} |
| my $spec = $trole.'.'.$extendedarea; |
} |
| $grouproles{$spec.'.'.$area.'/'.$group} = |
} |
| |
if (@groupkeys > 0) { |
| |
foreach my $role (@groupkeys) { |
| |
my ($trole,$area,$sec,$extendedarea); |
| |
if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) { |
| |
$trole = $1; |
| |
$area = $2; |
| |
$sec = $3; |
| |
$extendedarea = $area.$sec; |
| |
if (exists($$allgroups{$area})) { |
| |
foreach my $group (keys(%{$$allgroups{$area}})) { |
| |
my $spec = $trole.'.'.$extendedarea; |
| |
$grouproles{$spec.'.'.$area.'/'.$group} = |
| $$allgroups{$area}{$group}; |
$$allgroups{$area}{$group}; |
| |
} |
| } |
} |
| } |
} |
| } |
} |
|
Line 3733 sub set_userprivs {
|
Line 4106 sub set_userprivs {
|
| return ($author,$adv); |
return ($author,$adv); |
| } |
} |
| |
|
| |
sub role_status { |
| |
my ($rolekey,$then,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_; |
| |
my @pwhere = (); |
| |
if (exists($env{$rolekey}) && $env{$rolekey} ne '') { |
| |
(undef,undef,$$role,@pwhere)=split(/\./,$rolekey); |
| |
unless (!defined($$role) || $$role eq '') { |
| |
$$where=join('.',@pwhere); |
| |
$$trolecode=$$role.'.'.$$where; |
| |
($$tstart,$$tend)=split(/\./,$env{$rolekey}); |
| |
$$tstatus='is'; |
| |
if ($$tstart && $$tstart>$then) { |
| |
$$tstatus='future'; |
| |
if ($$tstart<$now) { |
| |
if ($$tstart && $$tstart>$refresh) { |
| |
if (($$where ne '') && ($$role ne '')) { |
| |
my (%allroles,%allgroups,$group_privs, |
| |
%groups_roles,@rolecodes); |
| |
my %userroles = ( |
| |
'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend |
| |
); |
| |
@rolecodes = ('cm'); |
| |
my $spec=$$role.'.'.$$where; |
| |
my ($tdummy,$tdomain,$trest)=split(/\//,$$where); |
| |
if ($$role =~ /^cr\//) { |
| |
&custom_roleprivs(\%allroles,$$role,$tdomain,$trest,$spec,$$where); |
| |
push(@rolecodes,'cr'); |
| |
} elsif ($$role eq 'gr') { |
| |
push(@rolecodes,$$role); |
| |
my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'}, |
| |
$env{'user.name'}); |
| |
my ($trole) = split('_',$rolehash{$$where.'_'.$$role},2); |
| |
(undef,my $group_privs) = split(/\//,$trole); |
| |
$group_privs = &unescape($group_privs); |
| |
&group_roleprivs(\%allgroups,$$where,$group_privs,$$tend,$$tstart); |
| |
my %course_roles = &get_my_roles($env{'user.name'},$env{'user.domain'},'userroles',['active'],['cc','co','in','ta','ep','ad','st','cr'],[$tdomain],1); |
| |
if (keys(%course_roles) > 0) { |
| |
my ($tnum) = ($trest =~ /^($match_courseid)/); |
| |
if ($tdomain ne '' && $tnum ne '') { |
| |
foreach my $key (keys(%course_roles)) { |
| |
if ($key =~ /^\Q$tnum\E:\Q$tdomain\E:([^:]+):?([^:]*)/) { |
| |
my $crsrole = $1; |
| |
my $crssec = $2; |
| |
if ($crsrole =~ /^cr/) { |
| |
unless (grep(/^cr$/,@rolecodes)) { |
| |
push(@rolecodes,'cr'); |
| |
} |
| |
} else { |
| |
unless(grep(/^\Q$crsrole\E$/,@rolecodes)) { |
| |
push(@rolecodes,$crsrole); |
| |
} |
| |
} |
| |
my $rolekey = $crsrole.'./'.$tdomain.'/'.$tnum; |
| |
if ($crssec ne '') { |
| |
$rolekey .= '/'.$crssec; |
| |
} |
| |
$rolekey .= './'; |
| |
$groups_roles{$rolekey} = \@rolecodes; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} else { |
| |
push(@rolecodes,$$role); |
| |
&standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where); |
| |
} |
| |
my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups,\%groups_roles); |
| |
&appenv(\%userroles,\@rolecodes); |
| |
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role); |
| |
} |
| |
} |
| |
$$tstatus = 'is'; |
| |
} |
| |
} |
| |
if ($$tend) { |
| |
if ($$tend<$then) { |
| |
$$tstatus='expired'; |
| |
} elsif ($$tend<$now) { |
| |
$$tstatus='will_not'; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
|
| |
sub check_adhoc_privs { |
| |
my ($cdom,$cnum,$then,$refresh,$now,$checkrole) = @_; |
| |
my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum; |
| |
if ($env{$cckey}) { |
| |
my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend); |
| |
&role_status($cckey,$then,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend); |
| |
unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) { |
| |
&set_adhoc_privileges($cdom,$cnum,$checkrole); |
| |
} |
| |
} else { |
| |
&set_adhoc_privileges($cdom,$cnum,$checkrole); |
| |
} |
| |
} |
| |
|
| |
sub set_adhoc_privileges { |
| |
# role can be cc or ca |
| |
my ($dcdom,$pickedcourse,$role) = @_; |
| |
my $area = '/'.$dcdom.'/'.$pickedcourse; |
| |
my $spec = $role.'.'.$area; |
| |
my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'}, |
| |
$env{'user.name'}); |
| |
my %ccrole = (); |
| |
&standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area); |
| |
my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole); |
| |
&appenv(\%userroles,[$role,'cm']); |
| |
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role); |
| |
&appenv( {'request.role' => $spec, |
| |
'request.role.domain' => $dcdom, |
| |
'request.course.sec' => '' |
| |
} |
| |
); |
| |
my $tadv=0; |
| |
if (&allowed('adv') eq 'F') { $tadv=1; } |
| |
&appenv({'request.role.adv' => $tadv}); |
| |
} |
| |
|
| # --------------------------------------------------------------- get interface |
# --------------------------------------------------------------- get interface |
| |
|
| sub get { |
sub get { |
|
Line 3768 sub del {
|
Line 4261 sub del {
|
| foreach my $item (@$storearr) { |
foreach my $item (@$storearr) { |
| $items.=&escape($item).'&'; |
$items.=&escape($item).'&'; |
| } |
} |
| |
|
| $items=~s/\&$//; |
$items=~s/\&$//; |
| if (!$udomain) { $udomain=$env{'user.domain'}; } |
if (!$udomain) { $udomain=$env{'user.domain'}; } |
| if (!$uname) { $uname=$env{'user.name'}; } |
if (!$uname) { $uname=$env{'user.name'}; } |
| my $uhome=&homeserver($uname,$udomain); |
my $uhome=&homeserver($uname,$udomain); |
| |
|
| return &reply("del:$udomain:$uname:$namespace:$items",$uhome); |
return &reply("del:$udomain:$uname:$namespace:$items",$uhome); |
| } |
} |
| |
|
|
Line 4193 sub get_portfolio_access {
|
Line 4686 sub get_portfolio_access {
|
| my (%allgroups,%allroles); |
my (%allgroups,%allroles); |
| my ($start,$end,$role,$sec,$group); |
my ($start,$end,$role,$sec,$group); |
| foreach my $envkey (%env) { |
foreach my $envkey (%env) { |
| if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) { |
if ($envkey =~ m-^user\.role\.(gr|cc|co|in|ta|ep|ad|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) { |
| my $cid = $2.'_'.$3; |
my $cid = $2.'_'.$3; |
| if ($1 eq 'gr') { |
if ($1 eq 'gr') { |
| $group = $4; |
$group = $4; |
|
Line 4332 sub is_portfolio_file {
|
Line 4825 sub is_portfolio_file {
|
| return; |
return; |
| } |
} |
| |
|
| |
sub usertools_access { |
| |
my ($uname,$udom,$tool,$action,$context) = @_; |
| |
my ($access,%tools); |
| |
if ($context eq '') { |
| |
$context = 'tools'; |
| |
} |
| |
if ($context eq 'requestcourses') { |
| |
%tools = ( |
| |
official => 1, |
| |
unofficial => 1, |
| |
community => 1, |
| |
); |
| |
} else { |
| |
%tools = ( |
| |
aboutme => 1, |
| |
blog => 1, |
| |
portfolio => 1, |
| |
); |
| |
} |
| |
return if (!defined($tools{$tool})); |
| |
|
| |
if ((!defined($udom)) || (!defined($uname))) { |
| |
$udom = $env{'user.domain'}; |
| |
$uname = $env{'user.name'}; |
| |
} |
| |
|
| |
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { |
| |
if ($action ne 'reload') { |
| |
if ($context eq 'requestcourses') { |
| |
return $env{'environment.canrequest.'.$tool}; |
| |
} else { |
| |
return $env{'environment.availabletools.'.$tool}; |
| |
} |
| |
} |
| |
} |
| |
|
| |
my ($toolstatus,$inststatus); |
| |
|
| |
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && |
| |
($action ne 'reload')) { |
| |
$toolstatus = $env{'environment.'.$context.'.'.$tool}; |
| |
$inststatus = $env{'environment.inststatus'}; |
| |
} else { |
| |
my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus'); |
| |
$toolstatus = $userenv{$context.'.'.$tool}; |
| |
$inststatus = $userenv{'inststatus'}; |
| |
} |
| |
|
| |
if ($toolstatus ne '') { |
| |
if ($toolstatus) { |
| |
$access = 1; |
| |
} else { |
| |
$access = 0; |
| |
} |
| |
return $access; |
| |
} |
| |
|
| |
my $is_adv = &is_advanced_user($udom,$uname); |
| |
my %domdef = &get_domain_defaults($udom); |
| |
if (ref($domdef{$tool}) eq 'HASH') { |
| |
if ($is_adv) { |
| |
if ($domdef{$tool}{'_LC_adv'} ne '') { |
| |
if ($domdef{$tool}{'_LC_adv'}) { |
| |
$access = 1; |
| |
} else { |
| |
$access = 0; |
| |
} |
| |
return $access; |
| |
} |
| |
} |
| |
if ($inststatus ne '') { |
| |
my ($hasaccess,$hasnoaccess); |
| |
foreach my $affiliation (split(/:/,$inststatus)) { |
| |
if ($domdef{$tool}{$affiliation} ne '') { |
| |
if ($domdef{$tool}{$affiliation}) { |
| |
$hasaccess = 1; |
| |
} else { |
| |
$hasnoaccess = 1; |
| |
} |
| |
} |
| |
} |
| |
if ($hasaccess || $hasnoaccess) { |
| |
if ($hasaccess) { |
| |
$access = 1; |
| |
} elsif ($hasnoaccess) { |
| |
$access = 0; |
| |
} |
| |
return $access; |
| |
} |
| |
} else { |
| |
if ($domdef{$tool}{'default'} ne '') { |
| |
if ($domdef{$tool}{'default'}) { |
| |
$access = 1; |
| |
} elsif ($domdef{$tool}{'default'} == 0) { |
| |
$access = 0; |
| |
} |
| |
return $access; |
| |
} |
| |
} |
| |
} else { |
| |
if ($context eq 'tools') { |
| |
$access = 1; |
| |
} else { |
| |
$access = 0; |
| |
} |
| |
return $access; |
| |
} |
| |
} |
| |
|
| |
sub is_course_owner { |
| |
my ($cdom,$cnum,$udom,$uname) = @_; |
| |
if (($udom eq '') || ($uname eq '')) { |
| |
$udom = $env{'user.domain'}; |
| |
$uname = $env{'user.name'}; |
| |
} |
| |
unless (($udom eq '') || ($uname eq '')) { |
| |
if (exists($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'})) { |
| |
if ($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'} eq $uname.':'.$udom) { |
| |
return 1; |
| |
} else { |
| |
my %courseinfo = &Apache::lonnet::coursedescription($cdom.'/'.$cnum); |
| |
if ($courseinfo{'internal.courseowner'} eq $uname.':'.$udom) { |
| |
return 1; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| |
sub is_advanced_user { |
| |
my ($udom,$uname) = @_; |
| |
my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1); |
| |
my %allroles; |
| |
my $is_adv; |
| |
foreach my $role (keys(%roleshash)) { |
| |
my ($trest,$tdomain,$trole,$sec) = split(/:/,$role); |
| |
my $area = '/'.$tdomain.'/'.$trest; |
| |
if ($sec ne '') { |
| |
$area .= '/'.$sec; |
| |
} |
| |
if (($area ne '') && ($trole ne '')) { |
| |
my $spec=$trole.'.'.$area; |
| |
if ($trole =~ /^cr\//) { |
| |
&custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area); |
| |
} elsif ($trole ne 'gr') { |
| |
&standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area); |
| |
} |
| |
} |
| |
} |
| |
foreach my $role (keys(%allroles)) { |
| |
last if ($is_adv); |
| |
foreach my $item (split(/:/,$allroles{$role})) { |
| |
if ($item ne '') { |
| |
my ($privilege,$restrictions)=split(/&/,$item); |
| |
if ($privilege eq 'adv') { |
| |
$is_adv = 1; |
| |
last; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return $is_adv; |
| |
} |
| |
|
| |
sub check_can_request { |
| |
my ($dom,$can_request,$request_domains) = @_; |
| |
my $canreq = 0; |
| |
my ($types,$typename) = &Apache::loncommon::course_types(); |
| |
my @options = ('approval','validate','autolimit'); |
| |
my $optregex = join('|',@options); |
| |
if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) { |
| |
foreach my $type (@{$types}) { |
| |
if (&usertools_access($env{'user.name'}, |
| |
$env{'user.domain'}, |
| |
$type,undef,'requestcourses')) { |
| |
$canreq ++; |
| |
if (ref($request_domains) eq 'HASH') { |
| |
push(@{$request_domains->{$type}},$env{'user.domain'}); |
| |
} |
| |
if ($dom eq $env{'user.domain'}) { |
| |
$can_request->{$type} = 1; |
| |
} |
| |
} |
| |
if ($env{'environment.reqcrsotherdom.'.$type} ne '') { |
| |
my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type}); |
| |
if (@curr > 0) { |
| |
foreach my $item (@curr) { |
| |
if (ref($request_domains) eq 'HASH') { |
| |
my ($otherdom) = ($item =~ /^($match_domain):($optregex)(=?\d*)$/); |
| |
if ($otherdom ne '') { |
| |
if (ref($request_domains->{$type}) eq 'ARRAY') { |
| |
unless (grep(/^\Q$otherdom\E$/,@{$request_domains->{$type}})) { |
| |
push(@{$request_domains->{$type}},$otherdom); |
| |
} |
| |
} else { |
| |
push(@{$request_domains->{$type}},$otherdom); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
unless($dom eq $env{'user.domain'}) { |
| |
$canreq ++; |
| |
if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) { |
| |
$can_request->{$type} = 1; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return $canreq; |
| |
} |
| |
|
| # ---------------------------------------------- Custom access rule evaluation |
# ---------------------------------------------- Custom access rule evaluation |
| |
|
|
Line 4487 sub allowed {
|
Line 5193 sub allowed {
|
| my $statecond=0; |
my $statecond=0; |
| my $courseprivid=''; |
my $courseprivid=''; |
| |
|
| |
my $ownaccess; |
| |
# Community Coordinator or Assistant Co-author browsing resource space. |
| |
if (($priv eq 'bro') && ($env{'user.author'})) { |
| |
if ($uri eq '') { |
| |
$ownaccess = 1; |
| |
} else { |
| |
if (($env{'user.domain'} ne '') && ($env{'user.name'} ne '')) { |
| |
my $udom = $env{'user.domain'}; |
| |
my $uname = $env{'user.name'}; |
| |
if ($uri =~ m{^\Q$udom\E/?$}) { |
| |
$ownaccess = 1; |
| |
} elsif ($uri =~ m{^\Q$udom\E/\Q$uname\E/?}) { |
| |
unless ($uri =~ m{\.\./}) { |
| |
$ownaccess = 1; |
| |
} |
| |
} elsif (($udom ne 'public') && ($uname ne 'public')) { |
| |
my $now = time; |
| |
if ($uri =~ m{^([^/]+)/?$}) { |
| |
my $adom = $1; |
| |
foreach my $key (keys(%env)) { |
| |
if ($key =~ m{^user\.role\.(ca|aa)/\Q$adom\E}) { |
| |
my ($start,$end) = split('.',$env{$key}); |
| |
if (($now >= $start) && (!$end || $end < $now)) { |
| |
$ownaccess = 1; |
| |
last; |
| |
} |
| |
} |
| |
} |
| |
} elsif ($uri =~ m{^([^/]+)/([^/]+)/?}) { |
| |
my $adom = $1; |
| |
my $aname = $2; |
| |
foreach my $role ('ca','aa') { |
| |
if ($env{"user.role.$role./$adom/$aname"}) { |
| |
my ($start,$end) = |
| |
split('.',$env{"user.role.$role./$adom/$aname"}); |
| |
if (($now >= $start) && (!$end || $end < $now)) { |
| |
$ownaccess = 1; |
| |
last; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
|
| # Course |
# Course |
| |
|
| if ($env{'user.priv.'.$env{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) { |
if ($env{'user.priv.'.$env{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) { |
| $thisallowed.=$1; |
unless (($priv eq 'bro') && (!$ownaccess)) { |
| |
$thisallowed.=$1; |
| |
} |
| } |
} |
| |
|
| # Domain |
# Domain |
| |
|
| if ($env{'user.priv.'.$env{'request.role'}.'./'.(split(/\//,$uri))[0].'/'} |
if ($env{'user.priv.'.$env{'request.role'}.'./'.(split(/\//,$uri))[0].'/'} |
| =~/\Q$priv\E\&([^\:]*)/) { |
=~/\Q$priv\E\&([^\:]*)/) { |
| $thisallowed.=$1; |
unless (($priv eq 'bro') && (!$ownaccess)) { |
| |
$thisallowed.=$1; |
| |
} |
| } |
} |
| |
|
| # Course: uri itself is a course |
# Course: uri itself is a course |
|
Line 4507 sub allowed {
|
Line 5264 sub allowed {
|
| |
|
| if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri} |
if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri} |
| =~/\Q$priv\E\&([^\:]*)/) { |
=~/\Q$priv\E\&([^\:]*)/) { |
| $thisallowed.=$1; |
unless (($priv eq 'bro') && (!$ownaccess)) { |
| |
$thisallowed.=$1; |
| |
} |
| } |
} |
| |
|
| # URI is an uploaded document for this course, default permissions don't matter |
# URI is an uploaded document for this course, default permissions don't matter |
|
Line 4647 sub allowed {
|
Line 5406 sub allowed {
|
| |
|
| my $envkey; |
my $envkey; |
| if ($thisallowed=~/L/) { |
if ($thisallowed=~/L/) { |
| foreach $envkey (keys %env) { |
foreach $envkey (keys(%env)) { |
| if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) { |
if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) { |
| my $courseid=$2; |
my $courseid=$2; |
| my $roleid=$1.'.'.$2; |
my $roleid=$1.'.'.$2; |
|
Line 4920 sub update_allusers_table {
|
Line 5679 sub update_allusers_table {
|
| 'generation='.&escape($names->{'generation'}).'%%'. |
'generation='.&escape($names->{'generation'}).'%%'. |
| 'permanentemail='.&escape($names->{'permanentemail'}).'%%'. |
'permanentemail='.&escape($names->{'permanentemail'}).'%%'. |
| 'id='.&escape($names->{'id'}),$homeserver); |
'id='.&escape($names->{'id'}),$homeserver); |
| my $reply = &get_query_reply($queryid); |
return; |
| return $reply; |
|
| } |
} |
| |
|
| # ------- Request retrieval of institutional classlists for course(s) |
# ------- Request retrieval of institutional classlists for course(s) |
|
Line 4938 sub fetch_enrollment_query {
|
Line 5696 sub fetch_enrollment_query {
|
| } |
} |
| my $host=&hostname($homeserver); |
my $host=&hostname($homeserver); |
| my $cmd = ''; |
my $cmd = ''; |
| foreach my $affiliate (keys %{$affiliatesref}) { |
foreach my $affiliate (keys(%{$affiliatesref})) { |
| $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%'; |
$cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%'; |
| } |
} |
| $cmd =~ s/%%$//; |
$cmd =~ s/%%$//; |
|
Line 5071 sub auto_run {
|
Line 5829 sub auto_run {
|
| |
|
| sub auto_get_sections { |
sub auto_get_sections { |
| my ($cnum,$cdom,$inst_coursecode) = @_; |
my ($cnum,$cdom,$inst_coursecode) = @_; |
| my $homeserver = &homeserver($cnum,$cdom); |
my $homeserver; |
| my @secs = (); |
if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) { |
| my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver)); |
$homeserver = &homeserver($cnum,$cdom); |
| unless ($response eq 'refused') { |
} |
| @secs = split(/:/,$response); |
if (!defined($homeserver)) { |
| |
if ($cdom =~ /^$match_domain$/) { |
| |
$homeserver = &domain($cdom,'primary'); |
| |
} |
| |
} |
| |
my @secs; |
| |
if (defined($homeserver)) { |
| |
my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver)); |
| |
unless ($response eq 'refused') { |
| |
@secs = split(/:/,$response); |
| |
} |
| } |
} |
| return @secs; |
return @secs; |
| } |
} |
|
Line 5094 sub auto_validate_courseID {
|
Line 5862 sub auto_validate_courseID {
|
| return $response; |
return $response; |
| } |
} |
| |
|
| |
sub auto_validate_instcode { |
| |
my ($cnum,$cdom,$instcode,$owner) = @_; |
| |
my ($homeserver,$response); |
| |
if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) { |
| |
$homeserver = &homeserver($cnum,$cdom); |
| |
} |
| |
if (!defined($homeserver)) { |
| |
if ($cdom =~ /^$match_domain$/) { |
| |
$homeserver = &domain($cdom,'primary'); |
| |
} |
| |
} |
| |
$response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'. |
| |
&escape($instcode).':'.&escape($owner),$homeserver)); |
| |
my ($outcome,$description) = map { &unescape($_); } split('&',$response,2); |
| |
return ($outcome,$description); |
| |
} |
| |
|
| sub auto_create_password { |
sub auto_create_password { |
| my ($cnum,$cdom,$authparam,$udom) = @_; |
my ($cnum,$cdom,$authparam,$udom) = @_; |
| my ($homeserver,$response); |
my ($homeserver,$response); |
|
Line 5208 sub auto_instcode_format {
|
Line 5993 sub auto_instcode_format {
|
| push(@homeservers,$tryserver); |
push(@homeservers,$tryserver); |
| } |
} |
| } |
} |
| |
} elsif ($caller eq 'requests') { |
| |
if ($codedom =~ /^$match_domain$/) { |
| |
my $chome = &domain($codedom,'primary'); |
| |
unless ($chome eq 'no_host') { |
| |
push(@homeservers,$chome); |
| |
} |
| |
} |
| } else { |
} else { |
| push(@homeservers,&homeserver($caller,$codedom)); |
push(@homeservers,&homeserver($caller,$codedom)); |
| } |
} |
|
Line 5265 sub auto_instcode_defaults {
|
Line 6057 sub auto_instcode_defaults {
|
| } |
} |
| |
|
| return $response; |
return $response; |
| } |
} |
| |
|
| |
sub auto_possible_instcodes { |
| |
my ($domain,$codetitles,$cat_titles,$cat_orders,$code_order) = @_; |
| |
unless ((ref($codetitles) eq 'ARRAY') && (ref($cat_titles) eq 'HASH') && |
| |
(ref($cat_orders) eq 'HASH') && (ref($code_order) eq 'ARRAY')) { |
| |
return; |
| |
} |
| |
my (@homeservers,$uhome); |
| |
if (defined(&domain($domain,'primary'))) { |
| |
$uhome=&domain($domain,'primary'); |
| |
push(@homeservers,&domain($domain,'primary')); |
| |
} else { |
| |
my %servers = &get_servers($domain,'library'); |
| |
foreach my $tryserver (keys(%servers)) { |
| |
if (!grep(/^\Q$tryserver\E$/,@homeservers)) { |
| |
push(@homeservers,$tryserver); |
| |
} |
| |
} |
| |
} |
| |
my $response; |
| |
foreach my $server (@homeservers) { |
| |
$response=&reply('autopossibleinstcodes:'.$domain,$server); |
| |
next if ($response =~ /(con_lost|error|no_such_host|refused)/); |
| |
my ($codetitlestr,$codeorderstr,$cat_title,$cat_order) = |
| |
split(':',$response); |
| |
@{$codetitles} = map { &unescape($_); } (split('&',$codetitlestr)); |
| |
@{$code_order} = map { &unescape($_); } (split('&',$codeorderstr)); |
| |
foreach my $item (split('&',$cat_title)) { |
| |
my ($name,$value)=split('=',$item); |
| |
$cat_titles->{&unescape($name)}=&thaw_unescape($value); |
| |
} |
| |
foreach my $item (split('&',$cat_order)) { |
| |
my ($name,$value)=split('=',$item); |
| |
$cat_orders->{&unescape($name)}=&thaw_unescape($value); |
| |
} |
| |
return 'ok'; |
| |
} |
| |
return $response; |
| |
} |
| |
|
| |
sub auto_courserequest_checks { |
| |
my ($dom) = @_; |
| |
my ($homeserver,%validations); |
| |
if ($dom =~ /^$match_domain$/) { |
| |
$homeserver = &domain($dom,'primary'); |
| |
} |
| |
unless ($homeserver eq 'no_host') { |
| |
my $response=&reply('autocrsreqchecks:'.$dom,$homeserver); |
| |
unless ($response =~ /(con_lost|error|no_such_host|refused)/) { |
| |
my @items = split(/&/,$response); |
| |
foreach my $item (@items) { |
| |
my ($key,$value) = split('=',$item); |
| |
$validations{&unescape($key)} = &thaw_unescape($value); |
| |
} |
| |
} |
| |
} |
| |
return %validations; |
| |
} |
| |
|
| |
sub auto_courserequest_validation { |
| |
my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist) = @_; |
| |
my ($homeserver,$response); |
| |
if ($dom =~ /^$match_domain$/) { |
| |
$homeserver = &domain($dom,'primary'); |
| |
} |
| |
unless ($homeserver eq 'no_host') { |
| |
|
| |
$response=&unescape(&reply('autocrsreqvalidation:'.$dom.':'.&escape($owner). |
| |
':'.&escape($crstype).':'.&escape($inststatuslist). |
| |
':'.&escape($instcode).':'.&escape($instseclist), |
| |
$homeserver)); |
| |
} |
| |
return $response; |
| |
} |
| |
|
| sub auto_validate_class_sec { |
sub auto_validate_class_sec { |
| my ($cdom,$cnum,$owners,$inst_class) = @_; |
my ($cdom,$cnum,$owners,$inst_class) = @_; |
|
Line 5418 sub devalidate_getgroups_cache {
|
Line 6284 sub devalidate_getgroups_cache {
|
| # ------------------------------------------------------------------ Plain Text |
# ------------------------------------------------------------------ Plain Text |
| |
|
| sub plaintext { |
sub plaintext { |
| my ($short,$type,$cid) = @_; |
my ($short,$type,$cid,$forcedefault) = @_; |
| if ($short =~ /^cr/) { |
if ($short =~ m{^cr/}) { |
| return (split('/',$short))[-1]; |
return (split('/',$short))[-1]; |
| } |
} |
| if (!defined($cid)) { |
if (!defined($cid)) { |
| $cid = $env{'request.course.id'}; |
$cid = $env{'request.course.id'}; |
| } |
} |
| if (defined($cid) && defined($env{'course.'.$cid.'.'.$short.'.plaintext'})) { |
|
| return &Apache::lonlocal::mt($env{'course.'.$cid.'.'.$short. |
|
| '.plaintext'}); |
|
| } |
|
| my %rolenames = ( |
my %rolenames = ( |
| Course => 'std', |
Course => 'std', |
| Group => 'alt1', |
Community => 'alt1', |
| ); |
); |
| if (defined($type) && |
if ($cid ne '') { |
| defined($rolenames{$type}) && |
if ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '') { |
| defined($prp{$short}{$rolenames{$type}})) { |
unless ($forcedefault) { |
| |
my $roletext = $env{'course.'.$cid.'.'.$short.'.plaintext'}; |
| |
&Apache::lonlocal::mt_escape(\$roletext); |
| |
return &Apache::lonlocal::mt($roletext); |
| |
} |
| |
} |
| |
} |
| |
if ((defined($type)) && (defined($rolenames{$type})) && |
| |
(defined($rolenames{$type})) && |
| |
(defined($prp{$short}{$rolenames{$type}}))) { |
| return &Apache::lonlocal::mt($prp{$short}{$rolenames{$type}}); |
return &Apache::lonlocal::mt($prp{$short}{$rolenames{$type}}); |
| } else { |
} elsif ($cid ne '') { |
| return &Apache::lonlocal::mt($prp{$short}{'std'}); |
my $crstype = $env{'course.'.$cid.'.type'}; |
| |
if (($crstype ne '') && (defined($rolenames{$crstype})) && |
| |
(defined($prp{$short}{$rolenames{$crstype}}))) { |
| |
return &Apache::lonlocal::mt($prp{$short}{$rolenames{$crstype}}); |
| |
} |
| } |
} |
| |
return &Apache::lonlocal::mt($prp{$short}{'std'}); |
| } |
} |
| |
|
| # ----------------------------------------------------------------- Assign Role |
# ----------------------------------------------------------------- Assign Role |
|
Line 5452 sub assignrole {
|
Line 6328 sub assignrole {
|
| my $cwosec=$url; |
my $cwosec=$url; |
| $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/; |
$cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/; |
| unless (&allowed('ccr',$cwosec)) { |
unless (&allowed('ccr',$cwosec)) { |
| &logthis('Refused custom assignrole: '. |
my $refused = 1; |
| $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. |
if ($context eq 'requestcourses') { |
| $env{'user.name'}.' at '.$env{'user.domain'}); |
if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) { |
| return 'refused'; |
if ($role =~ m{^cr/($match_domain)/($match_username)/([^/]+)$}) { |
| |
if (($1 eq $env{'user.domain'}) && ($2 eq $env{'user.name'})) { |
| |
my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$}); |
| |
my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner')); |
| |
if ($crsenv{'internal.courseowner'} eq |
| |
$env{'user.name'}.':'.$env{'user.domain'}) { |
| |
$refused = ''; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if ($refused) { |
| |
&logthis('Refused custom assignrole: '. |
| |
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start. |
| |
' by '.$env{'user.name'}.' at '.$env{'user.domain'}); |
| |
return 'refused'; |
| |
} |
| } |
} |
| $mrole='cr'; |
$mrole='cr'; |
| } elsif ($role =~ /^gr\//) { |
} elsif ($role =~ /^gr\//) { |
|
Line 5481 sub assignrole {
|
Line 6374 sub assignrole {
|
| $refused = 1; |
$refused = 1; |
| } |
} |
| if ($refused) { |
if ($refused) { |
| if (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { |
my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$}); |
| |
if (!$selfenroll && $context eq 'course') { |
| |
my %crsenv; |
| |
if ($role eq 'cc' || $role eq 'co') { |
| |
%crsenv = &userenvironment($cdom,$cnum,('internal.courseowner')); |
| |
if (($role eq 'cc') && ($cnum !~ /^$match_community$/)) { |
| |
if ($env{'request.role'} eq 'cc./'.$cdom.'/'.$cnum) { |
| |
if ($crsenv{'internal.courseowner'} eq |
| |
$env{'user.name'}.':'.$env{'user.domain'}) { |
| |
$refused = ''; |
| |
} |
| |
} |
| |
} elsif (($role eq 'co') && ($cnum =~ /^$match_community$/)) { |
| |
if ($env{'request.role'} eq 'co./'.$cdom.'/'.$cnum) { |
| |
if ($crsenv{'internal.courseowner'} eq |
| |
$env{'user.name'}.':'.$env{'user.domain'}) { |
| |
$refused = ''; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} elsif (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { |
| $refused = ''; |
$refused = ''; |
| } else { |
} elsif ($context eq 'requestcourses') { |
| |
my @possroles = ('st','ta','ep','in','cc','co'); |
| |
if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) { |
| |
my $wrongcc; |
| |
if ($cnum =~ /^$match_community$/) { |
| |
$wrongcc = 1 if ($role eq 'cc'); |
| |
} else { |
| |
$wrongcc = 1 if ($role eq 'co'); |
| |
} |
| |
unless ($wrongcc) { |
| |
my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner')); |
| |
if ($crsenv{'internal.courseowner'} eq |
| |
$env{'user.name'}.':'.$env{'user.domain'}) { |
| |
$refused = ''; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if ($refused) { |
| &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url. |
&logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url. |
| ' '.$role.' '.$end.' '.$start.' by '. |
' '.$role.' '.$end.' '.$start.' by '. |
| $env{'user.name'}.' at '.$env{'user.domain'}); |
$env{'user.name'}.' at '.$env{'user.domain'}); |
|
Line 5530 sub assignrole {
|
Line 6462 sub assignrole {
|
| &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend, |
&Apache::longroup::group_changes($udom,$uname,$url,$role,$origend, |
| $origstart,$selfenroll,$context); |
$origstart,$selfenroll,$context); |
| } |
} |
| |
if ($role eq 'cc') { |
| |
&autoupdate_coowners($url,$end,$start,$uname,$udom); |
| |
} |
| } |
} |
| return $answer; |
return $answer; |
| } |
} |
| |
|
| |
sub autoupdate_coowners { |
| |
my ($url,$end,$start,$uname,$udom) = @_; |
| |
my ($cdom,$cnum) = ($url =~ m{^/($match_domain)/($match_courseid)}); |
| |
if (($cdom ne '') && ($cnum ne '')) { |
| |
my $now = time; |
| |
my %domdesign = &Apache::loncommon::get_domainconf($cdom); |
| |
if ($domdesign{$cdom.'.autoassign.co-owners'}) { |
| |
my %coursehash = &coursedescription($cdom.'_'.$cnum); |
| |
my $instcode = $coursehash{'internal.coursecode'}; |
| |
if ($instcode ne '') { |
| |
if (($start && $start <= $now) && ($end == 0) || ($end > $now)) { |
| |
unless ($coursehash{'internal.courseowner'} eq $uname.':'.$udom) { |
| |
my ($delcoowners,@newcoowners,$putresult,$delresult,$coowners); |
| |
my ($result,$desc) = &auto_validate_instcode($cnum,$cdom,$instcode,$uname.':'.$udom); |
| |
if ($result eq 'valid') { |
| |
if ($coursehash{'internal.co-owners'}) { |
| |
foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) { |
| |
push(@newcoowners,$coowner); |
| |
} |
| |
unless (grep(/^\Q$uname\E:\Q$udom\E$/,@newcoowners)) { |
| |
push(@newcoowners,$uname.':'.$udom); |
| |
} |
| |
@newcoowners = sort(@newcoowners); |
| |
} else { |
| |
push(@newcoowners,$uname.':'.$udom); |
| |
} |
| |
} else { |
| |
if ($coursehash{'internal.co-owners'}) { |
| |
foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) { |
| |
unless ($coowner eq $uname.':'.$udom) { |
| |
push(@newcoowners,$coowner); |
| |
} |
| |
} |
| |
unless (@newcoowners > 0) { |
| |
$delcoowners = 1; |
| |
$coowners = ''; |
| |
} |
| |
} |
| |
} |
| |
if (@newcoowners || $delcoowners) { |
| |
&store_coowners($cdom,$cnum,$coursehash{'home'}, |
| |
$delcoowners,@newcoowners); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
|
| |
sub store_coowners { |
| |
my ($cdom,$cnum,$chome,$delcoowners,@newcoowners) = @_; |
| |
my $cid = $cdom.'_'.$cnum; |
| |
my ($coowners,$delresult,$putresult); |
| |
if (@newcoowners) { |
| |
$coowners = join(',',@newcoowners); |
| |
my %coownershash = ( |
| |
'internal.co-owners' => $coowners, |
| |
); |
| |
$putresult = &put('environment',\%coownershash,$cdom,$cnum); |
| |
if ($putresult eq 'ok') { |
| |
if ($env{'course.'.$cid.'.num'} eq $cnum) { |
| |
&appenv({'course.'.$cid.'.internal.co-owners' => $coowners}); |
| |
} |
| |
} |
| |
} |
| |
if ($delcoowners) { |
| |
$delresult = &Apache::lonnet::del('environment',['internal.co-owners'],$cdom,$cnum); |
| |
if ($delresult eq 'ok') { |
| |
if ($env{'course.'.$cid.'.internal.co-owners'}) { |
| |
&Apache::lonnet::delenv('course.'.$cid.'.internal.co-owners'); |
| |
} |
| |
} |
| |
} |
| |
if (($putresult eq 'ok') || ($delresult eq 'ok')) { |
| |
my %crsinfo = |
| |
&Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.'); |
| |
if (ref($crsinfo{$cid}) eq 'HASH') { |
| |
$crsinfo{$cid}{'co-owners'} = \@newcoowners; |
| |
my $cidput = &Apache::lonnet::courseidput($cdom,\%crsinfo,$chome,'notime'); |
| |
} |
| |
} |
| |
} |
| |
|
| # -------------------------------------------------- Modify user authentication |
# -------------------------------------------------- Modify user authentication |
| # Overrides without validation |
# Overrides without validation |
| |
|
|
Line 5566 sub modifyuser {
|
Line 6585 sub modifyuser {
|
| my ($udom, $uname, $uid, |
my ($udom, $uname, $uid, |
| $umode, $upass, $first, |
$umode, $upass, $first, |
| $middle, $last, $gene, |
$middle, $last, $gene, |
| $forceid, $desiredhome, $email, $inststatus)=@_; |
$forceid, $desiredhome, $email, $inststatus, $candelete)=@_; |
| $udom= &LONCAPA::clean_domain($udom); |
$udom= &LONCAPA::clean_domain($udom); |
| $uname=&LONCAPA::clean_username($uname); |
$uname=&LONCAPA::clean_username($uname); |
| |
my $showcandelete = 'none'; |
| |
if (ref($candelete) eq 'ARRAY') { |
| |
if (@{$candelete} > 0) { |
| |
$showcandelete = join(', ',@{$candelete}); |
| |
} |
| |
} |
| &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. |
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. |
| $umode.', '.$first.', '.$middle.', '. |
$umode.', '.$first.', '.$middle.', '. |
| $last.', '.$gene.'(forceid: '.$forceid.')'. |
$last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$showcandelete.')'. |
| (defined($desiredhome) ? ' desiredhome = '.$desiredhome : |
(defined($desiredhome) ? ' desiredhome = '.$desiredhome : |
| ' desiredhome not specified'). |
' desiredhome not specified'). |
| ' by '.$env{'user.name'}.' at '.$env{'user.domain'}. |
' by '.$env{'user.name'}.' at '.$env{'user.domain'}. |
| ' in domain '.$env{'request.role.domain'}); |
' in domain '.$env{'request.role.domain'}); |
| my $uhome=&homeserver($uname,$udom,'true'); |
my $uhome=&homeserver($uname,$udom,'true'); |
| |
my $newuser; |
| |
if ($uhome eq 'no_host') { |
| |
$newuser = 1; |
| |
} |
| # ----------------------------------------------------------------- Create User |
# ----------------------------------------------------------------- Create User |
| if (($uhome eq 'no_host') && |
if (($uhome eq 'no_host') && |
| (($umode && $upass) || ($umode eq 'localauth'))) { |
(($umode && $upass) || ($umode eq 'localauth'))) { |
|
Line 5629 sub modifyuser {
|
Line 6658 sub modifyuser {
|
| ['firstname','middlename','lastname','generation','id', |
['firstname','middlename','lastname','generation','id', |
| 'permanentemail','inststatus'], |
'permanentemail','inststatus'], |
| $udom,$uname); |
$udom,$uname); |
| my %names; |
my (%names,%oldnames); |
| if ($tmp[0] =~ m/^error:.*/) { |
if ($tmp[0] =~ m/^error:.*/) { |
| %names=(); |
%names=(); |
| } else { |
} else { |
| %names = @tmp; |
%names = @tmp; |
| |
%oldnames = %names; |
| } |
} |
| # |
# |
| # Make sure to not trash student environment if instructor does not bother |
# If name, email and/or uid are blank (e.g., because an uploaded file |
| # to supply name and email information |
# of users did not contain them), do not overwrite existing values |
| # |
# unless field is in $candelete array ref. |
| |
# |
| |
|
| |
my @fields = ('firstname','middlename','lastname','generation', |
| |
'permanentemail','id'); |
| |
my %newvalues; |
| |
if (ref($candelete) eq 'ARRAY') { |
| |
foreach my $field (@fields) { |
| |
if (grep(/^\Q$field\E$/,@{$candelete})) { |
| |
if ($field eq 'firstname') { |
| |
$names{$field} = $first; |
| |
} elsif ($field eq 'middlename') { |
| |
$names{$field} = $middle; |
| |
} elsif ($field eq 'lastname') { |
| |
$names{$field} = $last; |
| |
} elsif ($field eq 'generation') { |
| |
$names{$field} = $gene; |
| |
} elsif ($field eq 'permanentemail') { |
| |
$names{$field} = $email; |
| |
} elsif ($field eq 'id') { |
| |
$names{$field} = $uid; |
| |
} |
| |
} |
| |
} |
| |
} |
| if ($first) { $names{'firstname'} = $first; } |
if ($first) { $names{'firstname'} = $first; } |
| if (defined($middle)) { $names{'middlename'} = $middle; } |
if (defined($middle)) { $names{'middlename'} = $middle; } |
| if ($last) { $names{'lastname'} = $last; } |
if ($last) { $names{'lastname'} = $last; } |
|
Line 5648 sub modifyuser {
|
Line 6702 sub modifyuser {
|
| if ($email=~/\@/) { $names{'permanentemail'} = $email; } |
if ($email=~/\@/) { $names{'permanentemail'} = $email; } |
| } |
} |
| if ($uid) { $names{'id'} = $uid; } |
if ($uid) { $names{'id'} = $uid; } |
| if (defined($inststatus)) { $names{'inststatus'} = $inststatus; } |
if (defined($inststatus)) { |
| my $reply = &put('environment', \%names, $udom,$uname); |
$names{'inststatus'} = ''; |
| if ($reply ne 'ok') { return 'error: '.$reply; } |
my ($usertypes,$typesorder) = &retrieve_inst_usertypes($udom); |
| my $sqlresult = &update_allusers_table($uname,$udom,\%names); |
if (ref($usertypes) eq 'HASH') { |
| &devalidate_cache_new('namescache',$uname.':'.$udom); |
my @okstatuses; |
| my $logmsg = 'Success modifying user '.$udom.', '.$uname.', '.$uid.', '. |
foreach my $item (split(/:/,$inststatus)) { |
| |
if (defined($usertypes->{$item})) { |
| |
push(@okstatuses,$item); |
| |
} |
| |
} |
| |
if (@okstatuses) { |
| |
$names{'inststatus'} = join(':', map { &escape($_); } @okstatuses); |
| |
} |
| |
} |
| |
} |
| |
my $logmsg = $udom.', '.$uname.', '.$uid.', '. |
| $umode.', '.$first.', '.$middle.', '. |
$umode.', '.$first.', '.$middle.', '. |
| $last.', '.$gene.', '.$email.', '.$inststatus; |
$last.', '.$gene.', '.$email.', '.$inststatus; |
| if ($env{'user.name'} ne '' && $env{'user.domain'}) { |
if ($env{'user.name'} ne '' && $env{'user.domain'}) { |
| $logmsg .= ' by '.$env{'user.name'}.' at '.$env{'user.domain'}; |
$logmsg .= ' by '.$env{'user.name'}.' at '.$env{'user.domain'}; |
| } else { |
} else { |
| $logmsg .= ' during self creation'; |
$logmsg .= ' during self creation'; |
| } |
} |
| |
my $changed; |
| |
if ($newuser) { |
| |
$changed = 1; |
| |
} else { |
| |
foreach my $field (@fields) { |
| |
if ($names{$field} ne $oldnames{$field}) { |
| |
$changed = 1; |
| |
last; |
| |
} |
| |
} |
| |
} |
| |
unless ($changed) { |
| |
$logmsg = 'No changes in user information needed for: '.$logmsg; |
| |
&logthis($logmsg); |
| |
return 'ok'; |
| |
} |
| |
my $reply = &put('environment', \%names, $udom,$uname); |
| |
if ($reply ne 'ok') { |
| |
return 'error: '.$reply; |
| |
} |
| |
my $sqlresult = &update_allusers_table($uname,$udom,\%names); |
| |
&devalidate_cache_new('namescache',$uname.':'.$udom); |
| |
$logmsg = 'Success modifying user '.$logmsg; |
| &logthis($logmsg); |
&logthis($logmsg); |
| return 'ok'; |
return 'ok'; |
| } |
} |
|
Line 5670 sub modifyuser {
|
Line 6757 sub modifyuser {
|
| sub modifystudent { |
sub modifystudent { |
| my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, |
my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, |
| $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid, |
$end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid, |
| $selfenroll,$context)=@_; |
$selfenroll,$context,$inststatus)=@_; |
| if (!$cid) { |
if (!$cid) { |
| unless ($cid=$env{'request.course.id'}) { |
unless ($cid=$env{'request.course.id'}) { |
| return 'not_in_class'; |
return 'not_in_class'; |
|
Line 5679 sub modifystudent {
|
Line 6766 sub modifystudent {
|
| # --------------------------------------------------------------- Make the user |
# --------------------------------------------------------------- Make the user |
| my $reply=&modifyuser |
my $reply=&modifyuser |
| ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid, |
($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid, |
| $desiredhome,$email); |
$desiredhome,$email,$inststatus); |
| unless ($reply eq 'ok') { return $reply; } |
unless ($reply eq 'ok') { return $reply; } |
| # This will cause &modify_student_enrollment to get the uid from the |
# This will cause &modify_student_enrollment to get the uid from the |
| # students environment |
# students environment |
|
Line 5793 sub writecoursepref {
|
Line 6880 sub writecoursepref {
|
| |
|
| sub createcourse { |
sub createcourse { |
| my ($udom,$description,$url,$course_server,$nonstandard,$inst_code, |
my ($udom,$description,$url,$course_server,$nonstandard,$inst_code, |
| $course_owner,$crstype)=@_; |
$course_owner,$crstype,$cnum,$context,$category)=@_; |
| $url=&declutter($url); |
$url=&declutter($url); |
| my $cid=''; |
my $cid=''; |
| unless (&allowed('ccc',$udom)) { |
if ($context eq 'requestcourses') { |
| |
my $can_create = 0; |
| |
my ($ownername,$ownerdom) = split(':',$course_owner); |
| |
if ($udom eq $ownerdom) { |
| |
if (&usertools_access($ownername,$ownerdom,$category,undef, |
| |
$context)) { |
| |
$can_create = 1; |
| |
} |
| |
} else { |
| |
my %userenv = &userenvironment($ownerdom,$ownername,'reqcrsotherdom.'. |
| |
$category); |
| |
if ($userenv{'reqcrsotherdom.'.$category} ne '') { |
| |
my @curr = split(',',$userenv{'reqcrsotherdom.'.$category}); |
| |
if (@curr > 0) { |
| |
my @options = qw(approval validate autolimit); |
| |
my $optregex = join('|',@options); |
| |
if (grep(/^\Q$udom\E:($optregex)(=?\d*)$/,@curr)) { |
| |
$can_create = 1; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if ($can_create) { |
| |
unless ($ownername eq $env{'user.name'} && $ownerdom eq $env{'user.domain'}) { |
| |
unless (&allowed('ccc',$udom)) { |
| |
return 'refused'; |
| |
} |
| |
} |
| |
} else { |
| |
return 'refused'; |
| |
} |
| |
} elsif (!&allowed('ccc',$udom)) { |
| return 'refused'; |
return 'refused'; |
| } |
} |
| # ------------------------------------------------------------------- Create ID |
# --------------------------------------------------------------- Get Unique ID |
| my $uname=int(1+rand(9)). |
my $uname; |
| ('a'..'z','A'..'Z','0'..'9')[int(rand(62))]. |
if ($cnum =~ /^$match_courseid$/) { |
| substr($$.time,0,5).unpack("H8",pack("I32",time)). |
my $chome=&homeserver($cnum,$udom,'true'); |
| unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; |
if (($chome eq '') || ($chome eq 'no_host')) { |
| # ----------------------------------------------- Make sure that does not exist |
$uname = $cnum; |
| my $uhome=&homeserver($uname,$udom,'true'); |
} else { |
| unless (($uhome eq '') || ($uhome eq 'no_host')) { |
$uname = &generate_coursenum($udom,$crstype); |
| $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)). |
} |
| unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; |
} else { |
| $uhome=&homeserver($uname,$udom,'true'); |
$uname = &generate_coursenum($udom,$crstype); |
| unless (($uhome eq '') || ($uhome eq 'no_host')) { |
} |
| return 'error: unable to generate unique course-ID'; |
return $uname if ($uname =~ /^error/); |
| } |
# -------------------------------------------------- Check supplied server name |
| } |
if (!defined($course_server)) { |
| # ------------------------------------------------ Check supplied server name |
if (defined(&domain($udom,'primary'))) { |
| $course_server = $env{'user.homeserver'} if (! defined($course_server)); |
$course_server = &domain($udom,'primary'); |
| if (! &is_library($course_server)) { |
} else { |
| return 'error:bad server name '.$course_server; |
$course_server = $env{'user.home'}; |
| |
} |
| |
} |
| |
my %host_servers = |
| |
&Apache::lonnet::get_servers($udom,'library'); |
| |
unless ($host_servers{$course_server}) { |
| |
return 'error: invalid home server for course: '.$course_server; |
| } |
} |
| # ------------------------------------------------------------- Make the course |
# ------------------------------------------------------------- Make the course |
| my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::', |
my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::', |
| $course_server); |
$course_server); |
| unless ($reply eq 'ok') { return 'error: '.$reply; } |
unless ($reply eq 'ok') { return 'error: '.$reply; } |
| $uhome=&homeserver($uname,$udom,'true'); |
my $uhome=&homeserver($uname,$udom,'true'); |
| if (($uhome eq '') || ($uhome eq 'no_host')) { |
if (($uhome eq '') || ($uhome eq 'no_host')) { |
| return 'error: no such course'; |
return 'error: no such course'; |
| } |
} |
| # ----------------------------------------------------------------- Course made |
# ----------------------------------------------------------------- Course made |
| # log existence |
# log existence |
| |
my $now = time; |
| my $newcourse = { |
my $newcourse = { |
| $udom.'_'.$uname => { |
$udom.'_'.$uname => { |
| description => $description, |
description => $description, |
| inst_code => $inst_code, |
inst_code => $inst_code, |
| owner => $course_owner, |
owner => $course_owner, |
| type => $crstype, |
type => $crstype, |
| |
creator => $env{'user.name'}.':'. |
| |
$env{'user.domain'}, |
| |
created => $now, |
| |
context => $context, |
| }, |
}, |
| }; |
}; |
| &courseidput($udom,$newcourse,$uhome,'notime'); |
&courseidput($udom,$newcourse,$uhome,'notime'); |
|
Line 5859 ENDINITMAP
|
Line 6988 ENDINITMAP
|
| } |
} |
| # ----------------------------------------------------------- Write preferences |
# ----------------------------------------------------------- Write preferences |
| &writecoursepref($udom.'_'.$uname, |
&writecoursepref($udom.'_'.$uname, |
| ('description' => $description, |
('description' => $description, |
| 'url' => $topurl)); |
'url' => $topurl, |
| |
'internal.creator' => $env{'user.name'}.':'. |
| |
$env{'user.domain'}, |
| |
'internal.created' => $now, |
| |
'internal.creationcontext' => $context) |
| |
); |
| return '/'.$udom.'/'.$uname; |
return '/'.$udom.'/'.$uname; |
| } |
} |
| |
|
| |
# ------------------------------------------------------------------- Create ID |
| |
sub generate_coursenum { |
| |
my ($udom,$crstype) = @_; |
| |
my $domdesc = &domain($udom); |
| |
return 'error: invalid domain' if ($domdesc eq ''); |
| |
my $first; |
| |
if ($crstype eq 'Community') { |
| |
$first = '0'; |
| |
} else { |
| |
$first = int(1+rand(9)); |
| |
} |
| |
my $uname=$first. |
| |
('a'..'z','A'..'Z','0'..'9')[int(rand(62))]. |
| |
substr($$.time,0,5).unpack("H8",pack("I32",time)). |
| |
unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; |
| |
# ----------------------------------------------- Make sure that does not exist |
| |
my $uhome=&homeserver($uname,$udom,'true'); |
| |
unless (($uhome eq '') || ($uhome eq 'no_host')) { |
| |
if ($crstype eq 'Community') { |
| |
$first = '0'; |
| |
} else { |
| |
$first = int(1+rand(9)); |
| |
} |
| |
$uname=$first. |
| |
('a'..'z','A'..'Z','0'..'9')[int(rand(62))]. |
| |
substr($$.time,0,5).unpack("H8",pack("I32",time)). |
| |
unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; |
| |
$uhome=&homeserver($uname,$udom,'true'); |
| |
unless (($uhome eq '') || ($uhome eq 'no_host')) { |
| |
return 'error: unable to generate unique course-ID'; |
| |
} |
| |
} |
| |
return $uname; |
| |
} |
| |
|
| sub is_course { |
sub is_course { |
| my ($cdom,$cnum) = @_; |
my ($cdom,$cnum) = @_; |
| my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef, |
my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef, |
|
Line 5874 sub is_course {
|
Line 7043 sub is_course {
|
| return 0; |
return 0; |
| } |
} |
| |
|
| |
sub store_userdata { |
| |
my ($storehash,$datakey,$namespace,$udom,$uname) = @_; |
| |
my $result; |
| |
if ($datakey ne '') { |
| |
if (ref($storehash) eq 'HASH') { |
| |
if ($udom eq '' || $uname eq '') { |
| |
$udom = $env{'user.domain'}; |
| |
$uname = $env{'user.name'}; |
| |
} |
| |
my $uhome=&homeserver($uname,$udom); |
| |
if (($uhome eq '') || ($uhome eq 'no_host')) { |
| |
$result = 'error: no_host'; |
| |
} else { |
| |
$storehash->{'ip'} = $ENV{'REMOTE_ADDR'}; |
| |
$storehash->{'host'} = $perlvar{'lonHostID'}; |
| |
|
| |
my $namevalue=''; |
| |
foreach my $key (keys(%{$storehash})) { |
| |
$namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&'; |
| |
} |
| |
$namevalue=~s/\&$//; |
| |
$result = &reply("store:$env{'user.domain'}:$env{'user.name'}:". |
| |
"$namespace:$datakey:$namevalue",$uhome); |
| |
} |
| |
} else { |
| |
$result = 'error: data to store was not a hash reference'; |
| |
} |
| |
} else { |
| |
$result= 'error: invalid requestkey'; |
| |
} |
| |
return $result; |
| |
} |
| |
|
| # ---------------------------------------------------------- Assign Custom Role |
# ---------------------------------------------------------- Assign Custom Role |
| |
|
| sub assigncustomrole { |
sub assigncustomrole { |
|
Line 7078 sub add_prefix_and_part {
|
Line 8280 sub add_prefix_and_part {
|
| # ---------------------------------------------------------------- Get metadata |
# ---------------------------------------------------------------- Get metadata |
| |
|
| my %metaentry; |
my %metaentry; |
| |
my %importedpartids; |
| sub metadata { |
sub metadata { |
| my ($uri,$what,$liburi,$prefix,$depthcount)=@_; |
my ($uri,$what,$liburi,$prefix,$depthcount)=@_; |
| $uri=&declutter($uri); |
$uri=&declutter($uri); |
|
Line 7104 sub metadata {
|
Line 8307 sub metadata {
|
| if (defined($cached)) { return $result->{':'.$what}; } |
if (defined($cached)) { return $result->{':'.$what}; } |
| } |
} |
| { |
{ |
| |
# Imported parts would go here |
| |
my %importedids=(); |
| |
my @origfileimportpartids=(); |
| |
my $importedparts=0; |
| # |
# |
| # Is this a recursive call for a library? |
# Is this a recursive call for a library? |
| # |
# |
|
Line 7187 sub metadata {
|
Line 8394 sub metadata {
|
| # This is not a package - some other kind of start tag |
# This is not a package - some other kind of start tag |
| # |
# |
| my $entry=$token->[1]; |
my $entry=$token->[1]; |
| my $unikey; |
my $unikey=''; |
| if ($entry eq 'import') { |
|
| $unikey=''; |
|
| } else { |
|
| $unikey=$entry; |
|
| } |
|
| $unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'}); |
|
| |
|
| if (defined($token->[2]->{'id'})) { |
|
| $unikey.='_'.$token->[2]->{'id'}; |
|
| } |
|
| |
|
| if ($entry eq 'import') { |
if ($entry eq 'import') { |
| # |
# |
| # Importing a library here |
# Importing a library here |
| # |
# |
| |
my $location=$parser->get_text('/import'); |
| |
my $dir=$filename; |
| |
$dir=~s|[^/]*$||; |
| |
$location=&filelocation($dir,$location); |
| |
|
| |
my $importmode=$token->[2]->{'importmode'}; |
| |
if ($importmode eq 'problem') { |
| |
# Import as problem/response |
| |
$unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); |
| |
} elsif ($importmode eq 'part') { |
| |
# Import as part(s) |
| |
$importedparts=1; |
| |
# We need to get the original file and the imported file to get the part order correct |
| |
# Good news: we do not need to worry about nested libraries, since parts cannot be nested |
| |
# Load and inspect original file |
| |
if ($#origfileimportpartids<0) { |
| |
undef(%importedpartids); |
| |
my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri); |
| |
my $origfile=&getfile($origfilelocation); |
| |
@origfileimportpartids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); |
| |
} |
| |
|
| |
# Load and inspect imported file |
| |
my $impfile=&getfile($location); |
| |
my @impfilepartids=($impfile=~/<part[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); |
| |
if ($#impfilepartids>=0) { |
| |
# This problem had parts |
| |
$importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids); |
| |
} else { |
| |
# Importing by turning a single problem into a problem part |
| |
# It gets the import-tags ID as part-ID |
| |
$unikey=&add_prefix_and_part($prefix,$token->[2]->{'id'}); |
| |
$importedpartids{$token->[2]->{'id'}}=$token->[2]->{'id'}; |
| |
} |
| |
} else { |
| |
# Normal import |
| |
$unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); |
| |
if (defined($token->[2]->{'id'})) { |
| |
$unikey.='_'.$token->[2]->{'id'}; |
| |
} |
| |
} |
| |
|
| if ($depthcount<20) { |
if ($depthcount<20) { |
| my $location=$parser->get_text('/import'); |
|
| my $dir=$filename; |
|
| $dir=~s|[^/]*$||; |
|
| $location=&filelocation($dir,$location); |
|
| my $metadata = |
my $metadata = |
| &metadata($uri,'keys', $location,$unikey, |
&metadata($uri,'keys', $location,$unikey, |
| $depthcount+1); |
$depthcount+1); |
|
Line 7215 sub metadata {
|
Line 8450 sub metadata {
|
| $metaentry{':'.$meta}=$metaentry{':'.$meta}; |
$metaentry{':'.$meta}=$metaentry{':'.$meta}; |
| $metathesekeys{$meta}=1; |
$metathesekeys{$meta}=1; |
| } |
} |
| } |
|
| } else { |
|
| |
|
| |
} |
| |
} else { |
| |
# |
| |
# Not importing, some other kind of non-package, non-library start tag |
| |
# |
| |
$unikey=$entry.&add_prefix_and_part($prefix,$token->[2]->{'part'}); |
| |
if (defined($token->[2]->{'id'})) { |
| |
$unikey.='_'.$token->[2]->{'id'}; |
| |
} |
| if (defined($token->[2]->{'name'})) { |
if (defined($token->[2]->{'name'})) { |
| $unikey.='_'.$token->[2]->{'name'}; |
$unikey.='_'.$token->[2]->{'name'}; |
| } |
} |
|
Line 7291 sub metadata {
|
Line 8533 sub metadata {
|
| grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'})); |
grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'})); |
| $metaentry{':packages'} = join(',',@uniq_packages); |
$metaentry{':packages'} = join(',',@uniq_packages); |
| |
|
| |
if ($importedparts) { |
| |
# We had imported parts and need to rebuild partorder |
| |
$metaentry{':partorder'}=''; |
| |
$metathesekeys{'partorder'}=1; |
| |
for (my $index=0;$index<$#origfileimportpartids;$index+=2) { |
| |
if ($origfileimportpartids[$index] eq 'part') { |
| |
# original part, part of the problem |
| |
$metaentry{':partorder'}.=','.$origfileimportpartids[$index+1]; |
| |
} else { |
| |
# we have imported parts at this position |
| |
$metaentry{':partorder'}.=','.$importedpartids{$origfileimportpartids[$index+1]}; |
| |
} |
| |
} |
| |
$metaentry{':partorder'}=~s/^\,//; |
| |
} |
| |
|
| $metaentry{':keys'} = join(',',keys(%metathesekeys)); |
$metaentry{':keys'} = join(',',keys(%metathesekeys)); |
| &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); |
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); |
| $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); |
$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); |
|
Line 7363 sub devalidate_title_cache {
|
Line 8621 sub devalidate_title_cache {
|
| &devalidate_cache_new('title',$key); |
&devalidate_cache_new('title',$key); |
| } |
} |
| |
|
| |
# ------------------------------------------------- Get the title of a course |
| |
|
| |
sub current_course_title { |
| |
return $env{ 'course.' . $env{'request.course.id'} . '.description' }; |
| |
} |
| # ------------------------------------------------- Get the title of a resource |
# ------------------------------------------------- Get the title of a resource |
| |
|
| sub gettitle { |
sub gettitle { |
|
Line 7429 sub symblist {
|
Line 8692 sub symblist {
|
| if (($env{'request.course.fn'}) && (%newhash)) { |
if (($env{'request.course.fn'}) && (%newhash)) { |
| if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db', |
if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db', |
| &GDBM_WRCREAT(),0640)) { |
&GDBM_WRCREAT(),0640)) { |
| foreach my $url (keys %newhash) { |
foreach my $url (keys(%newhash)) { |
| next if ($url eq 'last_known' |
next if ($url eq 'last_known' |
| && $env{'form.no_update_last_known'}); |
&& $env{'form.no_update_last_known'}); |
| $hash{declutter($url)}=&encode_symb($mapname, |
$hash{declutter($url)}=&encode_symb($mapname, |
|
Line 7466 sub symbverify {
|
Line 8729 sub symbverify {
|
| |
|
| if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db', |
if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db', |
| &GDBM_READER(),0640)) { |
&GDBM_READER(),0640)) { |
| |
if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) { |
| |
$thisurl =~ s/\?.+$//; |
| |
} |
| my $ids=$bighash{'ids_'.&clutter($thisurl)}; |
my $ids=$bighash{'ids_'.&clutter($thisurl)}; |
| unless ($ids) { |
unless ($ids) { |
| $ids=$bighash{'ids_/'.$thisurl}; |
$ids=$bighash{'ids_/'.$thisurl}; |
|
Line 7474 sub symbverify {
|
Line 8740 sub symbverify {
|
| # ------------------------------------------------------------------- Has ID(s) |
# ------------------------------------------------------------------- Has ID(s) |
| foreach my $id (split(/\,/,$ids)) { |
foreach my $id (split(/\,/,$ids)) { |
| my ($mapid,$resid)=split(/\./,$id); |
my ($mapid,$resid)=split(/\./,$id); |
| |
if ($thisfn =~ m{^/adm/wrapper/ext/}) { |
| |
$symb =~ s/\?.+$//; |
| |
} |
| if ( |
if ( |
| &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) |
&symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) |
| eq $symb) { |
eq $symb) { |
|
Line 8136 sub repcopy_userfile {
|
Line 9405 sub repcopy_userfile {
|
| if (-e $transferfile) { return 'ok'; } |
if (-e $transferfile) { return 'ok'; } |
| my $request; |
my $request; |
| $uri=~s/^\///; |
$uri=~s/^\///; |
| $request=new HTTP::Request('GET','http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri); |
my $homeserver = &homeserver($cnum,$cdom); |
| |
my $protocol = $protocol{$homeserver}; |
| |
$protocol = 'http' if ($protocol ne 'https'); |
| |
$request=new HTTP::Request('GET',$protocol.'://'.&hostname($homeserver).'/raw/'.$uri); |
| my $response=$ua->request($request,$transferfile); |
my $response=$ua->request($request,$transferfile); |
| # did it work? |
# did it work? |
| if ($response->is_error()) { |
if ($response->is_error()) { |
|
Line 8151 sub repcopy_userfile {
|
Line 9423 sub repcopy_userfile {
|
| |
|
| sub tokenwrapper { |
sub tokenwrapper { |
| my $uri=shift; |
my $uri=shift; |
| $uri=~s|^http\://([^/]+)||; |
$uri=~s|^https?\://([^/]+)||; |
| $uri=~s|^/||; |
$uri=~s|^/||; |
| $env{'user.environment'}=~/\/([^\/]+)\.id/; |
$env{'user.environment'}=~/\/([^\/]+)\.id/; |
| my $token=$1; |
my $token=$1; |
|
Line 8159 sub tokenwrapper {
|
Line 9431 sub tokenwrapper {
|
| if ($udom && $uname && $file) { |
if ($udom && $uname && $file) { |
| $file=~s|(\?\.*)*$||; |
$file=~s|(\?\.*)*$||; |
| &appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}}); |
&appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}}); |
| return 'http://'.&hostname(&homeserver($uname,$udom)).'/'.$uri. |
my $homeserver = &homeserver($uname,$udom); |
| |
my $protocol = $protocol{$homeserver}; |
| |
$protocol = 'http' if ($protocol ne 'https'); |
| |
return $protocol.'://'.&hostname($homeserver).'/'.$uri. |
| (($uri=~/\?/)?'&':'?').'token='.$token. |
(($uri=~/\?/)?'&':'?').'token='.$token. |
| '&tokenissued='.$perlvar{'lonHostID'}; |
'&tokenissued='.$perlvar{'lonHostID'}; |
| } else { |
} else { |
|
Line 8174 sub tokenwrapper {
|
Line 9449 sub tokenwrapper {
|
| sub getuploaded { |
sub getuploaded { |
| my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_; |
my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_; |
| $uri=~s/^\///; |
$uri=~s/^\///; |
| $uri = 'http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri; |
my $homeserver = &homeserver($cnum,$cdom); |
| |
my $protocol = $protocol{$homeserver}; |
| |
$protocol = 'http' if ($protocol ne 'https'); |
| |
$uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri; |
| my $ua=new LWP::UserAgent; |
my $ua=new LWP::UserAgent; |
| my $request=new HTTP::Request($reqtype,$uri); |
my $request=new HTTP::Request($reqtype,$uri); |
| my $response=$ua->request($request); |
my $response=$ua->request($request); |
|
Line 8256 sub filelocation {
|
Line 9534 sub filelocation {
|
| |
|
| sub hreflocation { |
sub hreflocation { |
| my ($dir,$file)=@_; |
my ($dir,$file)=@_; |
| unless (($file=~m-^http://-i) || ($file=~m-^/-)) { |
unless (($file=~m-^https?\://-i) || ($file=~m-^/-)) { |
| $file=filelocation($dir,$file); |
$file=filelocation($dir,$file); |
| } elsif ($file=~m-^/adm/-) { |
} elsif ($file=~m-^/adm/-) { |
| $file=~s-^/adm/wrapper/-/-; |
$file=~s-^/adm/wrapper/-/-; |
|
Line 8341 sub declutter {
|
Line 9619 sub declutter {
|
| $thisfn=~s|^adm/wrapper/||; |
$thisfn=~s|^adm/wrapper/||; |
| $thisfn=~s|^adm/coursedocs/showdoc/||; |
$thisfn=~s|^adm/coursedocs/showdoc/||; |
| $thisfn=~s/^res\///; |
$thisfn=~s/^res\///; |
| $thisfn=~s/\?.+$//; |
unless (($thisfn =~ /^ext/) || ($thisfn =~ /\.(page|sequence)___\d+___ext/)) { |
| |
$thisfn=~s/\?.+$//; |
| |
} |
| return $thisfn; |
return $thisfn; |
| } |
} |
| |
|
|
Line 8353 sub clutter {
|
Line 9633 sub clutter {
|
| || $thisfn =~ m{^/adm/(includes|pages)} ) { |
|| $thisfn =~ m{^/adm/(includes|pages)} ) { |
| $thisfn='/res'.$thisfn; |
$thisfn='/res'.$thisfn; |
| } |
} |
| if ($thisfn !~m|/adm|) { |
if ($thisfn !~m|^/adm|) { |
| if ($thisfn =~ m|/ext/|) { |
if ($thisfn =~ m|^/ext/|) { |
| $thisfn='/adm/wrapper'.$thisfn; |
$thisfn='/adm/wrapper'.$thisfn; |
| } else { |
} else { |
| my ($ext) = ($thisfn =~ /\.(\w+)$/); |
my ($ext) = ($thisfn =~ /\.(\w+)$/); |
|
Line 8452 sub get_dns {
|
Line 9732 sub get_dns {
|
| open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); |
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); |
| foreach my $dns (<$config>) { |
foreach my $dns (<$config>) { |
| next if ($dns !~ /^\^(\S*)/x); |
next if ($dns !~ /^\^(\S*)/x); |
| $alldns{$1} = 1; |
my $line = $1; |
| |
my ($host,$protocol) = split(/:/,$line); |
| |
if ($protocol ne 'https') { |
| |
$protocol = 'http'; |
| |
} |
| |
$alldns{$host} = $protocol; |
| } |
} |
| while (%alldns) { |
while (%alldns) { |
| my ($dns) = keys(%alldns); |
my ($dns) = keys(%alldns); |
| delete($alldns{$dns}); |
|
| my $ua=new LWP::UserAgent; |
my $ua=new LWP::UserAgent; |
| my $request=new HTTP::Request('GET',"http://$dns$url"); |
my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url"); |
| my $response=$ua->request($request); |
my $response=$ua->request($request); |
| |
delete($alldns{$dns}); |
| next if ($response->is_error()); |
next if ($response->is_error()); |
| my @content = split("\n",$response->content); |
my @content = split("\n",$response->content); |
| &Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60); |
&Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60); |
|
Line 8524 sub get_dns {
|
Line 9809 sub get_dns {
|
| } |
} |
| return $domain{$name}{$what}; |
return $domain{$name}{$what}; |
| } |
} |
| |
|
| |
sub domain_info { |
| |
&load_domain_tab() if (!$loaded); |
| |
return %domain; |
| |
} |
| |
|
| } |
} |
| |
|
| |
|
|
Line 8534 sub get_dns {
|
Line 9825 sub get_dns {
|
| my %libserv; |
my %libserv; |
| my $loaded; |
my $loaded; |
| my %name_to_host; |
my %name_to_host; |
| |
my %internetdom; |
| |
|
| sub parse_hosts_tab { |
sub parse_hosts_tab { |
| my ($file) = @_; |
my ($file) = @_; |
|
Line 8541 sub get_dns {
|
Line 9833 sub get_dns {
|
| next if ($configline =~ /^(\#|\s*$ )/x); |
next if ($configline =~ /^(\#|\s*$ )/x); |
| next if ($configline =~ /^\^/); |
next if ($configline =~ /^\^/); |
| chomp($configline); |
chomp($configline); |
| my ($id,$domain,$role,$name,$protocol)=split(/:/,$configline); |
my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline); |
| $name=~s/\s//g; |
$name=~s/\s//g; |
| if ($id && $domain && $role && $name) { |
if ($id && $domain && $role && $name) { |
| $hostname{$id}=$name; |
$hostname{$id}=$name; |
|
Line 8557 sub get_dns {
|
Line 9849 sub get_dns {
|
| } else { |
} else { |
| $protocol{$id} = 'http'; |
$protocol{$id} = 'http'; |
| } |
} |
| |
if (defined($intdom)) { |
| |
$internetdom{$id} = $intdom; |
| |
} |
| } |
} |
| } |
} |
| } |
} |
|
Line 8601 sub get_dns {
|
Line 9896 sub get_dns {
|
| return %name_to_host; |
return %name_to_host; |
| } |
} |
| |
|
| |
sub all_host_domain { |
| |
&load_hosts_tab() if (!$loaded); |
| |
return %hostdom; |
| |
} |
| |
|
| sub is_library { |
sub is_library { |
| &load_hosts_tab() if (!$loaded); |
&load_hosts_tab() if (!$loaded); |
| |
|
|
Line 8613 sub get_dns {
|
Line 9913 sub get_dns {
|
| return %libserv; |
return %libserv; |
| } |
} |
| |
|
| |
sub unique_library { |
| |
#2x reverse removes all hostnames that appear more than once |
| |
my %unique = reverse &all_library(); |
| |
return reverse %unique; |
| |
} |
| |
|
| sub get_servers { |
sub get_servers { |
| &load_hosts_tab() if (!$loaded); |
&load_hosts_tab() if (!$loaded); |
| |
|
|
Line 8636 sub get_dns {
|
Line 9942 sub get_dns {
|
| return %result; |
return %result; |
| } |
} |
| |
|
| |
sub get_unique_servers { |
| |
my %unique = reverse &get_servers(@_); |
| |
return reverse %unique; |
| |
} |
| |
|
| sub host_domain { |
sub host_domain { |
| &load_hosts_tab() if (!$loaded); |
&load_hosts_tab() if (!$loaded); |
| |
|
|
Line 8650 sub get_dns {
|
Line 9961 sub get_dns {
|
| my @uniq = grep(!$seen{$_}++, values(%hostdom)); |
my @uniq = grep(!$seen{$_}++, values(%hostdom)); |
| return @uniq; |
return @uniq; |
| } |
} |
| |
|
| |
sub internet_dom { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| |
my ($lonid) = @_; |
| |
return $internetdom{$lonid}; |
| |
} |
| } |
} |
| |
|
| { |
{ |
|
Line 8742 sub get_dns {
|
Line 10060 sub get_dns {
|
| |
|
| return %iphost; |
return %iphost; |
| } |
} |
| |
|
| |
# |
| |
# Given a DNS returns the loncapa host name for that DNS |
| |
# |
| |
sub host_from_dns { |
| |
my ($dns) = @_; |
| |
my @hosts; |
| |
my $ip; |
| |
|
| |
if (exists($name_to_ip{$dns})) { |
| |
$ip = $name_to_ip{$dns}; |
| |
} |
| |
if (!$ip) { |
| |
$ip = gethostbyname($dns); # Initial translation to IP is in net order. |
| |
if (length($ip) == 4) { |
| |
$ip = &IO::Socket::inet_ntoa($ip); |
| |
} |
| |
} |
| |
if ($ip) { |
| |
@hosts = get_hosts_from_ip($ip); |
| |
return $hosts[0]; |
| |
} |
| |
return undef; |
| |
} |
| |
|
| |
sub get_internet_names { |
| |
my ($lonid) = @_; |
| |
return if ($lonid eq ''); |
| |
my ($idnref,$cached)= |
| |
&Apache::lonnet::is_cached_new('internetnames',$lonid); |
| |
if ($cached) { |
| |
return $idnref; |
| |
} |
| |
my $ip = &get_host_ip($lonid); |
| |
my @hosts = &get_hosts_from_ip($ip); |
| |
my %iphost = &get_iphost(); |
| |
my (@idns,%seen); |
| |
foreach my $id (@hosts) { |
| |
my $dom = &host_domain($id); |
| |
my $prim_id = &domain($dom,'primary'); |
| |
my $prim_ip = &get_host_ip($prim_id); |
| |
next if ($seen{$prim_ip}); |
| |
if (ref($iphost{$prim_ip}) eq 'ARRAY') { |
| |
foreach my $id (@{$iphost{$prim_ip}}) { |
| |
my $intdom = &internet_dom($id); |
| |
unless (grep(/^\Q$intdom\E$/,@idns)) { |
| |
push(@idns,$intdom); |
| |
} |
| |
} |
| |
} |
| |
$seen{$prim_ip} = 1; |
| |
} |
| |
return &Apache::lonnet::do_cache_new('internetnames',$lonid,\@idns,12*60*60); |
| |
} |
| |
|
| } |
} |
| |
|
| BEGIN { |
BEGIN { |
|
Line 8819 BEGIN {
|
Line 10192 BEGIN {
|
| close($config); |
close($config); |
| } |
} |
| |
|
| |
# ---------------------------------------------------------- Read loncaparev table |
| |
{ |
| |
if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") { |
| |
if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) { |
| |
while (my $configline=<$config>) { |
| |
chomp($configline); |
| |
my ($hostid,$loncaparev)=split(/:/,$configline); |
| |
$loncaparevs{$hostid}=$loncaparev; |
| |
} |
| |
close($config); |
| |
} |
| |
} |
| |
} |
| |
|
| |
# ---------------------------------------------------------- Read serverhostID table |
| |
{ |
| |
if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") { |
| |
if (open(my $config,"<$perlvar{'lonTabDir'}/serverhomeIDs.tab")) { |
| |
while (my $configline=<$config>) { |
| |
chomp($configline); |
| |
my ($name,$id)=split(/:/,$configline); |
| |
$serverhomeIDs{$name}=$id; |
| |
} |
| |
close($config); |
| |
} |
| |
} |
| |
} |
| |
|
| |
sub all_loncaparevs { |
| |
return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10); |
| |
} |
| |
|
| # ------------- set up temporary directory |
# ------------- set up temporary directory |
| { |
{ |
| $tmpdir = $perlvar{'lonDaemons'}.'/tmp/'; |
$tmpdir = $perlvar{'lonDaemons'}.'/tmp/'; |
|
Line 9023 in the user's environment.db and in %env
|
Line 10428 in the user's environment.db and in %env
|
| |
|
| =item * |
=item * |
| X<delenv()> |
X<delenv()> |
| B<delenv($regexp)>: removes all items from the session |
B<delenv($delthis,$regexp)>: removes all items from the session |
| environment file that matches the regular expression in $regexp. The |
environment file that begin with $delthis. If the |
| values are also delted from the current processes %env. |
optional second arg - $regexp - is true, $delthis is treated as a |
| |
regular expression, otherwise \Q$delthis\E is used. |
| |
The values are also deleted from the current processes %env. |
| |
|
| =item * get_env_multiple($name) |
=item * get_env_multiple($name) |
| |
|
|
Line 9047 authentication scheme
|
Line 10454 authentication scheme
|
| |
|
| =item * |
=item * |
| X<authenticate()> |
X<authenticate()> |
| B<authenticate($uname,$upass,$udom)>: try to |
B<authenticate($uname,$upass,$udom,$checkdefauth,$clientcancheckhost)>: try to |
| authenticate user from domain's lib servers (first use the current |
authenticate user from domain's lib servers (first use the current |
| one). C<$upass> should be the users password. |
one). C<$upass> should be the users password. |
| |
$checkdefauth is optional (value is 1 if a check should be made to |
| |
authenticate user using default authentication method, and allow |
| |
account creation if username does not have account in the domain). |
| |
$clientcancheckhost is optional (value is 1 if checking whether the |
| |
server can host will occur on the client side in lonauth.pm). |
| |
|
| =item * |
=item * |
| X<homeserver()> |
X<homeserver()> |
|
Line 9122 and course level
|
Line 10534 and course level
|
| |
|
| =item * |
=item * |
| |
|
| plaintext($short) : return value in %prp hash (rolesplain.tab); plain text |
plaintext($short,$type,$cid,$forcedefault) : return value in %prp hash |
| explanation of a user role term |
(rolesplain.tab); plain text explanation of a user role term. |
| |
$type is Course (default) or Community. |
| |
If $forcedefault evaluates to true, text returned will be default |
| |
text for $type. Otherwise, if this is a course, the text returned |
| |
will be a custom name for the role (if defined in the course's |
| |
environment). If no custom name is defined the default is returned. |
| |
|
| =item * |
=item * |
| |
|
| get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec) : |
get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec) : |
|
Line 9166 modifyuserauth($udom,$uname,$umode,$upas
|
Line 10583 modifyuserauth($udom,$uname,$umode,$upas
|
| |
|
| =item * |
=item * |
| |
|
| modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene, |
modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last, $gene, |
| $forceid,$desiredhome,$email,$inststatus) : |
$forceid,$desiredhome,$email,$inststatus,$candelete) : |
| modify user |
|
| |
will update user information (firstname,middlename,lastname,generation, |
| |
permanentemail), and if forceid is true, student/employee ID also. |
| |
A user's institutional affiliation(s) can also be updated. |
| |
User information fields will not be overwritten with empty entries |
| |
unless the field is included in the $candelete array reference. |
| |
This array is included when a single user is modified via "Manage Users", |
| |
or when Autoupdate.pl is run by cron in a domain. |
| |
|
| =item * |
=item * |
| |
|
|
Line 9329 database) for a course
|
Line 10753 database) for a course
|
| |
|
| =item * |
=item * |
| |
|
| createcourse($udom,$description,$url) : make/modify course |
createcourse($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner,$crstype,$cnum) : make course |
| |
|
| |
=item * |
| |
|
| |
generate_coursenum($udom,$crstype) : get a unique (unused) course number in domain $udom for course type $crstype (Course or Community). |
| |
|
| =back |
=back |
| |
|
|
Line 9633 dirlist($uri) : return directory list ba
|
Line 11061 dirlist($uri) : return directory list ba
|
| |
|
| spareserver() : find server with least workload from spare.tab |
spareserver() : find server with least workload from spare.tab |
| |
|
| |
|
| |
=item * |
| |
|
| |
host_from_dns($dns) : Returns the loncapa hostname corresponding to a DNS name or undef |
| |
if there is no corresponding loncapa host. |
| |
|
| =back |
=back |
| |
|
| |
|
| =head2 Apache Request |
=head2 Apache Request |
| |
|
| =over 4 |
=over 4 |
![[BACK]](/icons/back.gif){kind=icon}
Return to lonnet.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / lonnet / perl