|
version 1.833, 2007/02/18 01:51:20
|
version 1.1452, 2021/05/10 16:08:40
|
|
Line 27
|
Line 27
|
| # |
# |
| ### |
### |
| |
|
| package Apache::lonnet; |
=pod |
| |
|
| use strict; |
|
| use LWP::UserAgent(); |
|
| use HTTP::Headers; |
|
| use HTTP::Date; |
|
| # use Date::Parse; |
|
| use vars |
|
| qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom |
|
| %libserv %pr %prp $memcache %packagetab |
|
| %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount |
|
| %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf |
|
| %domaindescription %domain_auth_def %domain_auth_arg_def |
|
| %domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary |
|
| $tmpdir $_64bit %env); |
|
| |
|
| use IO::Socket; |
=head1 NAME |
| use GDBM_File; |
|
| use HTML::LCParser; |
|
| use HTML::Parser; |
|
| use Fcntl qw(:flock); |
|
| use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze); |
|
| use Time::HiRes qw( gettimeofday tv_interval ); |
|
| use Cache::Memcached; |
|
| use Digest::MD5; |
|
| use Math::Random; |
|
| use LONCAPA qw(:DEFAULT :match); |
|
| use LONCAPA::Configuration; |
|
| |
|
| my $readit; |
Apache::lonnet.pm |
| my $max_connection_retries = 10; # Or some such value. |
|
| |
|
| require Exporter; |
=head1 SYNOPSIS |
| |
|
| our @ISA = qw (Exporter); |
This file is an interface to the lonc processes of |
| our @EXPORT = qw(%env); |
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. |
| |
|
| =pod |
This is part of the LearningOnline Network with CAPA project |
| |
described at http://www.lon-capa.org. |
| |
|
| =head1 Package Variables |
=head1 Package Variables |
| |
|
|
Line 86 delayed.
|
Line 68 delayed.
|
| |
|
| =cut |
=cut |
| |
|
| |
package Apache::lonnet; |
| |
|
| |
use strict; |
| |
use HTTP::Date; |
| |
use Image::Magick; |
| |
use CGI::Cookie; |
| |
|
| |
use Encode; |
| |
|
| |
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $deftex |
| |
$_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease |
| |
%managerstab $passwdmin); |
| |
|
| |
my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash, |
| |
%userrolehash, $processmarker, $dumpcount, %coursedombuf, |
| |
%coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf, |
| |
%courseownerbuf, %coursetypebuf,$locknum); |
| |
|
| |
use IO::Socket; |
| |
use GDBM_File; |
| |
use HTML::LCParser; |
| |
use Fcntl qw(:flock); |
| |
use Storable qw(thaw nfreeze); |
| |
use Time::HiRes qw( sleep gettimeofday tv_interval ); |
| |
use Cache::Memcached; |
| |
use Digest::MD5; |
| |
use Math::Random; |
| |
use File::MMagic; |
| |
use Net::CIDR; |
| |
use LONCAPA qw(:DEFAULT :match); |
| |
use LONCAPA::Configuration; |
| |
use LONCAPA::lonmetadata; |
| |
use LONCAPA::Lond; |
| |
use LONCAPA::LWPReq; |
| |
use LONCAPA::transliterate; |
| |
|
| |
use File::Copy; |
| |
|
| |
my $readit; |
| |
my $max_connection_retries = 20; # Or some such value. |
| |
|
| |
require Exporter; |
| |
|
| |
our @ISA = qw (Exporter); |
| |
our @EXPORT = qw(%env); |
| |
|
| |
|
| # --------------------------------------------------------------------- Logging |
# ------------------------------------ Logging (parameters, docs, slots, roles) |
| { |
{ |
| my $logid; |
my $logid; |
| sub instructor_log { |
sub write_log { |
| my ($hash_name,$storehash,$delflag,$uname,$udom)=@_; |
my ($context,$hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_; |
| $logid++; |
if ($context eq 'course') { |
| my $id=time().'00000'.$$.'00000'.$logid; |
if (($cnum eq '') || ($cdom eq '')) { |
| return &Apache::lonnet::put('nohist_'.$hash_name, |
$cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; |
| { $id => { |
$cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; |
| 'exe_uname' => $env{'user.name'}, |
} |
| 'exe_udom' => $env{'user.domain'}, |
} |
| 'exe_time' => time(), |
$logid ++; |
| 'exe_ip' => $ENV{'REMOTE_ADDR'}, |
my $now = time(); |
| 'delflag' => $delflag, |
my $id=$now.'00000'.$$.'00000'.$logid; |
| 'logentry' => $storehash, |
my $ip = &get_requestor_ip(); |
| 'uname' => $uname, |
my $logentry = { |
| 'udom' => $udom, |
$id => { |
| } |
'exe_uname' => $env{'user.name'}, |
| }, |
'exe_udom' => $env{'user.domain'}, |
| $env{'course.'.$env{'request.course.id'}.'.domain'}, |
'exe_time' => $now, |
| $env{'course.'.$env{'request.course.id'}.'.num'} |
'exe_ip' => $ip, |
| ); |
'delflag' => $delflag, |
| |
'logentry' => $storehash, |
| |
'uname' => $uname, |
| |
'udom' => $udom, |
| |
} |
| |
}; |
| |
return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum); |
| } |
} |
| } |
} |
| |
|
| sub logtouch { |
sub logtouch { |
| my $execdir=$perlvar{'lonDaemons'}; |
my $execdir=$perlvar{'lonDaemons'}; |
| unless (-e "$execdir/logs/lonnet.log") { |
unless (-e "$execdir/logs/lonnet.log") { |
| open(my $fh,">>$execdir/logs/lonnet.log"); |
open(my $fh,">>","$execdir/logs/lonnet.log"); |
| close $fh; |
close $fh; |
| } |
} |
| my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3]; |
my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3]; |
|
Line 127 sub logthis {
|
Line 161 sub logthis {
|
| my $execdir=$perlvar{'lonDaemons'}; |
my $execdir=$perlvar{'lonDaemons'}; |
| 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 139 sub logperm {
|
Line 174 sub logperm {
|
| my $execdir=$perlvar{'lonDaemons'}; |
my $execdir=$perlvar{'lonDaemons'}; |
| my $now=time; |
my $now=time; |
| my $local=localtime($now); |
my $local=localtime($now); |
| if (open(my $fh,">>$execdir/logs/lonnet.perm.log")) { |
if (open(my $fh,">>","$execdir/logs/lonnet.perm.log")) { |
| print $fh "$now:$message:$local\n"; |
print $fh "$now:$message:$local\n"; |
| close($fh); |
close($fh); |
| } |
} |
| return 1; |
return 1; |
| } |
} |
| |
|
| |
sub create_connection { |
| |
my ($hostname,$lonid) = @_; |
| |
my $client=IO::Socket::UNIX->new(Peer => $perlvar{'lonSockCreate'}, |
| |
Type => SOCK_STREAM, |
| |
Timeout => 10); |
| |
return 0 if (!$client); |
| |
print $client (join(':',$hostname,$lonid,&machine_ids($hostname),$loncaparevs{$lonid})."\n"); |
| |
my $result = <$client>; |
| |
chomp($result); |
| |
return 1 if ($result eq 'done'); |
| |
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_distarch { |
| |
my ($lonhost,$ignore_cache) = @_; |
| |
if (defined($lonhost)) { |
| |
if (!defined(&hostname($lonhost))) { |
| |
return; |
| |
} |
| |
my $cachetime = 12*3600; |
| |
if (!$ignore_cache) { |
| |
my ($distarch,$cached)=&is_cached_new('serverdistarch',$lonhost); |
| |
if (defined($cached)) { |
| |
return $distarch; |
| |
} |
| |
} |
| |
my $rep = &reply('serverdistarch',$lonhost); |
| |
unless ($rep eq 'unknown_command' || $rep eq 'no_such_host' || |
| |
$rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' || |
| |
$rep eq '') { |
| |
return &do_cache_new('serverdistarch',$lonhost,$rep,$cachetime); |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| |
sub get_servercerts_info { |
| |
my ($lonhost,$hostname,$context) = @_; |
| |
return if ($lonhost eq ''); |
| |
if ($hostname eq '') { |
| |
$hostname = &hostname($lonhost); |
| |
} |
| |
return if ($hostname eq ''); |
| |
my ($rep,$uselocal); |
| |
if ($context eq 'install') { |
| |
$uselocal = 1; |
| |
} elsif (grep { $_ eq $lonhost } ¤t_machine_ids()) { |
| |
$uselocal = 1; |
| |
} |
| |
if (($context ne 'cgi') && ($context ne 'install') && ($uselocal)) { |
| |
my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0]; |
| |
if ($distro eq '') { |
| |
$uselocal = 0; |
| |
} elsif ($distro =~ /^(?:centos|redhat|scientific)(\d+)$/) { |
| |
if ($1 < 6) { |
| |
$uselocal = 0; |
| |
} |
| |
} elsif ($distro =~ /^(?:sles)(\d+)$/) { |
| |
if ($1 < 12) { |
| |
$uselocal = 0; |
| |
} |
| |
} |
| |
} |
| |
if ($uselocal) { |
| |
$rep = LONCAPA::Lond::server_certs(\%perlvar,$lonhost,$hostname); |
| |
} else { |
| |
$rep=&reply('servercerts',$lonhost); |
| |
} |
| |
my ($result,%returnhash); |
| |
if (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') || |
| |
($rep eq 'unknown_cmd')) { |
| |
$result = $rep; |
| |
} else { |
| |
$result = 'ok'; |
| |
my @pairs=split(/\&/,$rep); |
| |
foreach my $item (@pairs) { |
| |
my ($key,$value)=split(/=/,$item,2); |
| |
my $what = &unescape($key); |
| |
$returnhash{$what}=&thaw_unescape($value); |
| |
} |
| |
} |
| |
return ($result,\%returnhash); |
| |
} |
| |
|
| |
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 =~ /^[\'\"]?([\w.\-]+)[\'\"]?$/) { |
| |
$loncaparev = $1; |
| |
} |
| |
} else { |
| |
$answer = &reply('serverloncaparev',$lonhost); |
| |
if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) { |
| |
if ($caller eq 'loncron') { |
| |
my $hostname = &hostname($lonhost); |
| |
my $protocol = $protocol{$lonhost}; |
| |
$protocol = 'http' if ($protocol ne 'https'); |
| |
my $url = $protocol.'://'.$hostname.'/adm/about.html'; |
| |
my $request=new HTTP::Request('GET',$url); |
| |
my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,4,1); |
| |
unless ($response->is_error()) { |
| |
my $content = $response->content; |
| |
if ($content =~ /<p>VERSION\:\s*([\w.\-]+)<\/p>/) { |
| |
$loncaparev = $1; |
| |
} |
| |
} |
| |
} else { |
| |
$loncaparev = $loncaparevs{$lonhost}; |
| |
} |
| |
} elsif ($answer =~ /^[\'\"]?([\w.\-]+)[\'\"]?$/) { |
| |
$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); |
| |
} |
| |
|
| |
sub get_remote_globals { |
| |
my ($lonhost,$whathash,$ignore_cache) = @_; |
| |
my ($result,%returnhash,%whatneeded); |
| |
if (ref($whathash) eq 'HASH') { |
| |
foreach my $what (sort(keys(%{$whathash}))) { |
| |
my $hashid = $lonhost.'-'.$what; |
| |
my ($response,$cached); |
| |
unless ($ignore_cache) { |
| |
($response,$cached)=&is_cached_new('lonnetglobal',$hashid); |
| |
} |
| |
if (defined($cached)) { |
| |
$returnhash{$what} = $response; |
| |
} else { |
| |
$whatneeded{$what} = 1; |
| |
} |
| |
} |
| |
if (keys(%whatneeded) == 0) { |
| |
$result = 'ok'; |
| |
} else { |
| |
my $requested = &freeze_escape(\%whatneeded); |
| |
my $rep=&reply('readlonnetglobal:'.$requested,$lonhost); |
| |
if (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') || |
| |
($rep eq 'unknown_cmd')) { |
| |
$result = $rep; |
| |
} else { |
| |
$result = 'ok'; |
| |
my @pairs=split(/\&/,$rep); |
| |
foreach my $item (@pairs) { |
| |
my ($key,$value)=split(/=/,$item,2); |
| |
my $what = &unescape($key); |
| |
my $hashid = $lonhost.'-'.$what; |
| |
$returnhash{$what}=&thaw_unescape($value); |
| |
&do_cache_new('lonnetglobal',$hashid,$returnhash{$what},600); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return ($result,\%returnhash); |
| |
} |
| |
|
| |
sub remote_devalidate_cache { |
| |
my ($lonhost,$cachekeys) = @_; |
| |
my $items; |
| |
return unless (ref($cachekeys) eq 'ARRAY'); |
| |
my $cachestr = join('&',@{$cachekeys}); |
| |
my $response = &reply('devalidatecache:'.&escape($cachestr),$lonhost); |
| |
return $response; |
| |
} |
| |
|
| # -------------------------------------------------- Non-critical communication |
# -------------------------------------------------- Non-critical communication |
| sub subreply { |
sub subreply { |
| my ($cmd,$server)=@_; |
my ($cmd,$server)=@_; |
| my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server}; |
my $peerfile="$perlvar{'lonSockDir'}/".&hostname($server); |
| # |
# |
| # With loncnew process trimming, there's a timing hole between lonc server |
# With loncnew process trimming, there's a timing hole between lonc server |
| # process exit and the master server picking up the listen on the AF_UNIX |
# process exit and the master server picking up the listen on the AF_UNIX |
|
Line 157 sub subreply {
|
Line 425 sub subreply {
|
| |
|
| my $lockfile=$peerfile.".lock"; |
my $lockfile=$peerfile.".lock"; |
| while (-e $lockfile) { # Need to wait for the lockfile to disappear. |
while (-e $lockfile) { # Need to wait for the lockfile to disappear. |
| sleep(1); |
sleep(0.1); |
| } |
} |
| # At this point, either a loncnew parent is listening or an old lonc |
# At this point, either a loncnew parent is listening or an old lonc |
| # or loncnew child is listening so we can connect or everything's dead. |
# or loncnew child is listening so we can connect or everything's dead. |
|
Line 170 sub subreply {
|
Line 438 sub subreply {
|
| $client=IO::Socket::UNIX->new(Peer =>"$peerfile", |
$client=IO::Socket::UNIX->new(Peer =>"$peerfile", |
| Type => SOCK_STREAM, |
Type => SOCK_STREAM, |
| Timeout => 10); |
Timeout => 10); |
| if($client) { |
if ($client) { |
| last; # Connected! |
last; # Connected! |
| |
} else { |
| |
&create_connection(&hostname($server),$server); |
| } |
} |
| sleep(1); # Try again later if failed connection. |
sleep(0.1); # Try again later if failed connection. |
| } |
} |
| my $answer; |
my $answer; |
| if ($client) { |
if ($client) { |
|
Line 189 sub subreply {
|
Line 459 sub subreply {
|
| |
|
| sub reply { |
sub reply { |
| my ($cmd,$server)=@_; |
my ($cmd,$server)=@_; |
| unless (defined($hostname{$server})) { return 'no_such_host'; } |
unless (defined(&hostname($server))) { return 'no_such_host'; } |
| my $answer=subreply($cmd,$server); |
my $answer=subreply($cmd,$server); |
| if (($answer=~/^refused/) || ($answer=~/^rejected/)) { |
if (($answer=~/^refused/) || ($answer=~/^rejected/)) { |
| &logthis("<font color=\"blue\">WARNING:". |
my $logged = $cmd; |
| " $cmd to $server returned $answer</font>"); |
if ($cmd =~ /^encrypt:([^:]+):/) { |
| |
my $subcmd = $1; |
| |
if (($subcmd eq 'auth') || ($subcmd eq 'passwd') || |
| |
($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') || |
| |
($subcmd eq 'putdom') || ($subcmd eq 'autoexportgrades')) { |
| |
(undef,undef,my @rest) = split(/:/,$cmd); |
| |
if (($subcmd eq 'auth') || ($subcmd eq 'putdom')) { |
| |
splice(@rest,2,1,'Hidden'); |
| |
} elsif ($subcmd eq 'passwd') { |
| |
splice(@rest,2,2,('Hidden','Hidden')); |
| |
} elsif (($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') || |
| |
($subcmd eq 'autoexportgrades')) { |
| |
splice(@rest,3,1,'Hidden'); |
| |
} |
| |
$logged = join(':',('encrypt:'.$subcmd,@rest)); |
| |
} |
| |
} |
| |
&logthis("<font color=\"blue\">WARNING:". |
| |
" $logged to $server returned $answer</font>"); |
| } |
} |
| return $answer; |
return $answer; |
| } |
} |
|
Line 201 sub reply {
|
Line 489 sub reply {
|
| # ----------------------------------------------------------- Send USR1 to lonc |
# ----------------------------------------------------------- Send USR1 to lonc |
| |
|
| sub reconlonc { |
sub reconlonc { |
| my $peerfile=shift; |
my ($lonid) = @_; |
| &logthis("Trying to reconnect for $peerfile"); |
if ($lonid) { |
| |
my $hostname = &hostname($lonid); |
| |
my $peerfile="$perlvar{'lonSockDir'}/$hostname"; |
| |
if ($hostname && -e $peerfile) { |
| |
&logthis("Trying to reconnect lonc for $lonid ($hostname)"); |
| |
my $client=IO::Socket::UNIX->new(Peer => $peerfile, |
| |
Type => SOCK_STREAM, |
| |
Timeout => 10); |
| |
if ($client) { |
| |
print $client ("reset_retries\n"); |
| |
my $answer=<$client>; |
| |
#reset just this one. |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| |
&logthis("Trying to reconnect lonc"); |
| my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; |
my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; |
| if (open(my $fh,"<$loncfile")) { |
if (open(my $fh,"<",$loncfile)) { |
| my $loncpid=<$fh>; |
my $loncpid=<$fh>; |
| chomp($loncpid); |
chomp($loncpid); |
| if (kill 0 => $loncpid) { |
if (kill 0 => $loncpid) { |
| &logthis("lonc at pid $loncpid responding, sending USR1"); |
&logthis("lonc at pid $loncpid responding, sending USR1"); |
| kill USR1 => $loncpid; |
kill USR1 => $loncpid; |
| sleep 1; |
sleep 1; |
| if (-e "$peerfile") { return; } |
|
| &logthis("$peerfile still not there, give it another try"); |
|
| sleep 5; |
|
| if (-e "$peerfile") { return; } |
|
| &logthis( |
|
| "<font color=\"blue\">WARNING: $peerfile still not there, giving up</font>"); |
|
| } else { |
} else { |
| &logthis( |
&logthis( |
| "<font color=\"blue\">WARNING:". |
"<font color=\"blue\">WARNING:". |
| " lonc at pid $loncpid not responding, giving up</font>"); |
" lonc at pid $loncpid not responding, giving up</font>"); |
| } |
} |
| } else { |
} else { |
| &logthis('<font color="blue">WARNING: lonc not running, giving up</font>'); |
&logthis('<font color="blue">WARNING: lonc not running, giving up</font>'); |
| } |
} |
| } |
} |
| |
|
|
Line 231 sub reconlonc {
|
Line 530 sub reconlonc {
|
| |
|
| sub critical { |
sub critical { |
| my ($cmd,$server)=@_; |
my ($cmd,$server)=@_; |
| unless ($hostname{$server}) { |
unless (&hostname($server)) { |
| &logthis("<font color=\"blue\">WARNING:". |
&logthis("<font color=\"blue\">WARNING:". |
| " Critical message to unknown server ($server)</font>"); |
" Critical message to unknown server ($server)</font>"); |
| return 'no_such_host'; |
return 'no_such_host'; |
| } |
} |
| my $answer=reply($cmd,$server); |
my $answer=reply($cmd,$server); |
| if ($answer eq 'con_lost') { |
if ($answer eq 'con_lost') { |
| &reconlonc("$perlvar{'lonSockDir'}/$server"); |
&reconlonc($server); |
| my $answer=reply($cmd,$server); |
my $answer=reply($cmd,$server); |
| if ($answer eq 'con_lost') { |
if ($answer eq 'con_lost') { |
| my $now=time; |
my $now=time; |
|
Line 250 sub critical {
|
Line 549 sub critical {
|
| $dumpcount++; |
$dumpcount++; |
| { |
{ |
| my $dfh; |
my $dfh; |
| if (open($dfh,">$dfilename")) { |
if (open($dfh,">",$dfilename)) { |
| print $dfh "$cmd\n"; |
print $dfh "$cmd\n"; |
| close($dfh); |
close($dfh); |
| } |
} |
| } |
} |
| sleep 2; |
sleep 1; |
| my $wcmd=''; |
my $wcmd=''; |
| { |
{ |
| my $dfh; |
my $dfh; |
| if (open($dfh,"<$dfilename")) { |
if (open($dfh,"<",$dfilename)) { |
| $wcmd=<$dfh>; |
$wcmd=<$dfh>; |
| close($dfh); |
close($dfh); |
| } |
} |
|
Line 296 sub convert_and_load_session_env {
|
Line 595 sub convert_and_load_session_env {
|
| my ($lonidsdir,$handle)=@_; |
my ($lonidsdir,$handle)=@_; |
| my @profile; |
my @profile; |
| { |
{ |
| open(my $idf,"$lonidsdir/$handle.id"); |
my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id"); |
| |
if (!$opened) { |
| |
return 0; |
| |
} |
| flock($idf,LOCK_SH); |
flock($idf,LOCK_SH); |
| @profile=<$idf>; |
@profile=<$idf>; |
| close($idf); |
close($idf); |
|
Line 335 sub transfer_profile_to_env {
|
Line 637 sub transfer_profile_to_env {
|
| |
|
| my $convert; |
my $convert; |
| { |
{ |
| open(my $idf,"$lonidsdir/$handle.id"); |
my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id"); |
| |
if (!$opened) { |
| |
return; |
| |
} |
| flock($idf,LOCK_SH); |
flock($idf,LOCK_SH); |
| if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id", |
if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id", |
| &GDBM_READER(),0640)) { |
&GDBM_READER(),0640)) { |
|
Line 367 sub transfer_profile_to_env {
|
Line 672 sub transfer_profile_to_env {
|
| } |
} |
| } |
} |
| |
|
| |
# ---------------------------------------------------- Check for valid session |
| |
sub check_for_valid_session { |
| |
my ($r,$name,$userhashref,$domref) = @_; |
| |
my %cookies=CGI::Cookie->parse($r->header_in('Cookie')); |
| |
my ($lonidsdir,$linkname,$pubname,$secure,$lonid); |
| |
if ($name eq 'lonDAV') { |
| |
$lonidsdir=$r->dir_config('lonDAVsessDir'); |
| |
} else { |
| |
$lonidsdir=$r->dir_config('lonIDsDir'); |
| |
if ($name eq '') { |
| |
$name = 'lonID'; |
| |
} |
| |
} |
| |
if ($name eq 'lonID') { |
| |
$secure = 'lonSID'; |
| |
$linkname = 'lonLinkID'; |
| |
$pubname = 'lonPubID'; |
| |
if (exists($cookies{$secure})) { |
| |
$lonid=$cookies{$secure}; |
| |
} elsif (exists($cookies{$name})) { |
| |
$lonid=$cookies{$name}; |
| |
} elsif ((exists($cookies{$linkname})) && ($ENV{'SERVER_PORT'} != 443)) { |
| |
$lonid=$cookies{$linkname}; |
| |
} elsif (exists($cookies{$pubname})) { |
| |
$lonid=$cookies{$pubname}; |
| |
} |
| |
} else { |
| |
$lonid=$cookies{$name}; |
| |
} |
| |
return undef if (!$lonid); |
| |
|
| |
my $handle=&LONCAPA::clean_handle($lonid->value); |
| |
if (-l "$lonidsdir/$handle.id") { |
| |
my $link = readlink("$lonidsdir/$handle.id"); |
| |
if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) { |
| |
$handle = $1; |
| |
} |
| |
} |
| |
if (!-e "$lonidsdir/$handle.id") { |
| |
if ((ref($domref)) && ($name eq 'lonID') && |
| |
($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) { |
| |
my ($possuname,$possudom,$possuhome) = ($1,$2,$3); |
| |
if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) { |
| |
$$domref = $possudom; |
| |
} |
| |
} |
| |
return undef; |
| |
} |
| |
|
| |
my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id"); |
| |
return undef if (!$opened); |
| |
|
| |
flock($idf,LOCK_SH); |
| |
my %disk_env; |
| |
if (!tie(%disk_env,'GDBM_File',"$lonidsdir/$handle.id", |
| |
&GDBM_READER(),0640)) { |
| |
return undef; |
| |
} |
| |
|
| |
if (!defined($disk_env{'user.name'}) |
| |
|| !defined($disk_env{'user.domain'})) { |
| |
untie(%disk_env); |
| |
return undef; |
| |
} |
| |
|
| |
if (ref($userhashref) eq 'HASH') { |
| |
$userhashref->{'name'} = $disk_env{'user.name'}; |
| |
$userhashref->{'domain'} = $disk_env{'user.domain'}; |
| |
if ($disk_env{'request.role'}) { |
| |
$userhashref->{'role'} = $disk_env{'request.role'}; |
| |
} |
| |
$userhashref->{'lti'} = $disk_env{'request.lti.login'}; |
| |
if ($userhashref->{'lti'}) { |
| |
$userhashref->{'ltitarget'} = $disk_env{'request.lti.target'}; |
| |
$userhashref->{'ltiuri'} = $disk_env{'request.lti.uri'}; |
| |
} |
| |
} |
| |
untie(%disk_env); |
| |
|
| |
return $handle; |
| |
} |
| |
|
| sub timed_flock { |
sub timed_flock { |
| my ($file,$lock_type) = @_; |
my ($file,$lock_type) = @_; |
| my $failed=0; |
my $failed=0; |
|
Line 387 sub timed_flock {
|
Line 774 sub timed_flock {
|
| } |
} |
| } |
} |
| |
|
| |
sub get_sessionfile_vars { |
| |
my ($handle,$lonidsdir,$storearr) = @_; |
| |
my %returnhash; |
| |
unless (ref($storearr) eq 'ARRAY') { |
| |
return %returnhash; |
| |
} |
| |
if (-l "$lonidsdir/$handle.id") { |
| |
my $link = readlink("$lonidsdir/$handle.id"); |
| |
if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) { |
| |
$handle = $1; |
| |
} |
| |
} |
| |
if ((-e "$lonidsdir/$handle.id") && |
| |
($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) { |
| |
my ($possuname,$possudom,$possuhome) = ($1,$2,$3); |
| |
if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) { |
| |
if (open(my $idf,'+<',"$lonidsdir/$handle.id")) { |
| |
flock($idf,LOCK_SH); |
| |
if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id", |
| |
&GDBM_READER(),0640)) { |
| |
foreach my $item (@{$storearr}) { |
| |
$returnhash{$item} = $disk_env{$item}; |
| |
} |
| |
untie(%disk_env); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return %returnhash; |
| |
} |
| |
|
| # ---------------------------------------------------------- Append Environment |
# ---------------------------------------------------------- Append Environment |
| |
|
| sub appenv { |
sub appenv { |
| my %newenv=@_; |
my ($newenv,$roles) = @_; |
| foreach my $key (keys(%newenv)) { |
if (ref($newenv) eq 'HASH') { |
| if (($newenv{$key}=~/^user\.role/) || ($newenv{$key}=~/^user\.priv/)) { |
foreach my $key (keys(%{$newenv})) { |
| &logthis("<font color=\"blue\">WARNING: ". |
my $refused = 0; |
| "Attempt to modify environment ".$key." to ".$newenv{$key} |
if (($key =~ /^user\.role/) || ($key =~ /^user\.priv/)) { |
| .'</font>'); |
$refused = 1; |
| delete($newenv{$key}); |
if (ref($roles) eq 'ARRAY') { |
| } else { |
my ($type,$role) = ($key =~ m{^user\.(role|priv)\.(.+?)\./}); |
| $env{$key}=$newenv{$key}; |
if (grep(/^\Q$role\E$/,@{$roles})) { |
| |
$refused = 0; |
| |
} |
| |
} |
| |
} |
| |
if ($refused) { |
| |
&logthis("<font color=\"blue\">WARNING: ". |
| |
"Attempt to modify environment ".$key." to ".$newenv->{$key} |
| |
.'</font>'); |
| |
delete($newenv->{$key}); |
| |
} else { |
| |
$env{$key}=$newenv->{$key}; |
| |
} |
| |
} |
| |
my $lonids = $perlvar{'lonIDsDir'}; |
| |
if ($env{'user.environment'} =~ m{^\Q$lonids/\E$match_username\_\d+\_$match_domain\_[\w\-.]+\.id$}) { |
| |
my $opened = open(my $env_file,'+<',$env{'user.environment'}); |
| |
if ($opened |
| |
&& &timed_flock($env_file,LOCK_EX) |
| |
&& |
| |
tie(my %disk_env,'GDBM_File',$env{'user.environment'}, |
| |
(&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { |
| |
while (my ($key,$value) = each(%{$newenv})) { |
| |
$disk_env{$key} = $value; |
| |
} |
| |
untie(%disk_env); |
| |
} |
| } |
} |
| } |
|
| open(my $env_file,$env{'user.environment'}); |
|
| if (&timed_flock($env_file,LOCK_EX) |
|
| && |
|
| tie(my %disk_env,'GDBM_File',$env{'user.environment'}, |
|
| (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { |
|
| while (my ($key,$value) = each(%newenv)) { |
|
| $disk_env{$key} = $value; |
|
| } |
|
| untie(%disk_env); |
|
| } |
} |
| return 'ok'; |
return 'ok'; |
| } |
} |
| # ----------------------------------------------------- Delete from Environment |
# ----------------------------------------------------- Delete from Environment |
| |
|
| sub delenv { |
sub delenv { |
| my $delthis=shift; |
my ($delthis,$regexp,$roles) = @_; |
| if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { |
if (($delthis=~/^user\.role/) || ($delthis=~/^user\.priv/)) { |
| &logthis("<font color=\"blue\">WARNING: ". |
my $refused = 1; |
| "Attempt to delete from environment ".$delthis); |
if (ref($roles) eq 'ARRAY') { |
| return 'error'; |
my ($type,$role) = ($delthis =~ /^user\.(role|priv)\.([^.]+)\./); |
| |
if (grep(/^\Q$role\E$/,@{$roles})) { |
| |
$refused = 0; |
| |
} |
| |
} |
| |
if ($refused) { |
| |
&logthis("<font color=\"blue\">WARNING: ". |
| |
"Attempt to delete from environment ".$delthis); |
| |
return 'error'; |
| |
} |
| } |
} |
| open(my $env_file,$env{'user.environment'}); |
my $opened = open(my $env_file,'+<',$env{'user.environment'}); |
| if (&timed_flock($env_file,LOCK_EX) |
if ($opened |
| |
&& &timed_flock($env_file,LOCK_EX) |
| && |
&& |
| 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 452 sub get_env_multiple {
|
Line 903 sub get_env_multiple {
|
| return(@values); |
return(@values); |
| } |
} |
| |
|
| |
# ------------------------------------------------------------------- Locking |
| |
|
| |
sub set_lock { |
| |
my ($text)=@_; |
| |
$locknum++; |
| |
my $id=$$.'-'.$locknum; |
| |
&appenv({'session.locks' => $env{'session.locks'}.','.$id, |
| |
'session.lock.'.$id => $text}); |
| |
return $id; |
| |
} |
| |
|
| |
sub get_locks { |
| |
my $num=0; |
| |
my %texts=(); |
| |
foreach my $lock (split(/\,/,$env{'session.locks'})) { |
| |
if ($lock=~/\w/) { |
| |
$num++; |
| |
$texts{$lock}=$env{'session.lock.'.$lock}; |
| |
} |
| |
} |
| |
return ($num,%texts); |
| |
} |
| |
|
| |
sub remove_lock { |
| |
my ($id)=@_; |
| |
my $newlocks=''; |
| |
foreach my $lock (split(/\,/,$env{'session.locks'})) { |
| |
if (($lock=~/\w/) && ($lock ne $id)) { |
| |
$newlocks.=','.$lock; |
| |
} |
| |
} |
| |
&appenv({'session.locks' => $newlocks}); |
| |
&delenv('session.lock.'.$id); |
| |
} |
| |
|
| |
sub remove_all_locks { |
| |
my $activelocks=$env{'session.locks'}; |
| |
foreach my $lock (split(/\,/,$env{'session.locks'})) { |
| |
if ($lock=~/\w/) { |
| |
&remove_lock($lock); |
| |
} |
| |
} |
| |
} |
| |
|
| |
|
| # ------------------------------------------ Find out current server userload |
# ------------------------------------------ Find out current server userload |
| # there is a copy in lond |
|
| sub userload { |
sub userload { |
| my $numusers=0; |
my $numusers=0; |
| { |
{ |
|
Line 461 sub userload {
|
Line 956 sub userload {
|
| my $filename; |
my $filename; |
| my $curtime=time; |
my $curtime=time; |
| while ($filename=readdir(LONIDS)) { |
while ($filename=readdir(LONIDS)) { |
| if ($filename eq '.' || $filename eq '..') {next;} |
next if ($filename eq '.' || $filename eq '..'); |
| |
next if ($filename =~ /publicuser_\d+\.id/); |
| |
next if ($filename =~ /^[a-f0-9]+_linked\.id$/); |
| my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9]; |
my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9]; |
| if ($curtime-$mtime < 1800) { $numusers++; } |
if ($curtime-$mtime < 1800) { $numusers++; } |
| } |
} |
|
Line 476 sub userload {
|
Line 973 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 { |
| my ($loadpercent,$userloadpercent,$want_server_name) = @_; |
my ($r,$loadpercent,$userloadpercent,$want_server_name,$udom) = @_; |
| my $spare_server; |
my $spare_server; |
| if ($userloadpercent !~ /\d/) { $userloadpercent=0; } |
if ($userloadpercent !~ /\d/) { $userloadpercent=0; } |
| my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent |
my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent |
| : $userloadpercent; |
: $userloadpercent; |
| |
my ($uint_dom,$remotesessions); |
| foreach my $try_server (@{ $spareid{'primary'} }) { |
if (($udom ne '') && (&domain($udom) ne '')) { |
| ($spare_server, $lowest_load) = |
my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); |
| &compare_server_load($try_server, $spare_server, $lowest_load); |
$uint_dom = &Apache::lonnet::internet_dom($uprimary_id); |
| } |
my %udomdefaults = &Apache::lonnet::get_domain_defaults($udom); |
| |
$remotesessions = $udomdefaults{'remotesessions'}; |
| my $found_server = ($spare_server ne '' && $lowest_load < 100); |
} |
| |
my $spareshash = &this_host_spares($udom); |
| |
if (ref($spareshash) eq 'HASH') { |
| |
if (ref($spareshash->{'primary'}) eq 'ARRAY') { |
| |
foreach my $try_server (@{ $spareshash->{'primary'} }) { |
| |
next unless (&spare_can_host($udom,$uint_dom,$remotesessions, |
| |
$try_server)); |
| |
($spare_server, $lowest_load) = |
| |
&compare_server_load($try_server, $spare_server, $lowest_load); |
| |
} |
| |
} |
| |
|
| if (!$found_server) { |
my $found_server = ($spare_server ne '' && $lowest_load < 100); |
| foreach my $try_server (@{ $spareid{'default'} }) { |
|
| ($spare_server, $lowest_load) = |
if (!$found_server) { |
| &compare_server_load($try_server, $spare_server, $lowest_load); |
if (ref($spareshash->{'default'}) eq 'ARRAY') { |
| } |
foreach my $try_server (@{ $spareshash->{'default'} }) { |
| |
next unless (&spare_can_host($udom,$uint_dom, |
| |
$remotesessions,$try_server)); |
| |
($spare_server, $lowest_load) = |
| |
&compare_server_load($try_server, $spare_server, $lowest_load); |
| |
} |
| |
} |
| |
} |
| } |
} |
| |
|
| if (!$want_server_name) { |
if (!$want_server_name) { |
| $spare_server="http://$hostname{$spare_server}"; |
if (defined($spare_server)) { |
| |
my $hostname = &hostname($spare_server); |
| |
if (defined($hostname)) { |
| |
my $protocol = 'http'; |
| |
if ($protocol{$spare_server} eq 'https') { |
| |
$protocol = $protocol{$spare_server}; |
| |
} |
| |
my $alias = &Apache::lonnet::use_proxy_alias($r,$spare_server); |
| |
$hostname = $alias if ($alias ne ''); |
| |
$spare_server = $protocol.'://'.$hostname; |
| |
} |
| |
} |
| } |
} |
| return $spare_server; |
return $spare_server; |
| } |
} |
| |
|
| sub compare_server_load { |
sub compare_server_load { |
| my ($try_server, $spare_server, $lowest_load) = @_; |
my ($try_server, $spare_server, $lowest_load, $required) = @_; |
| |
|
| |
if ($required) { |
| |
my ($reqdmajor,$reqdminor) = ($required =~ /^(\d+)\.(\d+)$/); |
| |
my $remoterev = &get_server_loncaparev(undef,$try_server); |
| |
my ($major,$minor) = ($remoterev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/); |
| |
if (($major eq '' && $minor eq '') || |
| |
(($reqdmajor > $major) || (($reqdmajor == $major) && ($reqdminor > $minor)))) { |
| |
return ($spare_server,$lowest_load); |
| |
} |
| |
} |
| |
|
| my $loadans = &reply('load', $try_server); |
my $loadans = &reply('load', $try_server); |
| 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 ($spare_server, $lowest_load); #didn't get a number from the server |
| } |
} |
| |
|
| my $load; |
my $load; |
|
Line 558 sub compare_server_load {
|
Line 1069 sub compare_server_load {
|
| } |
} |
| return ($spare_server,$lowest_load); |
return ($spare_server,$lowest_load); |
| } |
} |
| |
|
| |
# --------------------------- ask offload servers if user already has a session |
| |
sub find_existing_session { |
| |
my ($udom,$uname) = @_; |
| |
my $spareshash = &this_host_spares($udom); |
| |
if (ref($spareshash) eq 'HASH') { |
| |
if (ref($spareshash->{'primary'}) eq 'ARRAY') { |
| |
foreach my $try_server (@{ $spareshash->{'primary'} }) { |
| |
return $try_server if (&has_user_session($try_server, $udom, $uname)); |
| |
} |
| |
} |
| |
if (ref($spareshash->{'default'}) eq 'ARRAY') { |
| |
foreach my $try_server (@{ $spareshash->{'default'} }) { |
| |
return $try_server if (&has_user_session($try_server, $udom, $uname)); |
| |
} |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| |
sub delusersession { |
| |
my ($lonid,$udom,$uname) = @_; |
| |
my $uprimary_id = &domain($udom,'primary'); |
| |
my $uintdom = &internet_dom($uprimary_id); |
| |
my $intdom = &internet_dom($lonid); |
| |
my $serverhomedom = &host_domain($lonid); |
| |
if (($uintdom ne '') && ($uintdom eq $intdom)) { |
| |
return &reply(join(':','delusersession', |
| |
map {&escape($_)} ($udom,$uname)),$lonid); |
| |
} |
| |
return; |
| |
} |
| |
|
| |
# check if user's browser sent load balancer cookie and server still has session |
| |
# and is not overloaded. |
| |
sub check_for_balancer_cookie { |
| |
my ($r,$update_mtime) = @_; |
| |
my ($otherserver,$cookie); |
| |
my %cookies=CGI::Cookie->parse($r->header_in('Cookie')); |
| |
if (exists($cookies{'balanceID'})) { |
| |
my $balid = $cookies{'balanceID'}; |
| |
$cookie=&LONCAPA::clean_handle($balid->value); |
| |
my $balancedir=$r->dir_config('lonBalanceDir'); |
| |
if ((-d $balancedir) && (-e "$balancedir/$cookie.id")) { |
| |
if ($cookie =~ /^($match_domain)_($match_username)_[a-f0-9]+$/) { |
| |
my ($possudom,$possuname) = ($1,$2); |
| |
my $has_session = 0; |
| |
if ((&domain($possudom) ne '') && |
| |
(&homeserver($possuname,$possudom) ne 'no_host')) { |
| |
my $try_server; |
| |
my $opened = open(my $idf,'+<',"$balancedir/$cookie.id"); |
| |
if ($opened) { |
| |
flock($idf,LOCK_SH); |
| |
while (my $line = <$idf>) { |
| |
chomp($line); |
| |
if (&hostname($line) ne '') { |
| |
$try_server = $line; |
| |
last; |
| |
} |
| |
} |
| |
close($idf); |
| |
if (($try_server) && |
| |
(&has_user_session($try_server,$possudom,$possuname))) { |
| |
my $lowest_load = 30000; |
| |
($otherserver,$lowest_load) = |
| |
&compare_server_load($try_server,undef,$lowest_load); |
| |
if ($otherserver ne '' && $lowest_load < 100) { |
| |
$has_session = 1; |
| |
} else { |
| |
undef($otherserver); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if ($has_session) { |
| |
if ($update_mtime) { |
| |
my $atime = my $mtime = time; |
| |
utime($atime,$mtime,"$balancedir/$cookie.id"); |
| |
} |
| |
} else { |
| |
unlink("$balancedir/$cookie.id"); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return ($otherserver,$cookie); |
| |
} |
| |
|
| |
sub updatebalcookie { |
| |
my ($cookie,$balancer,$lastentry)=@_; |
| |
if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) { |
| |
my ($udom,$uname) = ($1,$2); |
| |
my $uprimary_id = &domain($udom,'primary'); |
| |
my $uintdom = &internet_dom($uprimary_id); |
| |
my $intdom = &internet_dom($balancer); |
| |
my $serverhomedom = &host_domain($balancer); |
| |
if (($uintdom ne '') && ($uintdom eq $intdom)) { |
| |
return &reply('updatebalcookie:'.&escape($cookie).':'.&escape($lastentry),$balancer); |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| |
sub delbalcookie { |
| |
my ($cookie,$balancer) =@_; |
| |
if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) { |
| |
my ($udom,$uname) = ($1,$2); |
| |
my $uprimary_id = &domain($udom,'primary'); |
| |
my $uintdom = &internet_dom($uprimary_id); |
| |
my $intdom = &internet_dom($balancer); |
| |
my $serverhomedom = &host_domain($balancer); |
| |
if (($uintdom ne '') && ($uintdom eq $intdom)) { |
| |
return &reply('delbalcookie:'.&escape($cookie),$balancer); |
| |
} |
| |
} |
| |
} |
| |
|
| |
# -------------------------------- ask if server already has a session for user |
| |
sub has_user_session { |
| |
my ($lonid,$udom,$uname) = @_; |
| |
my $result = &reply(join(':','userhassession', |
| |
map {&escape($_)} ($udom,$uname)),$lonid); |
| |
return 1 if ($result eq 'ok'); |
| |
|
| |
return 0; |
| |
} |
| |
|
| |
# --------- determine least loaded server in a user's domain which allows login |
| |
|
| |
sub choose_server { |
| |
my ($udom,$checkloginvia,$required,$skiploadbal) = @_; |
| |
my %domconfhash = &Apache::loncommon::get_domainconf($udom); |
| |
my %servers = &get_servers($udom); |
| |
my $lowest_load = 30000; |
| |
my ($login_host,$hostname,$portal_path,$isredirect,$balancers); |
| |
if ($skiploadbal) { |
| |
($balancers,my $cached)=&is_cached_new('loadbalancing',$udom); |
| |
unless (defined($cached)) { |
| |
my $cachetime = 60*60*24; |
| |
my %domconfig = |
| |
&Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom); |
| |
if (ref($domconfig{'loadbalancing'}) eq 'HASH') { |
| |
$balancers = &do_cache_new('loadbalancing',$udom,$domconfig{'loadbalancing'}, |
| |
$cachetime); |
| |
} |
| |
} |
| |
} |
| |
foreach my $lonhost (keys(%servers)) { |
| |
if ($skiploadbal) { |
| |
if (ref($balancers) eq 'HASH') { |
| |
next if (exists($balancers->{$lonhost})); |
| |
} |
| |
} |
| |
my $loginvia; |
| |
if ($checkloginvia) { |
| |
$loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost}; |
| |
if ($loginvia) { |
| |
my ($server,$path) = split(/:/,$loginvia); |
| |
($login_host, $lowest_load) = |
| |
&compare_server_load($server, $login_host, $lowest_load, $required); |
| |
if ($login_host eq $server) { |
| |
$portal_path = $path; |
| |
$isredirect = 1; |
| |
} |
| |
} else { |
| |
($login_host, $lowest_load) = |
| |
&compare_server_load($lonhost, $login_host, $lowest_load, $required); |
| |
if ($login_host eq $lonhost) { |
| |
$portal_path = ''; |
| |
$isredirect = ''; |
| |
} |
| |
} |
| |
} else { |
| |
($login_host, $lowest_load) = |
| |
&compare_server_load($lonhost, $login_host, $lowest_load, $required); |
| |
} |
| |
} |
| |
if ($login_host ne '') { |
| |
$hostname = &hostname($login_host); |
| |
} |
| |
return ($login_host,$hostname,$portal_path,$isredirect,$lowest_load); |
| |
} |
| |
|
| |
sub get_course_sessions { |
| |
my ($cnum,$cdom,$lastactivity) = @_; |
| |
my %servers = &internet_dom_servers($cdom); |
| |
my %returnhash; |
| |
foreach my $server (sort(keys(%servers))) { |
| |
my $rep = &reply("coursesessions:$cdom:$cnum:$lastactivity",$server); |
| |
my @pairs=split(/\&/,$rep); |
| |
unless (($rep eq 'unknown_cmd') || ($rep =~ /^error/)) { |
| |
foreach my $item (@pairs) { |
| |
my ($key,$value)=split(/=/,$item,2); |
| |
$key = &unescape($key); |
| |
next if ($key =~ /^error: 2 /); |
| |
if (exists($returnhash{$key})) { |
| |
next if ($value < $returnhash{$key}); |
| |
} |
| |
$returnhash{$key}=$value; |
| |
} |
| |
} |
| |
} |
| |
return %returnhash; |
| |
} |
| |
|
| # --------------------------------------------- Try to change a user's password |
# --------------------------------------------- Try to change a user's password |
| |
|
| sub changepass { |
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 589 sub changepass {
|
Line 1306 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."); |
| |
} elsif ($answer =~ "^prioruse") { |
| |
&logthis("$server refused to change $uname in $udom password because ". |
| |
"the password had been used before"); |
| } |
} |
| return $answer; |
return $answer; |
| } |
} |
|
Line 612 sub queryauthenticate {
|
Line 1335 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)=@_; |
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); |
my $uhome=&homeserver($uname,$udom,1); |
| if (!$uhome) { |
my $newhome; |
| &logthis("User $uname at $udom is unknown in authenticate"); |
if ((!$uhome) || ($uhome eq 'no_host')) { |
| return 'no_host'; |
# Maybe the machine was offline and only re-appeared again recently? |
| |
&reconlonc(); |
| |
# One more |
| |
$uhome=&homeserver($uname,$udom,1); |
| |
if (($uhome eq 'no_host') && $checkdefauth) { |
| |
if (defined(&domain($udom,'primary'))) { |
| |
$newhome=&domain($udom,'primary'); |
| |
} |
| |
if ($newhome ne '') { |
| |
$uhome = $newhome; |
| |
} |
| |
} |
| |
if ((!$uhome) || ($uhome eq 'no_host')) { |
| |
&logthis("User $uname at $udom is unknown in authenticate"); |
| |
return 'no_host'; |
| |
} |
| } |
} |
| my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome); |
my $answer=reply("encrypt:auth:$udom:$uname:$upass:$checkdefauth:$clientcancheckhost",$uhome); |
| if ($answer eq 'authorized') { |
if ($answer eq 'authorized') { |
| &logthis("User $uname at $udom authorized by $uhome"); |
if ($newhome) { |
| return $uhome; |
&logthis("User $uname at $udom authorized by $uhome, but needs account"); |
| |
return 'no_account_on_host'; |
| |
} else { |
| |
&logthis("User $uname at $udom authorized by $uhome"); |
| |
return $uhome; |
| |
} |
| } |
} |
| if ($answer eq 'non_authorized') { |
if ($answer eq 'non_authorized') { |
| &logthis("User $uname at $udom rejected by $uhome"); |
&logthis("User $uname at $udom rejected by $uhome"); |
|
Line 633 sub authenticate {
|
Line 1376 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') { |
| |
my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); |
| |
my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id); |
| |
if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') { |
| |
if (($uint_dom ne '') && |
| |
(grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'excludedomain'}}))) { |
| |
$canhost = 0; |
| |
} else { |
| |
$canhost = 1; |
| |
} |
| |
} |
| |
if (ref($hostedsessions->{'includedomain'}) eq 'ARRAY') { |
| |
if (($uint_dom ne '') && |
| |
(grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'includedomain'}}))) { |
| |
$canhost = 1; |
| |
} else { |
| |
$canhost = 0; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return $canhost; |
| |
} |
| |
|
| |
sub spare_can_host { |
| |
my ($udom,$uint_dom,$remotesessions,$try_server)=@_; |
| |
my $canhost=1; |
| |
my $try_server_hostname = &hostname($try_server); |
| |
my $serverhomeID = &get_server_homeID($try_server_hostname); |
| |
my $serverhomedom = &host_domain($serverhomeID); |
| |
my %defdomdefaults = &get_domain_defaults($serverhomedom); |
| |
if (ref($defdomdefaults{'offloadnow'}) eq 'HASH') { |
| |
if ($defdomdefaults{'offloadnow'}{$try_server}) { |
| |
$canhost = 0; |
| |
} |
| |
} |
| |
if ($canhost) { |
| |
if (ref($defdomdefaults{'offloadoth'}) eq 'HASH') { |
| |
if ($defdomdefaults{'offloadoth'}{$try_server}) { |
| |
unless (&shared_institution($udom,$try_server)) { |
| |
$canhost = 0; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if (($canhost) && ($uint_dom)) { |
| |
my @intdoms; |
| |
my $internet_names = &get_internet_names($try_server); |
| |
if (ref($internet_names) eq 'ARRAY') { |
| |
@intdoms = @{$internet_names}; |
| |
} |
| |
unless (grep(/^\Q$uint_dom\E$/,@intdoms)) { |
| |
my $remoterev = &get_server_loncaparev(undef,$try_server); |
| |
$canhost = &can_host_session($udom,$try_server,$remoterev, |
| |
$remotesessions, |
| |
$defdomdefaults{'hostedsessions'}); |
| |
} |
| |
} |
| |
return $canhost; |
| |
} |
| |
|
| |
sub this_host_spares { |
| |
my ($dom) = @_; |
| |
my ($dom_in_use,$lonhost_in_use,$result); |
| |
my @hosts = ¤t_machine_ids(); |
| |
foreach my $lonhost (@hosts) { |
| |
if (&host_domain($lonhost) eq $dom) { |
| |
$dom_in_use = $dom; |
| |
$lonhost_in_use = $lonhost; |
| |
last; |
| |
} |
| |
} |
| |
if ($dom_in_use ne '') { |
| |
$result = &spares_for_offload($dom_in_use,$lonhost_in_use); |
| |
} |
| |
if (ref($result) ne 'HASH') { |
| |
$lonhost_in_use = $perlvar{'lonHostID'}; |
| |
$dom_in_use = &host_domain($lonhost_in_use); |
| |
$result = &spares_for_offload($dom_in_use,$lonhost_in_use); |
| |
if (ref($result) ne 'HASH') { |
| |
$result = \%spareid; |
| |
} |
| |
} |
| |
return $result; |
| |
} |
| |
|
| |
sub spares_for_offload { |
| |
my ($dom_in_use,$lonhost_in_use) = @_; |
| |
my ($result,$cached)=&is_cached_new('spares',$dom_in_use); |
| |
if (defined($cached)) { |
| |
return $result; |
| |
} else { |
| |
my $cachetime = 60*60*24; |
| |
my %domconfig = |
| |
&Apache::lonnet::get_dom('configuration',['usersessions'],$dom_in_use); |
| |
if (ref($domconfig{'usersessions'}) eq 'HASH') { |
| |
if (ref($domconfig{'usersessions'}{'spares'}) eq 'HASH') { |
| |
if (ref($domconfig{'usersessions'}{'spares'}{$lonhost_in_use}) eq 'HASH') { |
| |
return &do_cache_new('spares',$dom_in_use,$domconfig{'usersessions'}{'spares'}{$lonhost_in_use},$cachetime); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| |
sub get_lonbalancer_config { |
| |
my ($servers) = @_; |
| |
my ($currbalancer,$currtargets); |
| |
if (ref($servers) eq 'HASH') { |
| |
foreach my $server (keys(%{$servers})) { |
| |
my %what = ( |
| |
spareid => 1, |
| |
perlvar => 1, |
| |
); |
| |
my ($result,$returnhash) = &get_remote_globals($server,\%what); |
| |
if ($result eq 'ok') { |
| |
if (ref($returnhash) eq 'HASH') { |
| |
if (ref($returnhash->{'perlvar'}) eq 'HASH') { |
| |
if ($returnhash->{'perlvar'}->{'lonBalancer'} eq 'yes') { |
| |
$currbalancer = $server; |
| |
$currtargets = {}; |
| |
if (ref($returnhash->{'spareid'}) eq 'HASH') { |
| |
if (ref($returnhash->{'spareid'}->{'primary'}) eq 'ARRAY') { |
| |
$currtargets->{'primary'} = $returnhash->{'spareid'}->{'primary'}; |
| |
} |
| |
if (ref($returnhash->{'spareid'}->{'default'}) eq 'ARRAY') { |
| |
$currtargets->{'default'} = $returnhash->{'spareid'}->{'default'}; |
| |
} |
| |
} |
| |
last; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return ($currbalancer,$currtargets); |
| |
} |
| |
|
| |
sub check_loadbalancing { |
| |
my ($uname,$udom,$caller) = @_; |
| |
my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom, |
| |
$rule_in_effect,$offloadto,$otherserver,$setcookie,$dom_balancers); |
| |
my $lonhost = $perlvar{'lonHostID'}; |
| |
my @hosts = ¤t_machine_ids(); |
| |
my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); |
| |
my $uintdom = &Apache::lonnet::internet_dom($uprimary_id); |
| |
my $intdom = &Apache::lonnet::internet_dom($lonhost); |
| |
my $serverhomedom = &host_domain($lonhost); |
| |
my $domneedscache; |
| |
my $cachetime = 60*60*24; |
| |
|
| |
if (($uintdom ne '') && ($uintdom eq $intdom)) { |
| |
$dom_in_use = $udom; |
| |
$homeintdom = 1; |
| |
} else { |
| |
$dom_in_use = $serverhomedom; |
| |
} |
| |
my ($result,$cached)=&is_cached_new('loadbalancing',$dom_in_use); |
| |
unless (defined($cached)) { |
| |
my %domconfig = |
| |
&Apache::lonnet::get_dom('configuration',['loadbalancing'],$dom_in_use); |
| |
if (ref($domconfig{'loadbalancing'}) eq 'HASH') { |
| |
$result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime); |
| |
} else { |
| |
$domneedscache = $dom_in_use; |
| |
} |
| |
} |
| |
if (ref($result) eq 'HASH') { |
| |
($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers) = |
| |
&check_balancer_result($result,@hosts); |
| |
if ($is_balancer) { |
| |
if (ref($currrules) eq 'HASH') { |
| |
if ($homeintdom) { |
| |
if ($uname ne '') { |
| |
if (($currrules->{'_LC_adv'} ne '') || ($currrules->{'_LC_author'} ne '')) { |
| |
my ($is_adv,$is_author) = &is_advanced_user($udom,$uname); |
| |
if (($currrules->{'_LC_author'} ne '') && ($is_author)) { |
| |
$rule_in_effect = $currrules->{'_LC_author'}; |
| |
} elsif (($currrules->{'_LC_adv'} ne '') && ($is_adv)) { |
| |
$rule_in_effect = $currrules->{'_LC_adv'} |
| |
} |
| |
} |
| |
if ($rule_in_effect eq '') { |
| |
my %userenv = &userenvironment($udom,$uname,'inststatus'); |
| |
if ($userenv{'inststatus'} ne '') { |
| |
my @statuses = map { &unescape($_); } split(/:/,$userenv{'inststatus'}); |
| |
my ($othertitle,$usertypes,$types) = |
| |
&Apache::loncommon::sorted_inst_types($udom); |
| |
if (ref($types) eq 'ARRAY') { |
| |
foreach my $type (@{$types}) { |
| |
if (grep(/^\Q$type\E$/,@statuses)) { |
| |
if (exists($currrules->{$type})) { |
| |
$rule_in_effect = $currrules->{$type}; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} else { |
| |
if (exists($currrules->{'default'})) { |
| |
$rule_in_effect = $currrules->{'default'}; |
| |
} |
| |
} |
| |
} |
| |
} else { |
| |
if (exists($currrules->{'default'})) { |
| |
$rule_in_effect = $currrules->{'default'}; |
| |
} |
| |
} |
| |
} else { |
| |
if ($currrules->{'_LC_external'} ne '') { |
| |
$rule_in_effect = $currrules->{'_LC_external'}; |
| |
} |
| |
} |
| |
$offloadto = &get_loadbalancer_targets($rule_in_effect,$currtargets, |
| |
$uname,$udom); |
| |
} |
| |
} |
| |
} elsif (($homeintdom) && ($udom ne $serverhomedom)) { |
| |
($result,$cached)=&is_cached_new('loadbalancing',$serverhomedom); |
| |
unless (defined($cached)) { |
| |
my %domconfig = |
| |
&Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom); |
| |
if (ref($domconfig{'loadbalancing'}) eq 'HASH') { |
| |
$result = &do_cache_new('loadbalancing',$serverhomedom,$domconfig{'loadbalancing'},$cachetime); |
| |
} else { |
| |
$domneedscache = $serverhomedom; |
| |
} |
| |
} |
| |
if (ref($result) eq 'HASH') { |
| |
($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers) = |
| |
&check_balancer_result($result,@hosts); |
| |
if ($is_balancer) { |
| |
if (ref($currrules) eq 'HASH') { |
| |
if ($currrules->{'_LC_internetdom'} ne '') { |
| |
$rule_in_effect = $currrules->{'_LC_internetdom'}; |
| |
} |
| |
} |
| |
$offloadto = &get_loadbalancer_targets($rule_in_effect,$currtargets, |
| |
$uname,$udom); |
| |
} |
| |
} else { |
| |
if ($perlvar{'lonBalancer'} eq 'yes') { |
| |
$is_balancer = 1; |
| |
$offloadto = &this_host_spares($dom_in_use); |
| |
} |
| |
unless (defined($cached)) { |
| |
$domneedscache = $serverhomedom; |
| |
} |
| |
} |
| |
} else { |
| |
if ($perlvar{'lonBalancer'} eq 'yes') { |
| |
$is_balancer = 1; |
| |
$offloadto = &this_host_spares($dom_in_use); |
| |
} |
| |
unless (defined($cached)) { |
| |
$domneedscache = $serverhomedom; |
| |
} |
| |
} |
| |
if ($domneedscache) { |
| |
&do_cache_new('loadbalancing',$domneedscache,$is_balancer,$cachetime); |
| |
} |
| |
if (($is_balancer) && ($caller ne 'switchserver')) { |
| |
my $lowest_load = 30000; |
| |
if (ref($offloadto) eq 'HASH') { |
| |
if (ref($offloadto->{'primary'}) eq 'ARRAY') { |
| |
foreach my $try_server (@{$offloadto->{'primary'}}) { |
| |
($otherserver,$lowest_load) = |
| |
&compare_server_load($try_server,$otherserver,$lowest_load); |
| |
} |
| |
} |
| |
my $found_server = ($otherserver ne '' && $lowest_load < 100); |
| |
|
| |
if (!$found_server) { |
| |
if (ref($offloadto->{'default'}) eq 'ARRAY') { |
| |
foreach my $try_server (@{$offloadto->{'default'}}) { |
| |
($otherserver,$lowest_load) = |
| |
&compare_server_load($try_server,$otherserver,$lowest_load); |
| |
} |
| |
} |
| |
} |
| |
} elsif (ref($offloadto) eq 'ARRAY') { |
| |
if (@{$offloadto} == 1) { |
| |
$otherserver = $offloadto->[0]; |
| |
} elsif (@{$offloadto} > 1) { |
| |
foreach my $try_server (@{$offloadto}) { |
| |
($otherserver,$lowest_load) = |
| |
&compare_server_load($try_server,$otherserver,$lowest_load); |
| |
} |
| |
} |
| |
} |
| |
unless ($caller eq 'login') { |
| |
if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) { |
| |
$is_balancer = 0; |
| |
if ($uname ne '' && $udom ne '') { |
| |
if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) { |
| |
&appenv({'user.loadbalexempt' => $lonhost, |
| |
'user.loadbalcheck.time' => time}); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if (($is_balancer) && (!$homeintdom)) { |
| |
undef($setcookie); |
| |
} |
| |
return ($is_balancer,$otherserver,$setcookie,$offloadto,$dom_balancers); |
| |
} |
| |
|
| |
sub check_balancer_result { |
| |
my ($result,@hosts) = @_; |
| |
my ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers); |
| |
if (ref($result) eq 'HASH') { |
| |
if ($result->{'lonhost'} ne '') { |
| |
my $currbalancer = $result->{'lonhost'}; |
| |
if (grep(/^\Q$currbalancer\E$/,@hosts)) { |
| |
$is_balancer = 1; |
| |
$currtargets = $result->{'targets'}; |
| |
$currrules = $result->{'rules'}; |
| |
} |
| |
$dom_balancers = $currbalancer; |
| |
} else { |
| |
if (keys(%{$result})) { |
| |
foreach my $key (keys(%{$result})) { |
| |
if (($key ne '') && (grep(/^\Q$key\E$/,@hosts)) && |
| |
(ref($result->{$key}) eq 'HASH')) { |
| |
$is_balancer = 1; |
| |
$currrules = $result->{$key}{'rules'}; |
| |
$currtargets = $result->{$key}{'targets'}; |
| |
$setcookie = $result->{$key}{'cookie'}; |
| |
last; |
| |
} |
| |
} |
| |
$dom_balancers = join(',',sort(keys(%{$result}))); |
| |
} |
| |
} |
| |
} |
| |
return ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers); |
| |
} |
| |
|
| |
sub get_loadbalancer_targets { |
| |
my ($rule_in_effect,$currtargets,$uname,$udom) = @_; |
| |
my $offloadto; |
| |
if ($rule_in_effect eq 'none') { |
| |
return [$perlvar{'lonHostID'}]; |
| |
} elsif ($rule_in_effect eq '') { |
| |
$offloadto = $currtargets; |
| |
} else { |
| |
if ($rule_in_effect eq 'homeserver') { |
| |
my $homeserver = &homeserver($uname,$udom); |
| |
if ($homeserver ne 'no_host') { |
| |
$offloadto = [$homeserver]; |
| |
} |
| |
} elsif ($rule_in_effect eq 'externalbalancer') { |
| |
my %domconfig = |
| |
&Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom); |
| |
if (ref($domconfig{'loadbalancing'}) eq 'HASH') { |
| |
if ($domconfig{'loadbalancing'}{'lonhost'} ne '') { |
| |
if (&hostname($domconfig{'loadbalancing'}{'lonhost'}) ne '') { |
| |
$offloadto = [$domconfig{'loadbalancing'}{'lonhost'}]; |
| |
} |
| |
} |
| |
} else { |
| |
my %servers = &internet_dom_servers($udom); |
| |
my ($remotebalancer,$remotetargets) = &get_lonbalancer_config(\%servers); |
| |
if (&hostname($remotebalancer) ne '') { |
| |
$offloadto = [$remotebalancer]; |
| |
} |
| |
} |
| |
} elsif (&hostname($rule_in_effect) ne '') { |
| |
$offloadto = [$rule_in_effect]; |
| |
} |
| |
} |
| |
return $offloadto; |
| |
} |
| |
|
| |
sub internet_dom_servers { |
| |
my ($dom) = @_; |
| |
my (%uniqservers,%servers); |
| |
my $primaryserver = &hostname(&domain($dom,'primary')); |
| |
my @machinedoms = &machine_domains($primaryserver); |
| |
foreach my $mdom (@machinedoms) { |
| |
my %currservers = %servers; |
| |
my %server = &get_servers($mdom); |
| |
%servers = (%currservers,%server); |
| |
} |
| |
my %by_hostname; |
| |
foreach my $id (keys(%servers)) { |
| |
push(@{$by_hostname{$servers{$id}}},$id); |
| |
} |
| |
foreach my $hostname (sort(keys(%by_hostname))) { |
| |
if (@{$by_hostname{$hostname}} > 1) { |
| |
my $match = 0; |
| |
foreach my $id (@{$by_hostname{$hostname}}) { |
| |
if (&host_domain($id) eq $dom) { |
| |
$uniqservers{$id} = $hostname; |
| |
$match = 1; |
| |
} |
| |
} |
| |
unless ($match) { |
| |
$uniqservers{$by_hostname{$hostname}[0]} = $hostname; |
| |
} |
| |
} else { |
| |
$uniqservers{$by_hostname{$hostname}[0]} = $hostname; |
| |
} |
| |
} |
| |
return %uniqservers; |
| |
} |
| |
|
| |
sub trusted_domains { |
| |
my ($cmdtype,$calldom) = @_; |
| |
my ($trusted,$untrusted); |
| |
if (&domain($calldom) eq '') { |
| |
return ($trusted,$untrusted); |
| |
} |
| |
unless ($cmdtype =~ /^(content|shared|enroll|coaurem|othcoau|domroles|catalog|reqcrs|msg)$/) { |
| |
return ($trusted,$untrusted); |
| |
} |
| |
my $callprimary = &domain($calldom,'primary'); |
| |
my $intcalldom = &Apache::lonnet::internet_dom($callprimary); |
| |
if ($intcalldom eq '') { |
| |
return ($trusted,$untrusted); |
| |
} |
| |
|
| |
my ($trustconfig,$cached)=&Apache::lonnet::is_cached_new('trust',$calldom); |
| |
unless (defined($cached)) { |
| |
my %domconfig = &Apache::lonnet::get_dom('configuration',['trust'],$calldom); |
| |
&Apache::lonnet::do_cache_new('trust',$calldom,$domconfig{'trust'},3600); |
| |
$trustconfig = $domconfig{'trust'}; |
| |
} |
| |
if (ref($trustconfig)) { |
| |
my (%possexc,%possinc,@allexc,@allinc); |
| |
if (ref($trustconfig->{$cmdtype}) eq 'HASH') { |
| |
if (ref($trustconfig->{$cmdtype}->{'exc'}) eq 'ARRAY') { |
| |
map { $possexc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'exc'}}; |
| |
} |
| |
if (ref($trustconfig->{$cmdtype}->{'inc'}) eq 'ARRAY') { |
| |
$possinc{$intcalldom} = 1; |
| |
map { $possinc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'inc'}}; |
| |
} |
| |
} |
| |
if (keys(%possexc)) { |
| |
if (keys(%possinc)) { |
| |
foreach my $key (sort(keys(%possexc))) { |
| |
next if ($key eq $intcalldom); |
| |
unless ($possinc{$key}) { |
| |
push(@allexc,$key); |
| |
} |
| |
} |
| |
} else { |
| |
@allexc = sort(keys(%possexc)); |
| |
} |
| |
} |
| |
if (keys(%possinc)) { |
| |
$possinc{$intcalldom} = 1; |
| |
@allinc = sort(keys(%possinc)); |
| |
} |
| |
if ((@allexc > 0) || (@allinc > 0)) { |
| |
my %doms_by_intdom; |
| |
my %allintdoms = &all_host_intdom(); |
| |
my %alldoms = &all_host_domain(); |
| |
foreach my $key (%allintdoms) { |
| |
if (ref($doms_by_intdom{$allintdoms{$key}}) eq 'ARRAY') { |
| |
unless (grep(/^\Q$alldoms{$key}\E$/,@{$doms_by_intdom{$allintdoms{$key}}})) { |
| |
push(@{$doms_by_intdom{$allintdoms{$key}}},$alldoms{$key}); |
| |
} |
| |
} else { |
| |
$doms_by_intdom{$allintdoms{$key}} = [$alldoms{$key}]; |
| |
} |
| |
} |
| |
foreach my $exc (@allexc) { |
| |
if (ref($doms_by_intdom{$exc}) eq 'ARRAY') { |
| |
push(@{$untrusted},@{$doms_by_intdom{$exc}}); |
| |
} |
| |
} |
| |
foreach my $inc (@allinc) { |
| |
if (ref($doms_by_intdom{$inc}) eq 'ARRAY') { |
| |
push(@{$trusted},@{$doms_by_intdom{$inc}}); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return ($trusted,$untrusted); |
| |
} |
| |
|
| |
sub will_trust { |
| |
my ($cmdtype,$domain,$possdom) = @_; |
| |
return 1 if ($domain eq $possdom); |
| |
my ($trustedref,$untrustedref) = &trusted_domains($cmdtype,$possdom); |
| |
my $willtrust; |
| |
if ((ref($trustedref) eq 'ARRAY') && (@{$trustedref} > 0)) { |
| |
if (grep(/^\Q$domain\E$/,@{$trustedref})) { |
| |
$willtrust = 1; |
| |
} |
| |
} elsif ((ref($untrustedref) eq 'ARRAY') && (@{$untrustedref} > 0)) { |
| |
unless (grep(/^\Q$domain\E$/,@{$untrustedref})) { |
| |
$willtrust = 1; |
| |
} |
| |
} else { |
| |
$willtrust = 1; |
| |
} |
| |
return $willtrust; |
| |
} |
| |
|
| # ---------------------- 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 641 sub homeserver {
|
Line 1927 sub homeserver {
|
| my $index="$uname:$udom"; |
my $index="$uname:$udom"; |
| |
|
| if (exists($homecache{$index})) { return $homecache{$index}; } |
if (exists($homecache{$index})) { return $homecache{$index}; } |
| my $tryserver; |
|
| foreach $tryserver (keys %libserv) { |
my %servers = &get_servers($udom,'library'); |
| |
foreach my $tryserver (keys(%servers)) { |
| next if ($ignoreBadCache ne 'true' && |
next if ($ignoreBadCache ne 'true' && |
| exists($badServerCache{$tryserver})); |
exists($badServerCache{$tryserver})); |
| if ($hostdom{$tryserver} eq $udom) { |
|
| my $answer=reply("home:$udom:$uname",$tryserver); |
my $answer=reply("home:$udom:$uname",$tryserver); |
| if ($answer eq 'found') { |
if ($answer eq 'found') { |
| return $homecache{$index}=$tryserver; |
delete($badServerCache{$tryserver}); |
| } elsif ($answer eq 'no_host') { |
return $homecache{$index}=$tryserver; |
| $badServerCache{$tryserver}=1; |
} elsif ($answer eq 'no_host') { |
| } |
$badServerCache{$tryserver}=1; |
| } |
} |
| } |
} |
| return 'no_host'; |
return 'no_host'; |
| } |
} |
| |
|
| # ------------------------------------- Find the usernames behind a list of IDs |
# ----- Find the usernames behind a list of student/employee IDs or clicker IDs |
| |
|
| sub idget { |
sub idget { |
| my ($udom,@ids)=@_; |
my ($udom,$idsref,$namespace)=@_; |
| my %returnhash=(); |
my %returnhash=(); |
| |
my @ids=(); |
| |
if (ref($idsref) eq 'ARRAY') { |
| |
@ids = @{$idsref}; |
| |
} else { |
| |
return %returnhash; |
| |
} |
| |
if ($namespace eq '') { |
| |
$namespace = 'ids'; |
| |
} |
| |
|
| my $tryserver; |
my %servers = &get_servers($udom,'library'); |
| foreach $tryserver (keys %libserv) { |
foreach my $tryserver (keys(%servers)) { |
| if ($hostdom{$tryserver} eq $udom) { |
my $idlist=join('&', map { &escape($_); } @ids); |
| my $idlist=join('&',@ids); |
if ($namespace eq 'ids') { |
| $idlist=~tr/A-Z/a-z/; |
$idlist=~tr/A-Z/a-z/; |
| my $reply=&reply("idget:$udom:".$idlist,$tryserver); |
} |
| my @answer=(); |
my $reply; |
| if (($reply ne 'con_lost') && ($reply!~/^error\:/)) { |
if ($namespace eq 'ids') { |
| @answer=split(/\&/,$reply); |
$reply=&reply("idget:$udom:".$idlist,$tryserver); |
| } ; |
} else { |
| my $i; |
$reply=&reply("getdom:$udom:$namespace:$idlist",$tryserver); |
| for ($i=0;$i<=$#ids;$i++) { |
} |
| if ($answer[$i]) { |
my @answer=(); |
| $returnhash{$ids[$i]}=$answer[$i]; |
if (($reply ne 'con_lost') && ($reply!~/^error\:/)) { |
| } |
@answer=split(/\&/,$reply); |
| } |
} ; |
| } |
my $i; |
| } |
for ($i=0;$i<=$#ids;$i++) { |
| |
if ($answer[$i]) { |
| |
$returnhash{$ids[$i]}=&unescape($answer[$i]); |
| |
} |
| |
} |
| |
} |
| return %returnhash; |
return %returnhash; |
| } |
} |
| |
|
|
Line 695 sub idrget {
|
Line 1996 sub idrget {
|
| return %returnhash; |
return %returnhash; |
| } |
} |
| |
|
| # ------------------------------- Store away a list of names and associated IDs |
# Store away a list of names and associated student/employee IDs or clicker IDs |
| |
|
| sub idput { |
sub idput { |
| my ($udom,%ids)=@_; |
my ($udom,$idsref,$uhom,$namespace)=@_; |
| my %servers=(); |
my %servers=(); |
| |
my %ids=(); |
| |
my %byid = (); |
| |
if (ref($idsref) eq 'HASH') { |
| |
%ids=%{$idsref}; |
| |
} |
| |
if ($namespace eq '') { |
| |
$namespace = 'ids'; |
| |
} |
| foreach my $uname (keys(%ids)) { |
foreach my $uname (keys(%ids)) { |
| &cput('environment',{'id'=>$ids{$uname}},$udom,$uname); |
&cput('environment',{'id'=>$ids{$uname}},$udom,$uname); |
| my $uhom=&homeserver($uname,$udom); |
if ($uhom eq '') { |
| |
$uhom=&homeserver($uname,$udom); |
| |
} |
| if ($uhom ne 'no_host') { |
if ($uhom ne 'no_host') { |
| my $id=&escape($ids{$uname}); |
|
| $id=~tr/A-Z/a-z/; |
|
| my $esc_unam=&escape($uname); |
my $esc_unam=&escape($uname); |
| if ($servers{$uhom}) { |
if ($namespace eq 'ids') { |
| $servers{$uhom}.='&'.$id.'='.$esc_unam; |
my $id=&escape($ids{$uname}); |
| |
$id=~tr/A-Z/a-z/; |
| |
my $esc_unam=&escape($uname); |
| |
$servers{$uhom}.=$id.'='.$esc_unam.'&'; |
| } else { |
} else { |
| $servers{$uhom}=$id.'='.$esc_unam; |
my @currids = split(/,/,$ids{$uname}); |
| |
foreach my $id (@currids) { |
| |
$byid{$uhom}{$id} .= $uname.','; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if ($namespace eq 'clickers') { |
| |
foreach my $server (keys(%byid)) { |
| |
if (ref($byid{$server}) eq 'HASH') { |
| |
foreach my $id (keys(%{$byid{$server}})) { |
| |
$byid{$server} =~ s/,$//; |
| |
$servers{$uhom}.=&escape($id).'='.&escape($byid{$server}).'&'; |
| |
} |
| } |
} |
| } |
} |
| } |
} |
| foreach my $server (keys(%servers)) { |
foreach my $server (keys(%servers)) { |
| &critical('idput:'.$udom.':'.$servers{$server},$server); |
$servers{$server} =~ s/\&$//; |
| |
if ($namespace eq 'ids') { |
| |
&critical('idput:'.$udom.':'.$servers{$server},$server); |
| |
} else { |
| |
&critical('updateclickers:'.$udom.':add:'.$servers{$server},$server); |
| |
} |
| } |
} |
| } |
} |
| |
|
| # ------------------------------------------- get items from domain db files |
# ------------- Delete unwanted student/employee IDs or clicker IDs from domain |
| |
|
| |
sub iddel { |
| |
my ($udom,$idshashref,$uhome,$namespace)=@_; |
| |
my %result=(); |
| |
my %ids=(); |
| |
my %byid = (); |
| |
if (ref($idshashref) eq 'HASH') { |
| |
%ids=%{$idshashref}; |
| |
} else { |
| |
return %result; |
| |
} |
| |
if ($namespace eq '') { |
| |
$namespace = 'ids'; |
| |
} |
| |
my %servers=(); |
| |
while (my ($id,$unamestr) = each(%ids)) { |
| |
if ($namespace eq 'ids') { |
| |
my $uhom = $uhome; |
| |
if ($uhom eq '') { |
| |
$uhom=&homeserver($unamestr,$udom); |
| |
} |
| |
if ($uhom ne 'no_host') { |
| |
$servers{$uhom}.='&'.&escape($id); |
| |
} |
| |
} else { |
| |
my @curritems = split(/,/,$ids{$id}); |
| |
foreach my $uname (@curritems) { |
| |
my $uhom = $uhome; |
| |
if ($uhom eq '') { |
| |
$uhom=&homeserver($uname,$udom); |
| |
} |
| |
if ($uhom ne 'no_host') { |
| |
$byid{$uhom}{$id} .= $uname.','; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if ($namespace eq 'clickers') { |
| |
foreach my $server (keys(%byid)) { |
| |
if (ref($byid{$server}) eq 'HASH') { |
| |
foreach my $id (keys(%{$byid{$server}})) { |
| |
$byid{$server}{$id} =~ s/,$//; |
| |
$servers{$server}.=&escape($id).'='.&escape($byid{$server}{$id}).'&'; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
foreach my $server (keys(%servers)) { |
| |
$servers{$server} =~ s/\&$//; |
| |
if ($namespace eq 'ids') { |
| |
$result{$server} = &critical('iddel:'.$udom.':'.$servers{$server},$uhome); |
| |
} elsif ($namespace eq 'clickers') { |
| |
$result{$server} = &critical('updateclickers:'.$udom.':del:'.$servers{$server},$server); |
| |
} |
| |
} |
| |
return %result; |
| |
} |
| |
|
| |
# ----- Update clicker ID-to-username look-ups in clickers.db on library server |
| |
|
| |
sub updateclickers { |
| |
my ($udom,$action,$idshashref,$uhome,$critical) = @_; |
| |
my %clickers; |
| |
if (ref($idshashref) eq 'HASH') { |
| |
%clickers=%{$idshashref}; |
| |
} else { |
| |
return; |
| |
} |
| |
my $items=''; |
| |
foreach my $item (keys(%clickers)) { |
| |
$items.=&escape($item).'='.&escape($clickers{$item}).'&'; |
| |
} |
| |
$items=~s/\&$//; |
| |
my $request = "updateclickers:$udom:$action:$items"; |
| |
if ($critical) { |
| |
return &critical($request,$uhome); |
| |
} else { |
| |
return &reply($request,$uhome); |
| |
} |
| |
} |
| |
|
| |
# ------------------------------dump from db file owned by domainconfig user |
| |
sub dump_dom { |
| |
my ($namespace, $udom, $regexp) = @_; |
| |
|
| |
$udom ||= $env{'user.domain'}; |
| |
|
| |
return () unless $udom; |
| |
|
| |
return &dump($namespace, $udom, &get_domainconfiguser($udom), $regexp); |
| |
} |
| |
|
| |
# ------------------------------------------ get items from domain db files |
| |
|
| sub get_dom { |
sub get_dom { |
| my ($namespace,$storearr,$udom)=@_; |
my ($namespace,$storearr,$udom,$uhome)=@_; |
| |
return if ($udom eq 'public'); |
| my $items=''; |
my $items=''; |
| foreach my $item (@$storearr) { |
foreach my $item (@$storearr) { |
| $items.=&escape($item).'&'; |
$items.=&escape($item).'&'; |
| } |
} |
| $items=~s/\&$//; |
$items=~s/\&$//; |
| if (!$udom) { $udom=$env{'user.domain'}; } |
if (!$udom) { |
| if (exists($domain_primary{$udom})) { |
$udom=$env{'user.domain'}; |
| my $uhome=$domain_primary{$udom}; |
return if ($udom eq 'public'); |
| my $rep=&reply("getdom:$udom:$namespace:$items",$uhome); |
if (defined(&domain($udom,'primary'))) { |
| |
$uhome=&domain($udom,'primary'); |
| |
} else { |
| |
undef($uhome); |
| |
} |
| |
} else { |
| |
if (!$uhome) { |
| |
if (defined(&domain($udom,'primary'))) { |
| |
$uhome=&domain($udom,'primary'); |
| |
} |
| |
} |
| |
} |
| |
if ($udom && $uhome && ($uhome ne 'no_host')) { |
| |
my $rep; |
| |
if (grep { $_ eq $uhome } ¤t_machine_ids()) { |
| |
# domain information is hosted on this machine |
| |
my $cmd = 'getdom'; |
| |
if ($namespace =~ /^enc/) { |
| |
$cmd = 'egetdom'; |
| |
} |
| |
$rep = &LONCAPA::Lond::get_dom("$cmd:$udom:$namespace:$items"); |
| |
} else { |
| |
if ($namespace =~ /^enc/) { |
| |
$rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome); |
| |
} else { |
| |
$rep=&reply("getdom:$udom:$namespace:$items",$uhome); |
| |
} |
| |
} |
| |
my %returnhash; |
| |
if ($rep eq '' || $rep =~ /^error: 2 /) { |
| |
return %returnhash; |
| |
} |
| my @pairs=split(/\&/,$rep); |
my @pairs=split(/\&/,$rep); |
| if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) { |
if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) { |
| return @pairs; |
return @pairs; |
| } |
} |
| my %returnhash=(); |
|
| my $i=0; |
my $i=0; |
| foreach my $item (@$storearr) { |
foreach my $item (@$storearr) { |
| $returnhash{$item}=&thaw_unescape($pairs[$i]); |
$returnhash{$item}=&thaw_unescape($pairs[$i]); |
|
Line 744 sub get_dom {
|
Line 2198 sub get_dom {
|
| } |
} |
| return %returnhash; |
return %returnhash; |
| } else { |
} else { |
| &logthis("get_dom failed - no primary domain server for $udom"); |
&logthis("get_dom failed - no homeserver and/or domain ($udom) ($uhome)"); |
| } |
} |
| } |
} |
| |
|
| # -------------------------------------------- put items in domain db files |
# -------------------------------------------- put items in domain db files |
| |
|
| sub put_dom { |
sub put_dom { |
| my ($namespace,$storehash,$udom)=@_; |
my ($namespace,$storehash,$udom,$uhome)=@_; |
| if (!$udom) { $udom=$env{'user.domain'}; } |
if (!$udom) { |
| if (exists($domain_primary{$udom})) { |
$udom=$env{'user.domain'}; |
| my $uhome=$domain_primary{$udom}; |
if (defined(&domain($udom,'primary'))) { |
| |
$uhome=&domain($udom,'primary'); |
| |
} else { |
| |
undef($uhome); |
| |
} |
| |
} else { |
| |
if (!$uhome) { |
| |
if (defined(&domain($udom,'primary'))) { |
| |
$uhome=&domain($udom,'primary'); |
| |
} |
| |
} |
| |
} |
| |
if ($udom && $uhome && ($uhome ne 'no_host')) { |
| my $items=''; |
my $items=''; |
| foreach my $item (keys(%$storehash)) { |
foreach my $item (keys(%$storehash)) { |
| $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; |
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; |
| } |
} |
| $items=~s/\&$//; |
$items=~s/\&$//; |
| return &reply("putdom:$udom:$namespace:$items",$uhome); |
if ($namespace =~ /^enc/) { |
| |
return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome); |
| |
} else { |
| |
return &reply("putdom:$udom:$namespace:$items",$uhome); |
| |
} |
| |
} else { |
| |
&logthis("put_dom failed - no homeserver and/or domain"); |
| |
} |
| |
} |
| |
|
| |
# --------------------- 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 { |
| |
my ($udom) = @_; |
| |
my (%returnhash,@order); |
| |
my %domdefs = &Apache::lonnet::get_domain_defaults($udom); |
| |
if ((ref($domdefs{'inststatustypes'}) eq 'HASH') && |
| |
(ref($domdefs{'inststatusorder'}) eq 'ARRAY')) { |
| |
return ($domdefs{'inststatustypes'},$domdefs{'inststatusorder'}); |
| |
} else { |
| |
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("retrieve_inst_usertypes 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("retrieve_inst_usertypes failed - no primary domain server for $udom"); |
| |
} |
| |
return (\%returnhash,\@order); |
| |
} |
| |
} |
| |
|
| |
sub is_domainimage { |
| |
my ($url) = @_; |
| |
if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+[^/]-) { |
| |
if (&domain($1) ne '') { |
| |
return '1'; |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| |
sub inst_directory_query { |
| |
my ($srch) = @_; |
| |
my $udom = $srch->{'srchdomain'}; |
| |
my %results; |
| |
my $homeserver = &domain($udom,'primary'); |
| |
my $outcome; |
| |
if ($homeserver ne '') { |
| |
unless ($homeserver eq $perlvar{'lonHostID'}) { |
| |
if ($srch->{'srchby'} eq 'email') { |
| |
my $lcrev = &get_server_loncaparev($udom,$homeserver); |
| |
my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/); |
| |
if (($major eq '' && $minor eq '') || ($major < 2) || |
| |
(($major == 2) && ($minor < 12))) { |
| |
return; |
| |
} |
| |
} |
| |
} |
| |
my $queryid=&reply("querysend:instdirsearch:". |
| |
&escape($srch->{'srchby'}).':'. |
| |
&escape($srch->{'srchterm'}).':'. |
| |
&escape($srch->{'srchtype'}),$homeserver); |
| |
my $host=&hostname($homeserver); |
| |
if ($queryid !~/^\Q$host\E\_/) { |
| |
&logthis('institutional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.' in domain '.$udom); |
| |
return; |
| |
} |
| |
my $response = &get_query_reply($queryid); |
| |
my $maxtries = 5; |
| |
my $tries = 1; |
| |
while (($response=~/^timeout/) && ($tries < $maxtries)) { |
| |
$response = &get_query_reply($queryid); |
| |
$tries ++; |
| |
} |
| |
|
| |
if (!&error($response) && $response ne 'refused') { |
| |
if ($response eq 'unavailable') { |
| |
$outcome = $response; |
| |
} else { |
| |
$outcome = 'ok'; |
| |
my @matches = split(/\n/,$response); |
| |
foreach my $match (@matches) { |
| |
my ($key,$value) = split(/=/,$match); |
| |
$results{&unescape($key).':'.$udom} = &thaw_unescape($value); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return ($outcome,%results); |
| |
} |
| |
|
| |
sub usersearch { |
| |
my ($srch) = @_; |
| |
my $dom = $srch->{'srchdomain'}; |
| |
my %results; |
| |
my %libserv = &all_library(); |
| |
my $query = 'usersearch'; |
| |
foreach my $tryserver (keys(%libserv)) { |
| |
if (&host_domain($tryserver) eq $dom) { |
| |
unless ($tryserver eq $perlvar{'lonHostID'}) { |
| |
if ($srch->{'srchby'} eq 'email') { |
| |
my $lcrev = &get_server_loncaparev($dom,$tryserver); |
| |
my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/); |
| |
next if (($major eq '' && $minor eq '') || ($major < 2) || |
| |
(($major == 2) && ($minor < 12))); |
| |
} |
| |
} |
| |
my $host=&hostname($tryserver); |
| |
my $queryid= |
| |
&reply("querysend:".&escape($query).':'. |
| |
&escape($srch->{'srchby'}).':'. |
| |
&escape($srch->{'srchtype'}).':'. |
| |
&escape($srch->{'srchterm'}),$tryserver); |
| |
if ($queryid !~/^\Q$host\E\_/) { |
| |
&logthis('usersearch: invalid queryid: '.$queryid.' for host: '.$host.'in domain '.$dom.' and server: '.$tryserver); |
| |
next; |
| |
} |
| |
my $reply = &get_query_reply($queryid); |
| |
my $maxtries = 1; |
| |
my $tries = 1; |
| |
while (($reply=~/^timeout/) && ($tries < $maxtries)) { |
| |
$reply = &get_query_reply($queryid); |
| |
$tries ++; |
| |
} |
| |
if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { |
| |
&logthis('usersrch error: '.$reply.' for '.$dom.' - searching for : '.$srch->{'srchterm'}.' by '.$srch->{'srchby'}.' ('.$srch->{'srchtype'}.') - maxtries: '.$maxtries.' tries: '.$tries); |
| |
} else { |
| |
my @matches; |
| |
if ($reply =~ /\n/) { |
| |
@matches = split(/\n/,$reply); |
| |
} else { |
| |
@matches = split(/\&/,$reply); |
| |
} |
| |
foreach my $match (@matches) { |
| |
my ($uname,$udom,%userhash); |
| |
foreach my $entry (split(/:/,$match)) { |
| |
my ($key,$value) = |
| |
map {&unescape($_);} split(/=/,$entry); |
| |
$userhash{$key} = $value; |
| |
if ($key eq 'username') { |
| |
$uname = $value; |
| |
} elsif ($key eq 'domain') { |
| |
$udom = $value; |
| |
} |
| |
} |
| |
$results{$uname.':'.$udom} = \%userhash; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return %results; |
| |
} |
| |
|
| |
sub get_instuser { |
| |
my ($udom,$uname,$id) = @_; |
| |
my $homeserver = &domain($udom,'primary'); |
| |
my ($outcome,%results); |
| |
if ($homeserver ne '') { |
| |
my $queryid=&reply("querysend:getinstuser:".&escape($uname).':'. |
| |
&escape($id).':'.&escape($udom),$homeserver); |
| |
my $host=&hostname($homeserver); |
| |
if ($queryid !~/^\Q$host\E\_/) { |
| |
&logthis('get_instuser invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom); |
| |
return; |
| |
} |
| |
my $response = &get_query_reply($queryid); |
| |
my $maxtries = 5; |
| |
my $tries = 1; |
| |
while (($response=~/^timeout/) && ($tries < $maxtries)) { |
| |
$response = &get_query_reply($queryid); |
| |
$tries ++; |
| |
} |
| |
if (!&error($response) && $response ne 'refused') { |
| |
if ($response eq 'unavailable') { |
| |
$outcome = $response; |
| |
} else { |
| |
$outcome = 'ok'; |
| |
my @matches = split(/\n/,$response); |
| |
foreach my $match (@matches) { |
| |
my ($key,$value) = split(/=/,$match); |
| |
$results{&unescape($key)} = &thaw_unescape($value); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
my %userinfo; |
| |
if (ref($results{$uname}) eq 'HASH') { |
| |
%userinfo = %{$results{$uname}}; |
| |
} |
| |
return ($outcome,%userinfo); |
| |
} |
| |
|
| |
sub get_multiple_instusers { |
| |
my ($udom,$users,$caller) = @_; |
| |
my ($outcome,$results); |
| |
if (ref($users) eq 'HASH') { |
| |
my $count = keys(%{$users}); |
| |
my $requested = &freeze_escape($users); |
| |
my $homeserver = &domain($udom,'primary'); |
| |
if ($homeserver ne '') { |
| |
my $queryid=&reply('querysend:getmultinstusers:::'.$caller.'='.$requested,$homeserver); |
| |
my $host=&hostname($homeserver); |
| |
if ($queryid !~/^\Q$host\E\_/) { |
| |
&logthis('get_multiple_instusers invalid queryid: '.$queryid. |
| |
' for host: '.$homeserver.'in domain '.$udom); |
| |
return ($outcome,$results); |
| |
} |
| |
my $response = &get_query_reply($queryid); |
| |
my $maxtries = 5; |
| |
if ($count > 100) { |
| |
$maxtries = 1+int($count/20); |
| |
} |
| |
my $tries = 1; |
| |
while (($response=~/^timeout/) && ($tries <= $maxtries)) { |
| |
$response = &get_query_reply($queryid); |
| |
$tries ++; |
| |
} |
| |
if ($response eq '') { |
| |
$results = {}; |
| |
foreach my $key (keys(%{$users})) { |
| |
my ($uname,$id); |
| |
if ($caller eq 'id') { |
| |
$id = $key; |
| |
} else { |
| |
$uname = $key; |
| |
} |
| |
my ($resp,%info) = &get_instuser($udom,$uname,$id); |
| |
$outcome = $resp; |
| |
if ($resp eq 'ok') { |
| |
%{$results} = (%{$results}, %info); |
| |
} else { |
| |
last; |
| |
} |
| |
} |
| |
} elsif(!&error($response) && ($response ne 'refused')) { |
| |
if (($response eq 'unavailable') || ($response eq 'invalid') || ($response eq 'timeout')) { |
| |
$outcome = $response; |
| |
} else { |
| |
($outcome,my $userdata) = split(/=/,$response,2); |
| |
if ($outcome eq 'ok') { |
| |
$results = &thaw_unescape($userdata); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return ($outcome,$results); |
| |
} |
| |
|
| |
sub inst_rulecheck { |
| |
my ($udom,$uname,$id,$item,$rules) = @_; |
| |
my %returnhash; |
| |
if ($udom ne '') { |
| |
if (ref($rules) eq 'ARRAY') { |
| |
@{$rules} = map {&escape($_);} (@{$rules}); |
| |
my $rulestr = join(':',@{$rules}); |
| |
my $homeserver=&domain($udom,'primary'); |
| |
if (($homeserver ne '') && ($homeserver ne 'no_host')) { |
| |
my $response; |
| |
if ($item eq 'username') { |
| |
$response=&unescape(&reply('instrulecheck:'.&escape($udom). |
| |
':'.&escape($uname).':'.$rulestr, |
| |
$homeserver)); |
| |
} elsif ($item eq 'id') { |
| |
$response=&unescape(&reply('instidrulecheck:'.&escape($udom). |
| |
':'.&escape($id).':'.$rulestr, |
| |
$homeserver)); |
| |
} elsif ($item eq 'selfcreate') { |
| |
$response=&unescape(&reply('instselfcreatecheck:'. |
| |
&escape($udom).':'.&escape($uname). |
| |
':'.$rulestr,$homeserver)); |
| |
} |
| |
if ($response ne 'refused') { |
| |
my @pairs=split(/\&/,$response); |
| |
foreach my $item (@pairs) { |
| |
my ($key,$value)=split(/=/,$item,2); |
| |
$key = &unescape($key); |
| |
next if ($key =~ /^error: 2 /); |
| |
$returnhash{$key}=&thaw_unescape($value); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return %returnhash; |
| |
} |
| |
|
| |
sub inst_userrules { |
| |
my ($udom,$check) = @_; |
| |
my (%ruleshash,@ruleorder); |
| |
if ($udom ne '') { |
| |
my $homeserver=&domain($udom,'primary'); |
| |
if (($homeserver ne '') && ($homeserver ne 'no_host')) { |
| |
my $response; |
| |
if ($check eq 'id') { |
| |
$response=&reply('instidrules:'.&escape($udom), |
| |
$homeserver); |
| |
} elsif ($check eq 'email') { |
| |
$response=&reply('instemailrules:'.&escape($udom), |
| |
$homeserver); |
| |
} else { |
| |
$response=&reply('instuserrules:'.&escape($udom), |
| |
$homeserver); |
| |
} |
| |
if (($response ne 'refused') && ($response ne 'error') && |
| |
($response ne 'unknown_cmd') && |
| |
($response ne 'no_such_host')) { |
| |
my ($hashitems,$orderitems) = split(/:/,$response); |
| |
my @pairs=split(/\&/,$hashitems); |
| |
foreach my $item (@pairs) { |
| |
my ($key,$value)=split(/=/,$item,2); |
| |
$key = &unescape($key); |
| |
next if ($key =~ /^error: 2 /); |
| |
$ruleshash{$key}=&thaw_unescape($value); |
| |
} |
| |
my @esc_order = split(/\&/,$orderitems); |
| |
foreach my $item (@esc_order) { |
| |
push(@ruleorder,&unescape($item)); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return (\%ruleshash,\@ruleorder); |
| |
} |
| |
|
| |
# ------------- Get Authentication, Language and User Tools Defaults for Domain |
| |
|
| |
sub get_domain_defaults { |
| |
my ($domain,$ignore_cache) = @_; |
| |
return if (($domain eq '') || ($domain eq 'public')); |
| |
my $cachetime = 60*60*24; |
| |
unless ($ignore_cache) { |
| |
my ($result,$cached)=&is_cached_new('domdefaults',$domain); |
| |
if (defined($cached)) { |
| |
if (ref($result) eq 'HASH') { |
| |
return %{$result}; |
| |
} |
| |
} |
| |
} |
| |
my %domdefaults; |
| |
my %domconfig = |
| |
&Apache::lonnet::get_dom('configuration',['defaults','quotas', |
| |
'requestcourses','inststatus', |
| |
'coursedefaults','usersessions', |
| |
'requestauthor','selfenrollment', |
| |
'coursecategories','ssl','autoenroll', |
| |
'trust','helpsettings','wafproxy'],$domain); |
| |
my @coursetypes = ('official','unofficial','community','textbook','placement'); |
| |
if (ref($domconfig{'defaults'}) eq 'HASH') { |
| |
$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; |
| |
$domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'}; |
| |
$domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'}; |
| |
$domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'}; |
| |
$domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'}; |
| |
$domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'}; |
| |
$domdefaults{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'}; |
| |
$domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'}; |
| |
$domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'}; |
| |
} else { |
| |
$domdefaults{'lang_def'} = &domain($domain,'lang_def'); |
| |
$domdefaults{'auth_def'} = &domain($domain,'auth_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','webdav','portfolio'); |
| |
foreach my $item (@usertools) { |
| |
if (ref($domconfig{'quotas'}{$item}) eq 'HASH') { |
| |
$domdefaults{$item} = $domconfig{'quotas'}{$item}; |
| |
} |
| |
} |
| |
if (ref($domconfig{'quotas'}{'authorquota'}) eq 'HASH') { |
| |
$domdefaults{'authorquota'} = $domconfig{'quotas'}{'authorquota'}; |
| |
} |
| |
} |
| |
if (ref($domconfig{'requestcourses'}) eq 'HASH') { |
| |
foreach my $item ('official','unofficial','community','textbook','placement') { |
| |
$domdefaults{$item} = $domconfig{'requestcourses'}{$item}; |
| |
} |
| |
} |
| |
if (ref($domconfig{'requestauthor'}) eq 'HASH') { |
| |
$domdefaults{'requestauthor'} = $domconfig{'requestauthor'}; |
| |
} |
| |
if (ref($domconfig{'inststatus'}) eq 'HASH') { |
| |
foreach my $item ('inststatustypes','inststatusorder','inststatusguest') { |
| |
$domdefaults{$item} = $domconfig{'inststatus'}{$item}; |
| |
} |
| |
} |
| |
if (ref($domconfig{'coursedefaults'}) eq 'HASH') { |
| |
$domdefaults{'canuse_pdfforms'} = $domconfig{'coursedefaults'}{'canuse_pdfforms'}; |
| |
$domdefaults{'usejsme'} = $domconfig{'coursedefaults'}{'usejsme'}; |
| |
$domdefaults{'uselcmath'} = $domconfig{'coursedefaults'}{'uselcmath'}; |
| |
if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') { |
| |
$domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'}; |
| |
} |
| |
foreach my $type (@coursetypes) { |
| |
if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') { |
| |
unless ($type eq 'community') { |
| |
$domdefaults{$type.'credits'} = $domconfig{'coursedefaults'}{'coursecredits'}{$type}; |
| |
} |
| |
} |
| |
if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') { |
| |
$domdefaults{$type.'quota'} = $domconfig{'coursedefaults'}{'uploadquota'}{$type}; |
| |
} |
| |
if ($domdefaults{'postsubmit'} eq 'on') { |
| |
if (ref($domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}) eq 'HASH') { |
| |
$domdefaults{$type.'postsubtimeout'} = |
| |
$domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}{$type}; |
| |
} |
| |
} |
| |
} |
| |
if (ref($domconfig{'coursedefaults'}{'canclone'}) eq 'HASH') { |
| |
if (ref($domconfig{'coursedefaults'}{'canclone'}{'instcode'}) eq 'ARRAY') { |
| |
my @clonecodes = @{$domconfig{'coursedefaults'}{'canclone'}{'instcode'}}; |
| |
if (@clonecodes) { |
| |
$domdefaults{'canclone'} = join('+',@clonecodes); |
| |
} |
| |
} |
| |
} elsif ($domconfig{'coursedefaults'}{'canclone'}) { |
| |
$domdefaults{'canclone'}=$domconfig{'coursedefaults'}{'canclone'}; |
| |
} |
| |
if ($domconfig{'coursedefaults'}{'texengine'}) { |
| |
$domdefaults{'texengine'} = $domconfig{'coursedefaults'}{'texengine'}; |
| |
} |
| |
} |
| |
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'}; |
| |
} |
| |
if (ref($domconfig{'usersessions'}{'offloadnow'}) eq 'HASH') { |
| |
$domdefaults{'offloadnow'} = $domconfig{'usersessions'}{'offloadnow'}; |
| |
} |
| |
if (ref($domconfig{'usersessions'}{'offloadoth'}) eq 'HASH') { |
| |
$domdefaults{'offloadoth'} = $domconfig{'usersessions'}{'offloadoth'}; |
| |
} |
| |
} |
| |
if (ref($domconfig{'selfenrollment'}) eq 'HASH') { |
| |
if (ref($domconfig{'selfenrollment'}{'admin'}) eq 'HASH') { |
| |
my @settings = ('types','registered','enroll_dates','access_dates','section', |
| |
'approval','limit'); |
| |
foreach my $type (@coursetypes) { |
| |
if (ref($domconfig{'selfenrollment'}{'admin'}{$type}) eq 'HASH') { |
| |
my @mgrdc = (); |
| |
foreach my $item (@settings) { |
| |
if ($domconfig{'selfenrollment'}{'admin'}{$type}{$item} eq '0') { |
| |
push(@mgrdc,$item); |
| |
} |
| |
} |
| |
if (@mgrdc) { |
| |
$domdefaults{$type.'selfenrolladmdc'} = join(',',@mgrdc); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if (ref($domconfig{'selfenrollment'}{'default'}) eq 'HASH') { |
| |
foreach my $type (@coursetypes) { |
| |
if (ref($domconfig{'selfenrollment'}{'default'}{$type}) eq 'HASH') { |
| |
foreach my $item (keys(%{$domconfig{'selfenrollment'}{'default'}{$type}})) { |
| |
$domdefaults{$type.'selfenroll'.$item} = $domconfig{'selfenrollment'}{'default'}{$type}{$item}; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if (ref($domconfig{'coursecategories'}) eq 'HASH') { |
| |
$domdefaults{'catauth'} = 'std'; |
| |
$domdefaults{'catunauth'} = 'std'; |
| |
if ($domconfig{'coursecategories'}{'auth'}) { |
| |
$domdefaults{'catauth'} = $domconfig{'coursecategories'}{'auth'}; |
| |
} |
| |
if ($domconfig{'coursecategories'}{'unauth'}) { |
| |
$domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'}; |
| |
} |
| |
} |
| |
if (ref($domconfig{'ssl'}) eq 'HASH') { |
| |
if (ref($domconfig{'ssl'}{'replication'}) eq 'HASH') { |
| |
$domdefaults{'replication'} = $domconfig{'ssl'}{'replication'}; |
| |
} |
| |
if (ref($domconfig{'ssl'}{'connto'}) eq 'HASH') { |
| |
$domdefaults{'connect'} = $domconfig{'ssl'}{'connto'}; |
| |
} |
| |
if (ref($domconfig{'ssl'}{'connfrom'}) eq 'HASH') { |
| |
$domdefaults{'connect'} = $domconfig{'ssl'}{'connfrom'}; |
| |
} |
| |
} |
| |
if (ref($domconfig{'trust'}) eq 'HASH') { |
| |
my @prefixes = qw(content shared enroll othcoau coaurem domroles catalog reqcrs msg); |
| |
foreach my $prefix (@prefixes) { |
| |
if (ref($domconfig{'trust'}{$prefix}) eq 'HASH') { |
| |
$domdefaults{'trust'.$prefix} = $domconfig{'trust'}{$prefix}; |
| |
} |
| |
} |
| |
} |
| |
if (ref($domconfig{'autoenroll'}) eq 'HASH') { |
| |
$domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'}; |
| |
} |
| |
if (ref($domconfig{'helpsettings'}) eq 'HASH') { |
| |
$domdefaults{'submitbugs'} = $domconfig{'helpsettings'}{'submitbugs'}; |
| |
if (ref($domconfig{'helpsettings'}{'adhoc'}) eq 'HASH') { |
| |
$domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'}; |
| |
} |
| |
} |
| |
if (ref($domconfig{'wafproxy'}) eq 'HASH') { |
| |
foreach my $item ('ipheader','trusted','vpnint','vpnext','sslopt') { |
| |
if ($domconfig{'wafproxy'}{$item}) { |
| |
$domdefaults{'waf_'.$item} = $domconfig{'wafproxy'}{$item}; |
| |
} |
| |
} |
| |
} |
| |
&do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime); |
| |
return %domdefaults; |
| |
} |
| |
|
| |
sub get_dom_cats { |
| |
my ($dom) = @_; |
| |
return unless (&domain($dom)); |
| |
my ($cats,$cached)=&is_cached_new('cats',$dom); |
| |
unless (defined($cached)) { |
| |
my %domconfig = &get_dom('configuration',['coursecategories'],$dom); |
| |
if (ref($domconfig{'coursecategories'}) eq 'HASH') { |
| |
if (ref($domconfig{'coursecategories'}{'cats'}) eq 'HASH') { |
| |
%{$cats} = %{$domconfig{'coursecategories'}{'cats'}}; |
| |
} else { |
| |
$cats = {}; |
| |
} |
| |
} else { |
| |
$cats = {}; |
| |
} |
| |
&Apache::lonnet::do_cache_new('cats',$dom,$cats,3600); |
| |
} |
| |
return $cats; |
| |
} |
| |
|
| |
sub get_dom_instcats { |
| |
my ($dom) = @_; |
| |
return unless (&domain($dom)); |
| |
my ($instcats,$cached)=&is_cached_new('instcats',$dom); |
| |
unless (defined($cached)) { |
| |
my (%coursecodes,%codes,@codetitles,%cat_titles,%cat_order); |
| |
my $totcodes = &retrieve_instcodes(\%coursecodes,$dom); |
| |
if ($totcodes > 0) { |
| |
my $caller = 'global'; |
| |
if (&auto_instcode_format($caller,$dom,\%coursecodes,\%codes, |
| |
\@codetitles,\%cat_titles,\%cat_order) eq 'ok') { |
| |
$instcats = { |
| |
codes => \%codes, |
| |
codetitles => \@codetitles, |
| |
cat_titles => \%cat_titles, |
| |
cat_order => \%cat_order, |
| |
}; |
| |
&do_cache_new('instcats',$dom,$instcats,3600); |
| |
} |
| |
} |
| |
} |
| |
return $instcats; |
| |
} |
| |
|
| |
sub retrieve_instcodes { |
| |
my ($coursecodes,$dom) = @_; |
| |
my $totcodes; |
| |
my %courses = &courseiddump($dom,'.',1,'.','.','.',undef,undef,'Course'); |
| |
foreach my $course (keys(%courses)) { |
| |
if (ref($courses{$course}) eq 'HASH') { |
| |
if ($courses{$course}{'inst_code'} ne '') { |
| |
$$coursecodes{$course} = $courses{$course}{'inst_code'}; |
| |
$totcodes ++; |
| |
} |
| |
} |
| |
} |
| |
return $totcodes; |
| |
} |
| |
|
| |
sub course_portal_url { |
| |
my ($cnum,$cdom,$r) = @_; |
| |
my $chome = &homeserver($cnum,$cdom); |
| |
my $hostname = &hostname($chome); |
| |
my $protocol = $protocol{$chome}; |
| |
$protocol = 'http' if ($protocol ne 'https'); |
| |
my %domdefaults = &get_domain_defaults($cdom); |
| |
my $firsturl; |
| |
if ($domdefaults{'portal_def'}) { |
| |
$firsturl = $domdefaults{'portal_def'}; |
| } else { |
} else { |
| &logthis("put_dom failed - no primary domain server for $udom"); |
my $alias = &Apache::lonnet::use_proxy_alias($r,$chome); |
| |
$hostname = $alias if ($alias ne ''); |
| |
$firsturl = $protocol.'://'.$hostname; |
| |
} |
| |
return $firsturl; |
| |
} |
| |
|
| |
# --------------------------------------------- Get domain config for passwords |
| |
|
| |
sub get_passwdconf { |
| |
my ($dom) = @_; |
| |
my (%passwdconf,$gotconf,$lookup); |
| |
my ($result,$cached)=&is_cached_new('passwdconf',$dom); |
| |
if (defined($cached)) { |
| |
if (ref($result) eq 'HASH') { |
| |
%passwdconf = %{$result}; |
| |
$gotconf = 1; |
| |
} |
| |
} |
| |
unless ($gotconf) { |
| |
my %domconfig = &get_dom('configuration',['passwords'],$dom); |
| |
if (ref($domconfig{'passwords'}) eq 'HASH') { |
| |
%passwdconf = %{$domconfig{'passwords'}}; |
| |
} |
| |
my $cachetime = 24*60*60; |
| |
&do_cache_new('passwdconf',$dom,\%passwdconf,$cachetime); |
| } |
} |
| |
return %passwdconf; |
| } |
} |
| |
|
| # --------------------------------------------------- Assign a key to a student |
# --------------------------------------------------- Assign a key to a student |
|
Line 798 sub assign_access_key {
|
Line 2925 sub assign_access_key {
|
| # key now belongs to user |
# key now belongs to user |
| my $envkey='key.'.$cdom.'_'.$cnum; |
my $envkey='key.'.$cdom.'_'.$cnum; |
| if (&put('environment',{$envkey => $ckey}) eq 'ok') { |
if (&put('environment',{$envkey => $ckey}) eq 'ok') { |
| &appenv('environment.'.$envkey => $ckey); |
&appenv({'environment.'.$envkey => $ckey}); |
| return 'ok'; |
return 'ok'; |
| } else { |
} else { |
| return |
return |
|
Line 990 my %remembered;
|
Line 3117 my %remembered;
|
| my %accessed; |
my %accessed; |
| my $kicks=0; |
my $kicks=0; |
| my $hits=0; |
my $hits=0; |
| |
sub make_key { |
| |
my ($name,$id) = @_; |
| |
if (length($id) > 65 |
| |
&& length(&escape($id)) > 200) { |
| |
$id=length($id).':'.&Digest::MD5::md5_hex($id); |
| |
} |
| |
return &escape($name.':'.$id); |
| |
} |
| |
|
| sub devalidate_cache_new { |
sub devalidate_cache_new { |
| my ($name,$id,$debug) = @_; |
my ($name,$id,$debug) = @_; |
| if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); } |
if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); } |
| $id=&escape($name.':'.$id); |
my $remembered_id=$name.':'.$id; |
| |
$id=&make_key($name,$id); |
| $memcache->delete($id); |
$memcache->delete($id); |
| delete($remembered{$id}); |
delete($remembered{$remembered_id}); |
| delete($accessed{$id}); |
delete($accessed{$remembered_id}); |
| } |
} |
| |
|
| sub is_cached_new { |
sub is_cached_new { |
| my ($name,$id,$debug) = @_; |
my ($name,$id,$debug) = @_; |
| $id=&escape($name.':'.$id); |
my $remembered_id=$name.':'.$id; # this is to avoid make_key (which is slow) whenever possible |
| if (exists($remembered{$id})) { |
if (exists($remembered{$remembered_id})) { |
| if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); } |
if ($debug) { &Apache::lonnet::logthis("Early return $remembered_id of $remembered{$remembered_id} "); } |
| $accessed{$id}=[&gettimeofday()]; |
$accessed{$remembered_id}=[&gettimeofday()]; |
| $hits++; |
$hits++; |
| return ($remembered{$id},1); |
return ($remembered{$remembered_id},1); |
| } |
} |
| |
$id=&make_key($name,$id); |
| my $value = $memcache->get($id); |
my $value = $memcache->get($id); |
| if (!(defined($value))) { |
if (!(defined($value))) { |
| if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); } |
if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); } |
|
Line 1017 sub is_cached_new {
|
Line 3155 sub is_cached_new {
|
| if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); } |
if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); } |
| $value=undef; |
$value=undef; |
| } |
} |
| &make_room($id,$value,$debug); |
&make_room($remembered_id,$value,$debug); |
| if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); } |
if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); } |
| return ($value,1); |
return ($value,1); |
| } |
} |
| |
|
| sub do_cache_new { |
sub do_cache_new { |
| my ($name,$id,$value,$time,$debug) = @_; |
my ($name,$id,$value,$time,$debug) = @_; |
| $id=&escape($name.':'.$id); |
my $remembered_id=$name.':'.$id; |
| |
$id=&make_key($name,$id); |
| my $setvalue=$value; |
my $setvalue=$value; |
| if (!defined($setvalue)) { |
if (!defined($setvalue)) { |
| $setvalue='__undef__'; |
$setvalue='__undef__'; |
|
Line 1033 sub do_cache_new {
|
Line 3172 sub do_cache_new {
|
| $time=600; |
$time=600; |
| } |
} |
| if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); } |
if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); } |
| $memcache->set($id,$setvalue,$time); |
my $result = $memcache->set($id,$setvalue,$time); |
| |
if (! $result) { |
| |
&logthis("caching of id -> $id failed"); |
| |
$memcache->disconnect_all(); |
| |
} |
| # need to make a copy of $value |
# need to make a copy of $value |
| #&make_room($id,$value,$debug); |
&make_room($remembered_id,$value,$debug); |
| return $value; |
return $value; |
| } |
} |
| |
|
| sub make_room { |
sub make_room { |
| my ($id,$value,$debug)=@_; |
my ($remembered_id,$value,$debug)=@_; |
| $remembered{$id}=$value; |
|
| |
$remembered{$remembered_id}= (ref($value)) ? &Storable::dclone($value) |
| |
: $value; |
| if ($to_remember<0) { return; } |
if ($to_remember<0) { return; } |
| $accessed{$id}=[&gettimeofday()]; |
$accessed{$remembered_id}=[&gettimeofday()]; |
| if (scalar(keys(%remembered)) <= $to_remember) { return; } |
if (scalar(keys(%remembered)) <= $to_remember) { return; } |
| my $to_kick; |
my $to_kick; |
| my $max_time=0; |
my $max_time=0; |
|
Line 1070 sub purge_remembered {
|
Line 3215 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 1147 sub chatsend {
|
Line 3302 sub chatsend {
|
| |
|
| sub getversion { |
sub getversion { |
| my $fname=&clutter(shift); |
my $fname=&clutter(shift); |
| unless ($fname=~/^\/res\//) { return -1; } |
unless ($fname=~m{^(/adm/wrapper|)/res/}) { return -1; } |
| return ¤tversion(&filelocation('',$fname)); |
return ¤tversion(&filelocation('',$fname)); |
| } |
} |
| |
|
| sub currentversion { |
sub currentversion { |
| my $fname=shift; |
my $fname=shift; |
| my ($result,$cached)=&is_cached_new('resversion',$fname); |
|
| if (defined($cached)) { return $result; } |
|
| my $author=$fname; |
my $author=$fname; |
| $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; |
$author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; |
| my ($udom,$uname)=split(/\//,$author); |
my ($udom,$uname)=split(/\//,$author); |
| my $home=homeserver($uname,$udom); |
my $home=&homeserver($uname,$udom); |
| if ($home eq 'no_host') { |
if ($home eq 'no_host') { |
| return -1; |
return -1; |
| } |
} |
| my $answer=reply("currentversion:$fname",$home); |
my $answer=&reply("currentversion:$fname",$home); |
| if (($answer eq 'con_lost') || ($answer eq 'rejected')) { |
if (($answer eq 'con_lost') || ($answer eq 'rejected')) { |
| return -1; |
return -1; |
| } |
} |
| return &do_cache_new('resversion',$fname,$answer,600); |
return $answer; |
| |
} |
| |
|
| |
# |
| |
# Return special version number of resource if set by override, empty otherwise |
| |
# |
| |
sub usedversion { |
| |
my $fname=shift; |
| |
unless ($fname) { $fname=$env{'request.uri'}; } |
| |
my ($urlversion)=($fname=~/\.(\d+)\.\w+$/); |
| |
if ($urlversion) { return $urlversion; } |
| |
return ''; |
| } |
} |
| |
|
| # ----------------------------- Subscribe to a resource, return URL if possible |
# ----------------------------- Subscribe to a resource, return URL if possible |
|
Line 1194 sub subscribe {
|
Line 3358 sub subscribe {
|
| sub repcopy { |
sub repcopy { |
| my $filename=shift; |
my $filename=shift; |
| $filename=~s/\/+/\//g; |
$filename=~s/\/+/\//g; |
| if ($filename=~m|^/home/httpd/html/adm/|) { return 'ok'; } |
my $londocroot = $perlvar{'lonDocRoot'}; |
| if ($filename=~m|^/home/httpd/html/lonUsers/|) { return 'ok'; } |
if ($filename=~m{^\Q$londocroot/adm/\E}) { return 'ok'; } |
| if ($filename=~m|^/home/httpd/html/userfiles/| or |
if ($filename=~m{^\Q/home/httpd/lonUsers/\E}) { return 'ok'; } |
| $filename=~m -^/*(uploaded|editupload)/-) { |
if ($filename=~m{^\Q$londocroot/userfiles/\E} or |
| |
$filename=~m{^/*(uploaded|editupload)/}) { |
| return &repcopy_userfile($filename); |
return &repcopy_userfile($filename); |
| } |
} |
| $filename=~s/[\n\r]//g; |
$filename=~s/[\n\r]//g; |
|
Line 1224 sub repcopy {
|
Line 3389 sub repcopy {
|
| unless ($home eq $perlvar{'lonHostID'}) { |
unless ($home eq $perlvar{'lonHostID'}) { |
| my @parts=split(/\//,$filename); |
my @parts=split(/\//,$filename); |
| my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; |
my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; |
| if ($path ne "$perlvar{'lonDocRoot'}/res") { |
if ($path ne "$londocroot/res") { |
| &logthis("Malconfiguration for replication: $filename"); |
&logthis("Malconfiguration for replication: $filename"); |
| return 'bad_request'; |
return 'bad_request'; |
| } |
} |
|
Line 1235 sub repcopy {
|
Line 3400 sub repcopy {
|
| mkdir($path,0777); |
mkdir($path,0777); |
| } |
} |
| } |
} |
| my $ua=new LWP::UserAgent; |
|
| my $request=new HTTP::Request('GET',"$remoteurl"); |
my $request=new HTTP::Request('GET',"$remoteurl"); |
| my $response=$ua->request($request,$transname); |
my $response; |
| |
if ($remoteurl =~ m{/raw/}) { |
| |
$response=&LONCAPA::LWPReq::makerequest($home,$request,$transname,\%perlvar,'',0,1); |
| |
} else { |
| |
$response=&LONCAPA::LWPReq::makerequest($home,$request,$transname,\%perlvar,'',1); |
| |
} |
| if ($response->is_error()) { |
if ($response->is_error()) { |
| unlink($transname); |
unlink($transname); |
| my $message=$response->status_line; |
my $message=$response->status_line; |
|
Line 1247 sub repcopy {
|
Line 3416 sub repcopy {
|
| } else { |
} else { |
| if ($remoteurl!~/\.meta$/) { |
if ($remoteurl!~/\.meta$/) { |
| my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta'); |
my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta'); |
| my $mresponse=$ua->request($mrequest,$filename.'.meta'); |
my $mresponse; |
| |
if ($remoteurl =~ m{/raw/}) { |
| |
$mresponse = &LONCAPA::LWPReq::makerequest($home,$mrequest,$filename.'.meta',\%perlvar,'',0,1); |
| |
} else { |
| |
$mresponse = &LONCAPA::LWPReq::makerequest($home,$mrequest,$filename.'.meta',\%perlvar,'',1); |
| |
} |
| if ($mresponse->is_error()) { |
if ($mresponse->is_error()) { |
| unlink($filename.'.meta'); |
unlink($filename.'.meta'); |
| &logthis( |
&logthis( |
|
Line 1261 sub repcopy {
|
Line 3435 sub repcopy {
|
| } |
} |
| } |
} |
| |
|
| |
# ------------------------------------------------- Unsubscribe from a resource |
| |
|
| |
sub unsubscribe { |
| |
my ($fname) = @_; |
| |
my $answer; |
| |
if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return $answer; } |
| |
$fname=~s/[\n\r]//g; |
| |
my $author=$fname; |
| |
$author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; |
| |
my ($udom,$uname)=split(/\//,$author); |
| |
my $home=homeserver($uname,$udom); |
| |
if ($home eq 'no_host') { |
| |
$answer = 'no_host'; |
| |
} elsif (grep { $_ eq $home } ¤t_machine_ids()) { |
| |
$answer = 'home'; |
| |
} else { |
| |
my $defdom = $perlvar{'lonDefDomain'}; |
| |
if (&will_trust('content',$defdom,$udom)) { |
| |
$answer = reply("unsub:$fname",$home); |
| |
} else { |
| |
$answer = 'untrusted'; |
| |
} |
| |
} |
| |
return $answer; |
| |
} |
| |
|
| # ------------------------------------------------ Get server side include body |
# ------------------------------------------------ Get server side include body |
| sub ssi_body { |
sub ssi_body { |
| my ($filelink,%form)=@_; |
my ($filelink,%form)=@_; |
| if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) { |
if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) { |
| $form{'LONCAPA_INTERNAL_no_discussion'}='true'; |
$form{'LONCAPA_INTERNAL_no_discussion'}='true'; |
| } |
} |
| my $output=($filelink=~/^http\:/?&externalssi($filelink): |
my $output=''; |
| &ssi($filelink,%form)); |
my $response; |
| |
if ($filelink=~/^https?\:/) { |
| |
($output,$response)=&externalssi($filelink); |
| |
} else { |
| |
$filelink .= $filelink=~/\?/ ? '&' : '?'; |
| |
$filelink .= 'inhibitmenu=yes'; |
| |
($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; |
| $output=~s/^.*?\<body[^\>]*\>//si; |
$output=~s/^.*?\<body[^\>]*\>//si; |
| $output=~s/(.*)\<\/body\s*\>.*?$/$1/si; |
$output=~s/\<\/body\s*\>.*?$//si; |
| return $output; |
if (wantarray) { |
| |
return ($output, $response); |
| |
} else { |
| |
return $output; |
| |
} |
| } |
} |
| |
|
| # --------------------------------------------------------- Server Side Include |
# --------------------------------------------------------- Server Side Include |
| |
|
| sub absolute_url { |
sub absolute_url { |
| my ($host_name) = @_; |
my ($host_name,$unalias,$keep_proto) = @_; |
| my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://'); |
my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://'); |
| if ($host_name eq '') { |
if ($host_name eq '') { |
| $host_name = $ENV{'SERVER_NAME'}; |
$host_name = $ENV{'SERVER_NAME'}; |
| } |
} |
| |
if ($unalias) { |
| |
my $alias = &get_proxy_alias(); |
| |
if ($alias eq $host_name) { |
| |
my $lonhost = $perlvar{'lonHostID'}; |
| |
my $hostname = &hostname($lonhost); |
| |
my $lcproto; |
| |
if (($keep_proto) || ($hostname eq '')) { |
| |
$lcproto = $protocol; |
| |
} else { |
| |
$lcproto = $protocol{$lonhost}; |
| |
$lcproto = 'http' if ($lcproto ne 'https'); |
| |
$lcproto .= '://'; |
| |
} |
| |
unless ($hostname eq '') { |
| |
return $lcproto.$hostname; |
| |
} |
| |
} |
| |
} |
| return $protocol.$host_name; |
return $protocol.$host_name; |
| } |
} |
| |
|
| |
# |
| |
# Server side include. |
| |
# Parameters: |
| |
# fn Possibly encrypted resource name/id. |
| |
# form Hash that describes how the rendering should be done |
| |
# and other things. |
| |
# Returns: |
| |
# Scalar context: The content of the response. |
| |
# Array context: 2 element list of the content and the full response object. |
| |
# |
| sub ssi { |
sub ssi { |
| |
|
| my ($fn,%form)=@_; |
my ($fn,%form)=@_; |
| |
my ($host,$request,$response); |
| my $ua=new LWP::UserAgent; |
$host = &absolute_url('',1); |
| |
|
| my $request; |
|
| |
|
| $form{'no_update_last_known'}=1; |
$form{'no_update_last_known'}=1; |
| |
&Apache::lonenc::check_encrypt(\$fn); |
| if (%form) { |
if (%form) { |
| $request=new HTTP::Request('POST',&absolute_url().$fn); |
$request=new HTTP::Request('POST',$host.$fn); |
| $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form)); |
$request->content(join('&',map { |
| |
my $name = escape($_); |
| |
"$name=" . ( ref($form{$_}) eq 'ARRAY' |
| |
? join("&$name=", map {escape($_) } @{$form{$_}}) |
| |
: &escape($form{$_}) ); |
| |
} keys(%form))); |
| } else { |
} else { |
| $request=new HTTP::Request('GET',&absolute_url().$fn); |
$request=new HTTP::Request('GET',$host.$fn); |
| } |
} |
| |
|
| $request->header(Cookie => $ENV{'HTTP_COOKIE'}); |
$request->header(Cookie => $ENV{'HTTP_COOKIE'}); |
| my $response=$ua->request($request); |
my $lonhost = $perlvar{'lonHostID'}; |
| |
my $islocal; |
| |
if (($env{'request.course.id'}) && |
| |
($form{'grade_courseid'} eq $env{'request.course.id'}) && |
| |
($form{'grade_username'} ne '') && ($form{'grade_domain'} ne '') && |
| |
($form{'grade_symb'} ne '') && |
| |
(&Apache::lonnet::allowed('mgr',$env{'request.course.id'}. |
| |
($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:'')))) { |
| |
$islocal = 1; |
| |
} |
| |
$response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar, |
| |
'','','',$islocal); |
| |
|
| return $response->content; |
if (wantarray) { |
| |
return ($response->content, $response); |
| |
} else { |
| |
return $response->content; |
| |
} |
| } |
} |
| |
|
| sub externalssi { |
sub externalssi { |
| my ($url)=@_; |
my ($url)=@_; |
| my $ua=new LWP::UserAgent; |
|
| my $request=new HTTP::Request('GET',$url); |
my $request=new HTTP::Request('GET',$url); |
| my $response=$ua->request($request); |
my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar); |
| return $response->content; |
if (wantarray) { |
| |
return ($response->content, $response); |
| |
} else { |
| |
return $response->content; |
| |
} |
| |
} |
| |
|
| |
|
| |
# If the local copy of a replicated resource is outdated, trigger a |
| |
# connection from the homeserver to flush the delayed queue. If no update |
| |
# happens, remove local copies of outdated resource (and corresponding |
| |
# metadata file). |
| |
|
| |
sub remove_stale_resfile { |
| |
my ($url) = @_; |
| |
my $removed; |
| |
if ($url=~m{^/res/($match_domain)/($match_username)/}) { |
| |
my $audom = $1; |
| |
my $auname = $2; |
| |
unless (($url =~ /\.\d+\.\w+$/) || ($url =~ m{^/res/lib/templates/})) { |
| |
my $homeserver = &homeserver($auname,$audom); |
| |
unless (($homeserver eq 'no_host') || |
| |
(grep { $_ eq $homeserver } ¤t_machine_ids())) { |
| |
my $fname = &filelocation('',$url); |
| |
if (-e $fname) { |
| |
my $hostname = &hostname($homeserver); |
| |
if ($hostname) { |
| |
my $protocol = $protocol{$homeserver}; |
| |
$protocol = 'http' if ($protocol ne 'https'); |
| |
my $uri = &declutter($url); |
| |
my $request=new HTTP::Request('HEAD',$protocol.'://'.$hostname.'/raw/'.$uri); |
| |
my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,5,0,1); |
| |
if ($response->is_success()) { |
| |
my $remmodtime = &HTTP::Date::str2time( $response->header('Last-modified') ); |
| |
my $locmodtime = (stat($fname))[9]; |
| |
if ($locmodtime < $remmodtime) { |
| |
my $stale; |
| |
my $answer = &reply('pong',$homeserver); |
| |
if ($answer eq $homeserver.':'.$perlvar{'lonHostID'}) { |
| |
sleep(0.2); |
| |
$locmodtime = (stat($fname))[9]; |
| |
if ($locmodtime < $remmodtime) { |
| |
my $posstransfer = $fname.'.in.transfer'; |
| |
if ((-e $posstransfer) && ($remmodtime < (stat($posstransfer))[9])) { |
| |
$removed = 1; |
| |
} else { |
| |
$stale = 1; |
| |
} |
| |
} else { |
| |
$removed = 1; |
| |
} |
| |
} else { |
| |
$stale = 1; |
| |
} |
| |
if ($stale) { |
| |
if (unlink($fname)) { |
| |
if ($uri!~/\.meta$/) { |
| |
if (-e $fname.'.meta') { |
| |
unlink($fname.'.meta'); |
| |
} |
| |
} |
| |
my $unsubresult = &unsubscribe($fname); |
| |
unless ($unsubresult eq 'ok') { |
| |
&logthis("no unsub of $fname from $homeserver, reason: $unsubresult"); |
| |
} |
| |
$removed = 1; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return $removed; |
| } |
} |
| |
|
| # -------------------------------- Allow a /uploaded/ URI to be vouched for |
# -------------------------------- Allow a /uploaded/ URI to be vouched for |
|
Line 1327 sub allowuploaded {
|
Line 3658 sub allowuploaded {
|
| my %httpref=(); |
my %httpref=(); |
| my $httpurl=&hreflocation('',$url); |
my $httpurl=&hreflocation('',$url); |
| $httpref{'httpref.'.$httpurl}=$srcurl; |
$httpref{'httpref.'.$httpurl}=$srcurl; |
| &Apache::lonnet::appenv(%httpref); |
&Apache::lonnet::appenv(\%httpref); |
| |
} |
| |
|
| |
# |
| |
# Determine if the current user should be able to edit a particular resource, |
| |
# when viewing in course context. |
| |
# (a) When viewing resource used to determine if "Edit" item is included in |
| |
# Functions. |
| |
# (b) When displaying folder contents in course editor, used to determine if |
| |
# "Edit" link will be displayed alongside resource. |
| |
# |
| |
# input: six args -- filename (decluttered), course number, course domain, |
| |
# url, symb (if registered) and group (if this is a group |
| |
# item -- e.g., bulletin board, group page etc.). |
| |
# output: array of five scalars -- |
| |
# $cfile -- url for file editing if editable on current server |
| |
# $home -- homeserver of resource (i.e., for author if published, |
| |
# or course if uploaded.). |
| |
# $switchserver -- 1 if server switch will be needed. |
| |
# $forceedit -- 1 if icon/link should be to go to edit mode |
| |
# $forceview -- 1 if icon/link should be to go to view mode |
| |
# |
| |
|
| |
sub can_edit_resource { |
| |
my ($file,$cnum,$cdom,$resurl,$symb,$group) = @_; |
| |
my ($cfile,$home,$switchserver,$forceedit,$forceview,$uploaded,$incourse); |
| |
# |
| |
# For aboutme pages user can only edit his/her own. |
| |
# |
| |
if ($resurl =~ m{^/?adm/($match_domain)/($match_username)/aboutme$}) { |
| |
my ($sdom,$sname) = ($1,$2); |
| |
if (($sdom eq $env{'user.domain'}) && ($sname eq $env{'user.name'})) { |
| |
$home = $env{'user.home'}; |
| |
$cfile = $resurl; |
| |
if ($env{'form.forceedit'}) { |
| |
$forceview = 1; |
| |
} else { |
| |
$forceedit = 1; |
| |
} |
| |
return ($cfile,$home,$switchserver,$forceedit,$forceview); |
| |
} else { |
| |
return; |
| |
} |
| |
} |
| |
|
| |
if ($env{'request.course.id'}) { |
| |
my $crsedit = &Apache::lonnet::allowed('mdc',$env{'request.course.id'}); |
| |
if ($group ne '') { |
| |
# if this is a group homepage or group bulletin board, check group privs |
| |
my $allowed = 0; |
| |
if ($resurl =~ m{^/?adm/$cdom/$cnum/$group/smppg$}) { |
| |
if ((&allowed('mdg',$env{'request.course.id'}. |
| |
($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:''))) || |
| |
(&allowed('mgh',$env{'request.course.id'}.'/'.$group)) || $crsedit) { |
| |
$allowed = 1; |
| |
} |
| |
} elsif ($resurl =~ m{^/?adm/$cdom/$cnum/\d+/bulletinboard$}) { |
| |
if ((&allowed('mdg',$env{'request.course.id'}.($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:''))) || |
| |
(&allowed('cgb',$env{'request.course.id'}.'/'.$group)) || $crsedit) { |
| |
$allowed = 1; |
| |
} |
| |
} |
| |
if ($allowed) { |
| |
$home=&homeserver($cnum,$cdom); |
| |
if ($env{'form.forceedit'}) { |
| |
$forceview = 1; |
| |
} else { |
| |
$forceedit = 1; |
| |
} |
| |
$cfile = $resurl; |
| |
} else { |
| |
return; |
| |
} |
| |
} else { |
| |
if ($resurl =~ m{^/?adm/viewclasslist$}) { |
| |
unless (&Apache::lonnet::allowed('opa',$env{'request.course.id'})) { |
| |
return; |
| |
} |
| |
} elsif (!$crsedit) { |
| |
# |
| |
# No edit allowed where CC has switched to student role. |
| |
# |
| |
return; |
| |
} |
| |
} |
| |
} |
| |
|
| |
if ($file ne '') { |
| |
if (($cnum =~ /$match_courseid/) && ($cdom =~ /$match_domain/)) { |
| |
if (&is_course_upload($file,$cnum,$cdom)) { |
| |
$uploaded = 1; |
| |
$incourse = 1; |
| |
if ($file =~/\.(htm|html|css|js|txt)$/) { |
| |
$cfile = &hreflocation('',$file); |
| |
if ($env{'form.forceedit'}) { |
| |
$forceview = 1; |
| |
} else { |
| |
$forceedit = 1; |
| |
} |
| |
} |
| |
} elsif ($resurl =~ m{^/public/$cdom/$cnum/syllabus}) { |
| |
$incourse = 1; |
| |
if ($env{'form.forceedit'}) { |
| |
$forceview = 1; |
| |
} else { |
| |
$forceedit = 1; |
| |
} |
| |
$cfile = $resurl; |
| |
} elsif (($resurl ne '') && (&is_on_map($resurl))) { |
| |
if ($resurl =~ m{^/adm/$match_domain/$match_username/\d+/smppg|bulletinboard$}) { |
| |
$incourse = 1; |
| |
if ($env{'form.forceedit'}) { |
| |
$forceview = 1; |
| |
} else { |
| |
$forceedit = 1; |
| |
} |
| |
$cfile = $resurl; |
| |
} elsif ($resurl eq '/res/lib/templates/simpleproblem.problem') { |
| |
$incourse = 1; |
| |
$cfile = $resurl.'/smpedit'; |
| |
} elsif ($resurl =~ m{^/adm/wrapper/ext/}) { |
| |
$incourse = 1; |
| |
if ($env{'form.forceedit'}) { |
| |
$forceview = 1; |
| |
} else { |
| |
$forceedit = 1; |
| |
} |
| |
$cfile = $resurl; |
| |
} elsif (($resurl =~ m{^/ext/}) && ($symb ne '')) { |
| |
my ($map,$id,$res) = &decode_symb($symb); |
| |
if ($map =~ /\.page$/) { |
| |
$incourse = 1; |
| |
if ($env{'form.forceedit'}) { |
| |
$forceview = 1; |
| |
$cfile = $map; |
| |
} else { |
| |
$forceedit = 1; |
| |
$cfile = '/adm/wrapper'.$resurl; |
| |
} |
| |
} |
| |
} elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) { |
| |
$incourse = 1; |
| |
if ($env{'form.forceedit'}) { |
| |
$forceview = 1; |
| |
} else { |
| |
$forceedit = 1; |
| |
} |
| |
$cfile = $resurl; |
| |
} elsif ($resurl =~ m{^/?adm/viewclasslist$}) { |
| |
$incourse = 1; |
| |
if ($env{'form.forceedit'}) { |
| |
$forceview = 1; |
| |
} else { |
| |
$forceedit = 1; |
| |
} |
| |
$cfile = ($resurl =~ m{^/} ? $resurl : "/$resurl"); |
| |
} |
| |
} elsif ($resurl eq '/res/lib/templates/simpleproblem.problem/smpedit') { |
| |
my $template = '/res/lib/templates/simpleproblem.problem'; |
| |
if (&is_on_map($template)) { |
| |
$incourse = 1; |
| |
$forceview = 1; |
| |
$cfile = $template; |
| |
} |
| |
} elsif (($resurl =~ m{^/adm/wrapper/ext/}) && ($env{'form.folderpath'} =~ /^supplemental/)) { |
| |
$incourse = 1; |
| |
if ($env{'form.forceedit'}) { |
| |
$forceview = 1; |
| |
} else { |
| |
$forceedit = 1; |
| |
} |
| |
$cfile = $resurl; |
| |
} elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($env{'form.folderpath'} =~ /^supplemental/)) { |
| |
$incourse = 1; |
| |
if ($env{'form.forceedit'}) { |
| |
$forceview = 1; |
| |
} else { |
| |
$forceedit = 1; |
| |
} |
| |
$cfile = $resurl; |
| |
} elsif (($resurl eq '/adm/extresedit') && ($symb || $env{'form.folderpath'})) { |
| |
$incourse = 1; |
| |
$forceview = 1; |
| |
if ($symb) { |
| |
my ($map,$id,$res)=&decode_symb($symb); |
| |
$env{'request.symb'} = $symb; |
| |
$cfile = &clutter($res); |
| |
} else { |
| |
$cfile = $env{'form.suppurl'}; |
| |
my $escfile = &unescape($cfile); |
| |
if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) { |
| |
$cfile = '/adm/wrapper'.$escfile; |
| |
} else { |
| |
$escfile =~ s{^http://}{}; |
| |
$cfile = &escape("/adm/wrapper/ext/$escfile"); |
| |
} |
| |
} |
| |
} elsif ($resurl =~ m{^/?adm/viewclasslist$}) { |
| |
if ($env{'form.forceedit'}) { |
| |
$forceview = 1; |
| |
} else { |
| |
$forceedit = 1; |
| |
} |
| |
$cfile = ($resurl =~ m{^/} ? $resurl : "/$resurl"); |
| |
} |
| |
} |
| |
if ($uploaded || $incourse) { |
| |
$home=&homeserver($cnum,$cdom); |
| |
} elsif ($file !~ m{/$}) { |
| |
$file=~s{^(priv/$match_domain/$match_username)}{/$1}; |
| |
$file=~s{^($match_domain/$match_username)}{/priv/$1}; |
| |
# Check that the user has permission to edit this resource |
| |
my $setpriv = 1; |
| |
my ($cfuname,$cfudom)=&constructaccess($file,$setpriv); |
| |
if (defined($cfudom)) { |
| |
$home=&homeserver($cfuname,$cfudom); |
| |
$cfile=$file; |
| |
} |
| |
} |
| |
if (($cfile ne '') && (!$incourse || $uploaded) && |
| |
(($home ne '') && ($home ne 'no_host'))) { |
| |
my @ids=¤t_machine_ids(); |
| |
unless (grep(/^\Q$home\E$/,@ids)) { |
| |
$switchserver=1; |
| |
} |
| |
} |
| |
} |
| |
return ($cfile,$home,$switchserver,$forceedit,$forceview); |
| |
} |
| |
|
| |
sub is_course_upload { |
| |
my ($file,$cnum,$cdom) = @_; |
| |
my $uploadpath = &LONCAPA::propath($cdom,$cnum); |
| |
$uploadpath =~ s{^\/}{}; |
| |
if (($file =~ m{^\Q$uploadpath\E/userfiles/(docs|supplemental)/}) || |
| |
($file =~ m{^userfiles/\Q$cdom\E/\Q$cnum\E/(docs|supplemental)/})) { |
| |
return 1; |
| |
} |
| |
return; |
| |
} |
| |
|
| |
sub in_course { |
| |
my ($udom,$uname,$cdom,$cnum,$type,$hideprivileged) = @_; |
| |
if ($hideprivileged) { |
| |
my $skipuser; |
| |
my %coursehash = &coursedescription($cdom.'_'.$cnum); |
| |
my @possdoms = ($cdom); |
| |
if ($coursehash{'checkforpriv'}) { |
| |
push(@possdoms,split(/,/,$coursehash{'checkforpriv'})); |
| |
} |
| |
if (&privileged($uname,$udom,\@possdoms)) { |
| |
$skipuser = 1; |
| |
if ($coursehash{'nothideprivileged'}) { |
| |
foreach my $item (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { |
| |
my $user; |
| |
if ($item =~ /:/) { |
| |
$user = $item; |
| |
} else { |
| |
$user = join(':',split(/[\@]/,$item)); |
| |
} |
| |
if ($user eq $uname.':'.$udom) { |
| |
undef($skipuser); |
| |
last; |
| |
} |
| |
} |
| |
} |
| |
if ($skipuser) { |
| |
return 0; |
| |
} |
| |
} |
| |
} |
| |
$type ||= 'any'; |
| |
if (!defined($cdom) || !defined($cnum)) { |
| |
my $cid = $env{'request.course.id'}; |
| |
$cdom = $env{'course.'.$cid.'.domain'}; |
| |
$cnum = $env{'course.'.$cid.'.num'}; |
| |
} |
| |
my $typesref; |
| |
if (($type eq 'any') || ($type eq 'all')) { |
| |
$typesref = ['active','previous','future']; |
| |
} elsif ($type eq 'previous' || $type eq 'future') { |
| |
$typesref = [$type]; |
| |
} |
| |
my %roles = &get_my_roles($uname,$udom,'userroles', |
| |
$typesref,undef,[$cdom]); |
| |
my ($tmp) = keys(%roles); |
| |
return 0 if ($tmp =~ /^(con_lost|error|no_such_host)/i); |
| |
my @course_roles = grep(/^\Q$cnum\E:\Q$cdom\E:/, keys(%roles)); |
| |
if (@course_roles > 0) { |
| |
return 1; |
| |
} |
| |
return 0; |
| } |
} |
| |
|
| # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course |
# --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course |
|
Line 1335 sub allowuploaded {
|
Line 3957 sub allowuploaded {
|
| # path to file, source of file, instruction to parse file for objects, |
# path to file, source of file, instruction to parse file for objects, |
| # ref to hash for embedded objects, |
# ref to hash for embedded objects, |
| # ref to hash for codebase of java objects. |
# ref to hash for codebase of java objects. |
| |
# reference to scalar to accommodate mime type determined |
| |
# from File::MMagic if $parser = parse. |
| # |
# |
| # output: url to file (if action was uploaddoc), |
# output: url to file (if action was uploaddoc), |
| # ok if successful, or diagnostic message otherwise (if action was propagate or copy) |
# ok if successful, or diagnostic message otherwise (if action was propagate or copy) |
|
Line 1361 sub allowuploaded {
|
Line 3985 sub allowuploaded {
|
| # |
# |
| |
|
| sub process_coursefile { |
sub process_coursefile { |
| my ($action,$docuname,$docudom,$file,$source,$parser,$allfiles,$codebase)=@_; |
my ($action,$docuname,$docudom,$file,$source,$parser,$allfiles,$codebase, |
| |
$mimetype)=@_; |
| my $fetchresult; |
my $fetchresult; |
| my $home=&homeserver($docuname,$docudom); |
my $home=&homeserver($docuname,$docudom); |
| if ($action eq 'propagate') { |
if ($action eq 'propagate') { |
|
Line 1384 sub process_coursefile {
|
Line 4009 sub process_coursefile {
|
| $home); |
$home); |
| } |
} |
| } elsif ($action eq 'uploaddoc') { |
} elsif ($action eq 'uploaddoc') { |
| open(my $fh,'>'.$filepath.'/'.$fname); |
open(my $fh,'>',$filepath.'/'.$fname); |
| 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 $type = $mm->checktype_filename($filepath.'/'.$fname); |
| &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result); |
if ($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); |
| |
} |
| } |
} |
| |
if (ref($mimetype)) { |
| |
$$mimetype = $type; |
| |
} |
| } |
} |
| $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, |
$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, |
| $home); |
$home); |
|
Line 1435 sub store_edited_file {
|
Line 4067 sub store_edited_file {
|
| ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|); |
($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|); |
| $fpath=$docudom.'/'.$docuname.'/'.$fpath; |
$fpath=$docudom.'/'.$docuname.'/'.$fpath; |
| my $filepath = &build_filepath($fpath); |
my $filepath = &build_filepath($fpath); |
| open(my $fh,'>'.$filepath.'/'.$fname); |
open(my $fh,'>',$filepath.'/'.$fname); |
| print $fh $content; |
print $fh $content; |
| close($fh); |
close($fh); |
| my $home=&homeserver($docuname,$docudom); |
my $home=&homeserver($docuname,$docudom); |
|
Line 1460 sub clean_filename {
|
Line 4092 sub clean_filename {
|
| } |
} |
| # Replace spaces by underscores |
# Replace spaces by underscores |
| $fname=~s/\s+/\_/g; |
$fname=~s/\s+/\_/g; |
| |
# Transliterate non-ascii text to ascii |
| |
my $lang = &Apache::lonlocal::current_language(); |
| |
$fname = &LONCAPA::transliterate::fname_to_ascii($fname,$lang); |
| # Replace all other weird characters by nothing |
# Replace all other weird characters by nothing |
| $fname=~s{[^/\w\.\-]}{}g; |
$fname=~s{[^/\w\.\-]}{}g; |
| # Replace all .\d. sequences with _\d. so they no longer look like version |
# Replace all .\d. sequences with _\d. so they no longer look like version |
| # numbers |
# numbers |
| $fname=~s/\.(\d+)(?=\.)/_$1/g; |
$fname=~s/\.(\d+)(?=\.)/_$1/g; |
| |
# Replace three or more adjacent underscores with one for consistency |
| |
# with loncfile::filename_check() so complete url can be extracted by |
| |
# lonnet::decode_symb() |
| |
$fname=~s/_{3,}/_/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"} |
| # the desired filenam is in $env{"form.$formname.filename"} |
# the desired filename is in $env{"form.$formname.filename"} |
| # $coursedoc - if true up to the current course |
# $context - possible values: coursedoc, existingfile, overwrite, |
| # if false |
# canceloverwrite, scantron or ''. |
| |
# if 'coursedoc': upload to the current course |
| |
# if 'existingfile': write file to tmp/overwrites directory |
| |
# if 'canceloverwrite': delete file written to tmp/overwrites directory |
| |
# $context is passed as argument to &finishuserfileupload |
| # $subdir - directory in userfile to store the file into |
# $subdir - directory in userfile to store the file into |
| # $parser, $allfiles, $codebase - unknown |
# $parser - instruction to parse file for objects ($parser = parse) or |
| # |
# if context is 'scantron', $parser is hashref of csv column mapping |
| |
# (e.g.,{ PaperID => 0, LastName => 1, FirstName => 2, ID => 3, |
| |
# Section => 4, CODE => 5, FirstQuestion => 9 }). |
| |
# $allfiles - reference to hash for embedded objects |
| |
# $codebase - reference to hash for codebase of java objects |
| |
# $desuname - username for permanent storage of uploaded file |
| |
# $dsetudom - domain for permanaent storage of uploaded file |
| |
# $thumbwidth - width (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 |
| |
# $mimetype - reference to scalar to accommodate mime type determined |
| |
# from File::MMagic. |
| |
# |
| # 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,$destudom)=@_; |
my ($formname,$context,$subdir,$parser,$allfiles,$codebase,$destuname, |
| |
$destudom,$thumbwidth,$thumbheight,$resizewidth,$resizeheight,$mimetype)=@_; |
| 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); |
| # See if there is anything left |
# See if there is anything left |
| unless ($fname) { return 'error: no uploaded file'; } |
unless ($fname) { return 'error: no uploaded file'; } |
| chop($env{'form.'.$formname}); |
# If filename now begins with a . prepend unix timestamp _ milliseconds |
| if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { #files uploaded to help request form are handled differently |
if ($fname =~ /^\./) { |
| |
my ($s,$usec) = &gettimeofday(); |
| |
while (length($usec) < 6) { |
| |
$usec = '0'.$usec; |
| |
} |
| |
$fname = $s.'_'.substr($usec,0,3).$fname; |
| |
} |
| |
# Files uploaded to help request form, or uploaded to "create course" page are handled differently |
| |
if ((($formname eq 'screenshot') && ($subdir eq 'helprequests')) || |
| |
(($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) || |
| |
($context eq 'existingfile') || ($context eq 'canceloverwrite')) { |
| my $now = time; |
my $now = time; |
| my $filepath = 'tmp/helprequests/'.$now; |
my $filepath; |
| my @parts=split(/\//,$filepath); |
if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { |
| my $fullpath = $perlvar{'lonDaemons'}; |
$filepath = 'tmp/helprequests/'.$now; |
| for (my $i=0;$i<@parts;$i++) { |
} elsif (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) { |
| $fullpath .= '/'.$parts[$i]; |
$filepath = 'tmp/addcourse/'.$destudom.'/web/'.$env{'user.name'}. |
| if ((-e $fullpath)!=1) { |
'_'.$env{'user.domain'}.'/pending'; |
| mkdir($fullpath,0777); |
} elsif (($context eq 'existingfile') || ($context eq 'canceloverwrite')) { |
| |
my ($docuname,$docudom); |
| |
if ($destudom =~ /^$match_domain$/) { |
| |
$docudom = $destudom; |
| |
} else { |
| |
$docudom = $env{'user.domain'}; |
| |
} |
| |
if ($destuname =~ /^$match_username$/) { |
| |
$docuname = $destuname; |
| |
} else { |
| |
$docuname = $env{'user.name'}; |
| |
} |
| |
if (exists($env{'form.group'})) { |
| |
$docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; |
| |
$docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; |
| |
} |
| |
$filepath = 'tmp/overwrites/'.$docudom.'/'.$docuname.'/'.$subdir; |
| |
if ($context eq 'canceloverwrite') { |
| |
my $tempfile = $perlvar{'lonDaemons'}.'/'.$filepath.'/'.$fname; |
| |
if (-e $tempfile) { |
| |
my @info = stat($tempfile); |
| |
if ($info[9] eq $env{'form.timestamp'}) { |
| |
unlink($tempfile); |
| |
} |
| |
} |
| |
return; |
| } |
} |
| } |
} |
| open(my $fh,'>'.$fullpath.'/'.$fname); |
# Create the directory if not present |
| print $fh $env{'form.'.$formname}; |
|
| close($fh); |
|
| return $fullpath.'/'.$fname; |
|
| } elsif (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) { #files uploaded to create course page are handled differently |
|
| my $filepath = 'tmp/addcourse/'.$destudom.'/web/'.$env{'user.name'}. |
|
| '_'.$env{'user.domain'}.'/pending'; |
|
| my @parts=split(/\//,$filepath); |
my @parts=split(/\//,$filepath); |
| my $fullpath = $perlvar{'lonDaemons'}; |
my $fullpath = $perlvar{'lonDaemons'}; |
| for (my $i=0;$i<@parts;$i++) { |
for (my $i=0;$i<@parts;$i++) { |
|
Line 1514 sub userfileupload {
|
Line 4237 sub userfileupload {
|
| mkdir($fullpath,0777); |
mkdir($fullpath,0777); |
| } |
} |
| } |
} |
| open(my $fh,'>'.$fullpath.'/'.$fname); |
open(my $fh,'>',$fullpath.'/'.$fname); |
| print $fh $env{'form.'.$formname}; |
print $fh $env{'form.'.$formname}; |
| close($fh); |
close($fh); |
| return $fullpath.'/'.$fname; |
if ($context eq 'existingfile') { |
| |
my @info = stat($fullpath.'/'.$fname); |
| |
return ($fullpath.'/'.$fname,$info[9]); |
| |
} else { |
| |
return $fullpath.'/'.$fname; |
| |
} |
| } |
} |
| |
if ($subdir eq 'scantron') { |
| # Create the directory if not present |
$fname = 'scantron_orig_'.$fname; |
| $fname="$subdir/$fname"; |
} else { |
| if ($coursedoc) { |
$fname="$subdir/$fname"; |
| |
} |
| |
if ($context eq '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); |
$codebase,$thumbwidth,$thumbheight, |
| |
$resizewidth,$resizeheight,$context,$mimetype); |
| } else { |
} else { |
| $fname=$env{'form.folder'}.'/'.$fname; |
if ($env{'form.folder'}) { |
| |
$fname=$env{'form.folder'}.'/'.$fname; |
| |
} |
| return &process_coursefile('uploaddoc',$docuname,$docudom, |
return &process_coursefile('uploaddoc',$docuname,$docudom, |
| $fname,$formname,$parser, |
$fname,$formname,$parser, |
| $allfiles,$codebase); |
$allfiles,$codebase,$mimetype); |
| } |
} |
| } elsif (defined($destuname)) { |
} elsif (defined($destuname)) { |
| my $docuname=$destuname; |
my $docuname=$destuname; |
| my $docudom=$destudom; |
my $docudom=$destudom; |
| return &finishuserfileupload($docuname,$docudom,$formname, |
return &finishuserfileupload($docuname,$docudom,$formname,$fname, |
| $fname,$parser,$allfiles,$codebase); |
$parser,$allfiles,$codebase, |
| |
$thumbwidth,$thumbheight, |
| |
$resizewidth,$resizeheight,$context,$mimetype); |
| } else { |
} else { |
| my $docuname=$env{'user.name'}; |
my $docuname=$env{'user.name'}; |
| my $docudom=$env{'user.domain'}; |
my $docudom=$env{'user.domain'}; |
| if (exists($env{'form.group'})) { |
if ((exists($env{'form.group'})) || ($context eq 'syllabus')) { |
| $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; |
$docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; |
| $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; |
$docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; |
| } |
} |
| return &finishuserfileupload($docuname,$docudom,$formname, |
return &finishuserfileupload($docuname,$docudom,$formname,$fname, |
| $fname,$parser,$allfiles,$codebase); |
$parser,$allfiles,$codebase, |
| |
$thumbwidth,$thumbheight, |
| |
$resizewidth,$resizeheight,$context,$mimetype); |
| } |
} |
| } |
} |
| |
|
| sub finishuserfileupload { |
sub finishuserfileupload { |
| my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase) = @_; |
my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase, |
| |
$thumbwidth,$thumbheight,$resizewidth,$resizeheight,$context,$mimetype) = @_; |
| my $path=$docudom.'/'.$docuname.'/'; |
my $path=$docudom.'/'.$docuname.'/'; |
| my $filepath=$perlvar{'lonDocRoot'}; |
my $filepath=$perlvar{'lonDocRoot'}; |
| my ($fnamepath,$file); |
|
| |
my ($fnamepath,$file,$fetchthumb); |
| $file=$fname; |
$file=$fname; |
| if ($fname=~m|/|) { |
if ($fname=~m|/|) { |
| ($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|); |
($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|); |
|
Line 1571 sub finishuserfileupload {
|
Line 4309 sub finishuserfileupload {
|
| mkdir($filepath,0777); |
mkdir($filepath,0777); |
| } |
} |
| } |
} |
| |
|
| # Save the file |
# Save the file |
| { |
{ |
| if (!open(FH,'>'.$filepath.'/'.$file)) { |
if (!open(FH,'>',$filepath.'/'.$file)) { |
| &logthis('Failed to create '.$filepath.'/'.$file); |
&logthis('Failed to create '.$filepath.'/'.$file); |
| print STDERR ('Failed to create '.$filepath.'/'.$file."\n"); |
print STDERR ('Failed to create '.$filepath.'/'.$file."\n"); |
| return '/adm/notfound.html'; |
return '/adm/notfound.html'; |
| } |
} |
| if (!print FH ($env{'form.'.$formname})) { |
if ($context eq 'overwrite') { |
| |
my $source = LONCAPA::tempdir().'/overwrites/'.$docudom.'/'.$docuname.'/'.$fname; |
| |
my $target = $filepath.'/'.$file; |
| |
if (-e $source) { |
| |
my @info = stat($source); |
| |
if ($info[9] eq $env{'form.timestamp'}) { |
| |
unless (&File::Copy::move($source,$target)) { |
| |
&logthis('Failed to overwrite '.$filepath.'/'.$file); |
| |
return "Moving from $source failed"; |
| |
} |
| |
} else { |
| |
return "Temporary file: $source had unexpected date/time for last modification"; |
| |
} |
| |
} else { |
| |
return "Temporary file: $source missing"; |
| |
} |
| |
} elsif (!print FH ($env{'form.'.$formname})) { |
| &logthis('Failed to write to '.$filepath.'/'.$file); |
&logthis('Failed to write to '.$filepath.'/'.$file); |
| print STDERR ('Failed to write to '.$filepath.'/'.$file."\n"); |
print STDERR ('Failed to write to '.$filepath.'/'.$file."\n"); |
| 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 (($context eq 'coursedoc') || ($parser eq 'parse')) { |
| my $parse_result = &extract_embedded_items($filepath,$file,$allfiles, |
if (ref($mimetype)) { |
| $codebase); |
if ($$mimetype eq '') { |
| unless ($parse_result eq 'ok') { |
my $mm = new File::MMagic; |
| &logthis('Failed to parse '.$filepath.$file. |
my $type = $mm->checktype_filename($filepath.'/'.$file); |
| ' for embedded media: '.$parse_result); |
$$mimetype = $type; |
| |
} |
| } |
} |
| } |
} |
| |
if (($context ne 'scantron') && ($parser eq 'parse')) { |
| |
if ((ref($mimetype)) && ($$mimetype eq 'text/html')) { |
| |
my $parse_result = &extract_embedded_items($filepath.'/'.$file, |
| |
$allfiles,$codebase); |
| |
unless ($parse_result eq 'ok') { |
| |
&logthis('Failed to parse '.$filepath.$file. |
| |
' for embedded media: '.$parse_result); |
| |
} |
| |
} |
| |
} elsif (($context eq 'scantron') && (ref($parser) eq 'HASH')) { |
| |
my $format = $env{'form.scantron_format'}; |
| |
&bubblesheet_converter($docudom,$filepath.'/'.$file,$parser,$format); |
| |
} |
| |
if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) { |
| |
my $input = $filepath.'/'.$file; |
| |
my $output = $filepath.'/'.'tn-'.$file; |
| |
my $thumbsize = $thumbwidth.'x'.$thumbheight; |
| |
my @args = ('convert','-sample',$thumbsize,$input,$output); |
| |
system({$args[0]} @args); |
| |
if (-e $filepath.'/'.'tn-'.$file) { |
| |
$fetchthumb = 1; |
| |
} |
| |
} |
| |
|
| # 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) { |
| |
my $thumbresult= &reply('fetchuserfile:'.$path.'tn-'.$file,$docuhome); |
| |
if ($thumbresult ne 'ok') { |
| |
&logthis('Failed to transfer '.$path.'tn-'.$file.' to host '. |
| |
$docuhome.': '.$thumbresult); |
| |
} |
| |
} |
| # |
# |
| # Return the URL to it |
# Return the URL to it |
| return '/uploaded/'.$path.$file; |
return '/uploaded/'.$path.$file; |
|
Line 1605 sub finishuserfileupload {
|
Line 4399 sub finishuserfileupload {
|
| &logthis('Failed to transfer '.$path.$file.' to host '.$docuhome. |
&logthis('Failed to transfer '.$path.$file.' to host '.$docuhome. |
| ': '.$fetchresult); |
': '.$fetchresult); |
| return '/adm/notfound.html'; |
return '/adm/notfound.html'; |
| } |
} |
| } |
} |
| |
|
| sub extract_embedded_items { |
sub extract_embedded_items { |
| my ($filepath,$file,$allfiles,$codebase,$content) = @_; |
my ($fullpath,$allfiles,$codebase,$content) = @_; |
| my @state = (); |
my @state = (); |
| |
my (%lastids,%related,%shockwave,%flashvars); |
| my %javafiles = ( |
my %javafiles = ( |
| codebase => '', |
codebase => '', |
| code => '', |
code => '', |
|
Line 1624 sub extract_embedded_items {
|
Line 4419 sub extract_embedded_items {
|
| if ($content) { |
if ($content) { |
| $p = HTML::LCParser->new($content); |
$p = HTML::LCParser->new($content); |
| } else { |
} else { |
| $p = HTML::LCParser->new($filepath.'/'.$file); |
$p = HTML::LCParser->new($fullpath); |
| } |
} |
| while (my $t=$p->get_token()) { |
while (my $t=$p->get_token()) { |
| if ($t->[0] eq 'S') { |
if ($t->[0] eq 'S') { |
| my ($tagname, $attr) = ($t->[1],$t->[2]); |
my ($tagname, $attr) = ($t->[1],$t->[2]); |
| push (@state, $tagname); |
push(@state, $tagname); |
| if (lc($tagname) eq 'allow') { |
if (lc($tagname) eq 'allow') { |
| &add_filetype($allfiles,$attr->{'src'},'src'); |
&add_filetype($allfiles,$attr->{'src'},'src'); |
| } |
} |
| if (lc($tagname) eq 'img') { |
if (lc($tagname) eq 'img') { |
| &add_filetype($allfiles,$attr->{'src'},'src'); |
&add_filetype($allfiles,$attr->{'src'},'src'); |
| } |
} |
| |
if (lc($tagname) eq 'a') { |
| |
unless (($attr->{'href'} =~ /^#/) || ($attr->{'href'} eq '')) { |
| |
&add_filetype($allfiles,$attr->{'href'},'href'); |
| |
} |
| |
} |
| if (lc($tagname) eq 'script') { |
if (lc($tagname) eq 'script') { |
| |
my $src; |
| if ($attr->{'archive'} =~ /\.jar$/i) { |
if ($attr->{'archive'} =~ /\.jar$/i) { |
| &add_filetype($allfiles,$attr->{'archive'},'archive'); |
&add_filetype($allfiles,$attr->{'archive'},'archive'); |
| } else { |
} else { |
| &add_filetype($allfiles,$attr->{'src'},'src'); |
if ($attr->{'src'} ne '') { |
| |
$src = $attr->{'src'}; |
| |
&add_filetype($allfiles,$src,'src'); |
| |
} |
| |
} |
| |
my $text = $p->get_trimmed_text(); |
| |
if ($text =~ /\Qswfobject.registerObject(\E([^\)]+)\)/) { |
| |
my @swfargs = split(/,/,$1); |
| |
foreach my $item (@swfargs) { |
| |
$item =~ s/["']//g; |
| |
$item =~ s/^\s+//; |
| |
$item =~ s/\s+$//; |
| |
} |
| |
if (($swfargs[0] ne'') && ($swfargs[2] ne '')) { |
| |
if (ref($related{$swfargs[0]}) eq 'ARRAY') { |
| |
push(@{$related{$swfargs[0]}},$swfargs[2]); |
| |
} else { |
| |
$related{$swfargs[0]} = [$swfargs[2]]; |
| |
} |
| |
} |
| } |
} |
| } |
} |
| if (lc($tagname) eq 'link') { |
if (lc($tagname) eq 'link') { |
|
Line 1653 sub extract_embedded_items {
|
Line 4473 sub extract_embedded_items {
|
| foreach my $item (keys(%javafiles)) { |
foreach my $item (keys(%javafiles)) { |
| $javafiles{$item} = ''; |
$javafiles{$item} = ''; |
| } |
} |
| |
if ((lc($tagname) eq 'object') && (lc($state[-2]) ne 'object')) { |
| |
$lastids{lc($tagname)} = $attr->{'id'}; |
| |
} |
| } |
} |
| if (lc($state[-2]) eq 'object' && lc($tagname) eq 'param') { |
if (lc($state[-2]) eq 'object' && lc($tagname) eq 'param') { |
| my $name = lc($attr->{'name'}); |
my $name = lc($attr->{'name'}); |
|
Line 1662 sub extract_embedded_items {
|
Line 4485 sub extract_embedded_items {
|
| last; |
last; |
| } |
} |
| } |
} |
| |
my $pathfrom; |
| foreach my $item (keys(%mediafiles)) { |
foreach my $item (keys(%mediafiles)) { |
| if ($name eq $item) { |
if ($name eq $item) { |
| &add_filetype($allfiles, $attr->{'value'}, 'value'); |
$pathfrom = $attr->{'value'}; |
| |
$shockwave{$lastids{lc($state[-2])}} = $pathfrom; |
| |
&add_filetype($allfiles,$pathfrom,$name); |
| last; |
last; |
| } |
} |
| } |
} |
| |
if ($name eq 'flashvars') { |
| |
$flashvars{$lastids{lc($state[-2])}} = $attr->{'value'}; |
| |
} |
| |
if ($pathfrom ne '') { |
| |
&embedded_dependency($allfiles,\%related,$lastids{lc($state[-2])}, |
| |
$pathfrom); |
| |
} |
| } |
} |
| if (lc($tagname) eq 'embed' || lc($tagname) eq 'applet') { |
if (lc($tagname) eq 'embed' || lc($tagname) eq 'applet') { |
| foreach my $item (keys(%javafiles)) { |
foreach my $item (keys(%javafiles)) { |
|
Line 1682 sub extract_embedded_items {
|
Line 4515 sub extract_embedded_items {
|
| last; |
last; |
| } |
} |
| } |
} |
| |
if (lc($tagname) eq 'embed') { |
| |
if (($attr->{'name'} ne '') && ($attr->{'src'} ne '')) { |
| |
&embedded_dependency($allfiles,\%related,$attr->{'name'}, |
| |
$attr->{'src'}); |
| |
} |
| |
} |
| } |
} |
| |
if (lc($tagname) eq 'iframe') { |
| |
my $src = $attr->{'src'} ; |
| |
if (($src ne '') && ($src !~ m{^(/|https?://)})) { |
| |
&add_filetype($allfiles,$src,'src'); |
| |
} elsif ($src =~ m{^/}) { |
| |
if ($env{'request.course.id'}) { |
| |
my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; |
| |
my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; |
| |
my $url = &hreflocation('',$fullpath); |
| |
if ($url =~ m{^/uploaded/$cdom/$cnum/docs/(\w+/\d+)/}) { |
| |
my $relpath = $1; |
| |
if ($src =~ m{^/uploaded/$cdom/$cnum/docs/\Q$relpath\E/(.+)$}) { |
| |
&add_filetype($allfiles,$1,'src'); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if ($t->[4] =~ m{/>$}) { |
| |
pop(@state); |
| |
} |
| } elsif ($t->[0] eq 'E') { |
} elsif ($t->[0] eq 'E') { |
| my ($tagname) = ($t->[1]); |
my ($tagname) = ($t->[1]); |
| if ($javafiles{'codebase'} ne '') { |
if ($javafiles{'codebase'} ne '') { |
|
Line 1702 sub extract_embedded_items {
|
Line 4562 sub extract_embedded_items {
|
| pop @state; |
pop @state; |
| } |
} |
| } |
} |
| |
foreach my $id (sort(keys(%flashvars))) { |
| |
if ($shockwave{$id} ne '') { |
| |
my @pairs = split(/\&/,$flashvars{$id}); |
| |
foreach my $pair (@pairs) { |
| |
my ($key,$value) = split(/\=/,$pair); |
| |
if ($key eq 'thumb') { |
| |
&add_filetype($allfiles,$value,$key); |
| |
} elsif ($key eq 'content') { |
| |
my ($path) = ($shockwave{$id} =~ m{^(.+/)[^/]+$}); |
| |
my ($ext) = ($value =~ /\.([^.]+)$/); |
| |
if ($ext ne '') { |
| |
&add_filetype($allfiles,$path.$value,$ext); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| return 'ok'; |
return 'ok'; |
| } |
} |
| |
|
|
Line 1716 sub add_filetype {
|
Line 4593 sub add_filetype {
|
| } |
} |
| } |
} |
| |
|
| |
sub embedded_dependency { |
| |
my ($allfiles,$related,$identifier,$pathfrom) = @_; |
| |
if ((ref($allfiles) eq 'HASH') && (ref($related) eq 'HASH')) { |
| |
if (($identifier ne '') && |
| |
(ref($related->{$identifier}) eq 'ARRAY') && |
| |
($pathfrom ne '')) { |
| |
my ($path) = ($pathfrom =~ m{^(.+/)[^/]+$}); |
| |
foreach my $dep (@{$related->{$identifier}}) { |
| |
&add_filetype($allfiles,$path.$dep,'object'); |
| |
} |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| |
sub bubblesheet_converter { |
| |
my ($cdom,$fullpath,$config,$format) = @_; |
| |
if ((&domain($cdom) ne '') && |
| |
($fullpath =~ m{^\Q$perlvar{'lonDocRoot'}/userfiles/$cdom/\E$match_courseid/scantron_orig}) && |
| |
(-e $fullpath) && (ref($config) eq 'HASH') && ($format ne '')) { |
| |
my (%csvcols,%csvoptions); |
| |
if (ref($config->{'fields'}) eq 'HASH') { |
| |
%csvcols = %{$config->{'fields'}}; |
| |
} |
| |
if (ref($config->{'options'}) eq 'HASH') { |
| |
%csvoptions = %{$config->{'options'}}; |
| |
} |
| |
my %csvbynum = reverse(%csvcols); |
| |
my %scantronconf = &get_scantron_config($format,$cdom); |
| |
if (keys(%scantronconf)) { |
| |
my %bynum = ( |
| |
$scantronconf{CODEstart} => 'CODEstart', |
| |
$scantronconf{IDstart} => 'IDstart', |
| |
$scantronconf{PaperID} => 'PaperID', |
| |
$scantronconf{FirstName} => 'FirstName', |
| |
$scantronconf{LastName} => 'LastName', |
| |
$scantronconf{Qstart} => 'Qstart', |
| |
); |
| |
my @ordered; |
| |
foreach my $item (sort { $a <=> $b } keys(%bynum)) { |
| |
push(@ordered,$bynum{$item}); |
| |
} |
| |
my %mapstart = ( |
| |
CODEstart => 'CODE', |
| |
IDstart => 'ID', |
| |
PaperID => 'PaperID', |
| |
FirstName => 'FirstName', |
| |
LastName => 'LastName', |
| |
Qstart => 'FirstQuestion', |
| |
); |
| |
my %maplength = ( |
| |
CODEstart => 'CODElength', |
| |
IDstart => 'IDlength', |
| |
PaperID => 'PaperIDlength', |
| |
FirstName => 'FirstNamelength', |
| |
LastName => 'LastNamelength', |
| |
); |
| |
if (open(my $fh,'<',$fullpath)) { |
| |
my $output; |
| |
my %lettdig = &letter_to_digits(); |
| |
my %diglett = reverse(%lettdig); |
| |
my $numletts = scalar(keys(%lettdig)); |
| |
my $num = 0; |
| |
while (my $line=<$fh>) { |
| |
$num ++; |
| |
next if (($num == 1) && ($csvoptions{'hdr'} == 1)); |
| |
$line =~ s{[\r\n]+$}{}; |
| |
my %found; |
| |
my @values = split(/,/,$line); |
| |
my ($qstart,$record); |
| |
for (my $i=0; $i<@values; $i++) { |
| |
if ((($qstart ne '') && ($i > $qstart)) || |
| |
($csvbynum{$i} eq 'FirstQuestion')) { |
| |
if ($values[$i] eq '') { |
| |
$values[$i] = $scantronconf{'Qoff'}; |
| |
} elsif ($scantronconf{'Qon'} eq 'number') { |
| |
if ($values[$i] =~ /^[A-Ja-j]$/) { |
| |
$values[$i] = $lettdig{uc($values[$i])}; |
| |
} |
| |
} elsif ($scantronconf{'Qon'} eq 'letter') { |
| |
if ($values[$i] =~ /^[0-9]$/) { |
| |
$values[$i] = $diglett{$values[$i]}; |
| |
} |
| |
} else { |
| |
if ($values[$i] =~ /^[0-9A-Ja-j]$/) { |
| |
my $digit; |
| |
if ($values[$i] =~ /^[A-Ja-j]$/) { |
| |
$digit = $lettdig{uc($values[$i])}-1; |
| |
if ($values[$i] eq 'J') { |
| |
$digit += $numletts; |
| |
} |
| |
} elsif ($values[$i] =~ /^[0-9]$/) { |
| |
$digit = $values[$i]-1; |
| |
if ($values[$i] eq '0') { |
| |
$digit += $numletts; |
| |
} |
| |
} |
| |
my $qval=''; |
| |
for (my $j=0; $j<$scantronconf{'Qlength'}; $j++) { |
| |
if ($j == $digit) { |
| |
$qval .= $scantronconf{'Qon'}; |
| |
} else { |
| |
$qval .= $scantronconf{'Qoff'}; |
| |
} |
| |
} |
| |
$values[$i] = $qval; |
| |
} |
| |
} |
| |
if (length($values[$i]) > $scantronconf{'Qlength'}) { |
| |
$values[$i] = substr($values[$i],0,$scantronconf{'Qlength'}); |
| |
} |
| |
my $numblank = $scantronconf{'Qlength'} - length($values[$i]); |
| |
if ($numblank > 0) { |
| |
$values[$i] .= ($scantronconf{'Qoff'} x $numblank); |
| |
} |
| |
if ($csvbynum{$i} eq 'FirstQuestion') { |
| |
$qstart = $i; |
| |
$found{$csvbynum{$i}} = $values[$i]; |
| |
} else { |
| |
$found{'FirstQuestion'} .= $values[$i]; |
| |
} |
| |
} elsif (exists($csvbynum{$i})) { |
| |
if ($csvoptions{'rem'}) { |
| |
$values[$i] =~ s/^\s+//; |
| |
} |
| |
if (($csvbynum{$i} eq 'PaperID') && ($csvoptions{'pad'})) { |
| |
while (length($values[$i]) < $scantronconf{$maplength{$csvbynum{$i}}}) { |
| |
$values[$i] = '0'.$values[$i]; |
| |
} |
| |
} |
| |
$found{$csvbynum{$i}} = $values[$i]; |
| |
} |
| |
} |
| |
foreach my $item (@ordered) { |
| |
my $currlength = 1+length($record); |
| |
my $numspaces = $scantronconf{$item} - $currlength; |
| |
if ($numspaces > 0) { |
| |
$record .= (' ' x $numspaces); |
| |
} |
| |
if (($mapstart{$item} ne '') && (exists($found{$mapstart{$item}}))) { |
| |
unless ($item eq 'Qstart') { |
| |
if (length($found{$mapstart{$item}}) > $scantronconf{$maplength{$item}}) { |
| |
$found{$mapstart{$item}} = substr($found{$mapstart{$item}},0,$scantronconf{$maplength{$item}}); |
| |
} |
| |
} |
| |
$record .= $found{$mapstart{$item}}; |
| |
} |
| |
} |
| |
$output .= "$record\n"; |
| |
} |
| |
close($fh); |
| |
if ($output) { |
| |
if (open(my $fh,'>',$fullpath)) { |
| |
print $fh $output; |
| |
close($fh); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
} |
| |
|
| |
sub letter_to_digits { |
| |
my %lettdig = ( |
| |
A => 1, |
| |
B => 2, |
| |
C => 3, |
| |
D => 4, |
| |
E => 5, |
| |
F => 6, |
| |
G => 7, |
| |
H => 8, |
| |
I => 9, |
| |
J => 0, |
| |
); |
| |
return %lettdig; |
| |
} |
| |
|
| |
sub get_scantron_config { |
| |
my ($which,$cdom) = @_; |
| |
my @lines = &get_scantronformat_file($cdom); |
| |
my %config; |
| |
#FIXME probably should move to XML it has already gotten a bit much now |
| |
foreach my $line (@lines) { |
| |
my ($name,$descrip)=split(/:/,$line); |
| |
if ($name ne $which ) { next; } |
| |
chomp($line); |
| |
my @config=split(/:/,$line); |
| |
$config{'name'}=$config[0]; |
| |
$config{'description'}=$config[1]; |
| |
$config{'CODElocation'}=$config[2]; |
| |
$config{'CODEstart'}=$config[3]; |
| |
$config{'CODElength'}=$config[4]; |
| |
$config{'IDstart'}=$config[5]; |
| |
$config{'IDlength'}=$config[6]; |
| |
$config{'Qstart'}=$config[7]; |
| |
$config{'Qlength'}=$config[8]; |
| |
$config{'Qoff'}=$config[9]; |
| |
$config{'Qon'}=$config[10]; |
| |
$config{'PaperID'}=$config[11]; |
| |
$config{'PaperIDlength'}=$config[12]; |
| |
$config{'FirstName'}=$config[13]; |
| |
$config{'FirstNamelength'}=$config[14]; |
| |
$config{'LastName'}=$config[15]; |
| |
$config{'LastNamelength'}=$config[16]; |
| |
$config{'BubblesPerRow'}=$config[17]; |
| |
last; |
| |
} |
| |
return %config; |
| |
} |
| |
|
| |
sub get_scantronformat_file { |
| |
my ($cdom) = @_; |
| |
if ($cdom eq '') { |
| |
$cdom= $env{'course.'.$env{'request.course.id'}.'.domain'}; |
| |
} |
| |
my %domconfig = &get_dom('configuration',['scantron'],$cdom); |
| |
my $gottab = 0; |
| |
my @lines; |
| |
if (ref($domconfig{'scantron'}) eq 'HASH') { |
| |
if ($domconfig{'scantron'}{'scantronformat'} ne '') { |
| |
my $formatfile = &getfile($perlvar{'lonDocRoot'}.$domconfig{'scantron'}{'scantronformat'}); |
| |
if ($formatfile ne '-1') { |
| |
@lines = split("\n",$formatfile,-1); |
| |
$gottab = 1; |
| |
} |
| |
} |
| |
} |
| |
if (!$gottab) { |
| |
my $confname = $cdom.'-domainconfig'; |
| |
my $default = $perlvar{'lonDocRoot'}.'/res/'.$cdom.'/'.$confname.'/default.tab'; |
| |
my $formatfile = &getfile($default); |
| |
if ($formatfile ne '-1') { |
| |
@lines = split("\n",$formatfile,-1); |
| |
$gottab = 1; |
| |
} |
| |
} |
| |
if (!$gottab) { |
| |
my @domains = ¤t_machine_domains(); |
| |
if (grep(/^\Q$cdom\E$/,@domains)) { |
| |
if (open(my $fh,'<',$perlvar{'lonTabDir'}.'/scantronformat.tab')) { |
| |
@lines = <$fh>; |
| |
close($fh); |
| |
} |
| |
} else { |
| |
if (open(my $fh,'<',$perlvar{'lonTabDir'}.'/default_scantronformat.tab')) { |
| |
@lines = <$fh>; |
| |
close($fh); |
| |
} |
| |
} |
| |
} |
| |
return @lines; |
| |
} |
| |
|
| 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 1792 sub flushcourselogs {
|
Line 4924 sub flushcourselogs {
|
| # times and course titles for all courseids |
# times and course titles for all courseids |
| # |
# |
| my %courseidbuffer=(); |
my %courseidbuffer=(); |
| foreach my $crsid (keys %courselogs) { |
foreach my $crsid (keys(%courselogs)) { |
| if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'. |
if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'. |
| &escape($courselogs{$crsid}), |
&escape($courselogs{$crsid}), |
| $coursehombuf{$crsid}) eq 'ok') { |
$coursehombuf{$crsid}) eq 'ok') { |
|
Line 1805 sub flushcourselogs {
|
Line 4937 sub flushcourselogs {
|
| delete $courselogs{$crsid}; |
delete $courselogs{$crsid}; |
| } |
} |
| } |
} |
| if ($courseidbuffer{$coursehombuf{$crsid}}) { |
$courseidbuffer{$coursehombuf{$crsid}}{$crsid} = { |
| $courseidbuffer{$coursehombuf{$crsid}}.='&'. |
'description' => $coursedescrbuf{$crsid}, |
| &escape($crsid).'='.&escape($coursedescrbuf{$crsid}). |
'inst_code' => $courseinstcodebuf{$crsid}, |
| ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid}); |
'type' => $coursetypebuf{$crsid}, |
| } else { |
'owner' => $courseownerbuf{$crsid}, |
| $courseidbuffer{$coursehombuf{$crsid}}= |
}; |
| &escape($crsid).'='.&escape($coursedescrbuf{$crsid}). |
|
| ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid}); |
|
| } |
|
| } |
} |
| # |
# |
| # Write course id database (reverse lookup) to homeserver of courses |
# Write course id database (reverse lookup) to homeserver of courses |
| # Is used in pickcourse |
# Is used in pickcourse |
| # |
# |
| foreach my $crsid (keys(%courseidbuffer)) { |
foreach my $crs_home (keys(%courseidbuffer)) { |
| &courseidput($hostdom{$crsid},$courseidbuffer{$crsid},$crsid); |
my $response = &courseidput(&host_domain($crs_home), |
| |
$courseidbuffer{$crs_home}, |
| |
$crs_home,'timeonly'); |
| } |
} |
| # |
# |
| # File accesses |
# File accesses |
|
Line 1843 sub flushcourselogs {
|
Line 4974 sub flushcourselogs {
|
| my $result = &inc('nohist_accesscount',\%temphash,$dom,$name); |
my $result = &inc('nohist_accesscount',\%temphash,$dom,$name); |
| if ($result eq 'ok') { |
if ($result eq 'ok') { |
| delete $accesshash{$entry}; |
delete $accesshash{$entry}; |
| } elsif ($result eq 'unknown_cmd') { |
|
| # Target server has old code running on it. |
|
| my %temphash=($entry => $value); |
|
| if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') { |
|
| delete $accesshash{$entry}; |
|
| } |
|
| } |
} |
| } else { |
} else { |
| my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$}); |
my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$}); |
| |
if (($dom eq 'uploaded') || ($dom eq 'adm')) { next; } |
| my %temphash=($entry => $accesshash{$entry}); |
my %temphash=($entry => $accesshash{$entry}); |
| if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') { |
if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') { |
| delete $accesshash{$entry}; |
delete $accesshash{$entry}; |
|
Line 1872 sub flushcourselogs {
|
Line 4998 sub flushcourselogs {
|
| } |
} |
| } |
} |
| # |
# |
| # Reverse lookup of domain roles (dc, ad, li, sc, au) |
# Reverse lookup of domain roles (dc, ad, li, sc, dh, da, 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). |
| '='.&escape($domainrolehash{$entry}); |
'='.&escape($domainrolehash{$entry}); |
|
Line 1887 sub flushcourselogs {
|
Line 5013 sub flushcourselogs {
|
| delete $domainrolehash{$entry}; |
delete $domainrolehash{$entry}; |
| } |
} |
| foreach my $dom (keys(%domrolebuffer)) { |
foreach my $dom (keys(%domrolebuffer)) { |
| foreach my $tryserver (keys %libserv) { |
my %servers; |
| if ($hostdom{$tryserver} eq $dom) { |
if (defined(&domain($dom,'primary'))) { |
| unless (&reply('domroleput:'.$dom.':'. |
my $primary=&domain($dom,'primary'); |
| $domrolebuffer{$dom},$tryserver) eq 'ok') { |
my $hostname=&hostname($primary); |
| &logthis('Put of domain roles failed for '.$dom.' and '.$tryserver); |
$servers{$primary} = $hostname; |
| } |
} else { |
| } |
%servers = &get_servers($dom,'library'); |
| |
} |
| |
foreach my $tryserver (keys(%servers)) { |
| |
if (&reply('domroleput:'.$dom.':'. |
| |
$domrolebuffer{$dom},$tryserver) eq 'ok') { |
| |
last; |
| |
} else { |
| |
&logthis('Put of domain roles failed for '.$dom.' and '.$tryserver); |
| |
} |
| } |
} |
| } |
} |
| $dumpcount++; |
$dumpcount++; |
|
Line 1931 sub courseacclog {
|
Line 5065 sub courseacclog {
|
| my $fnsymb=shift; |
my $fnsymb=shift; |
| unless ($env{'request.course.id'}) { return ''; } |
unless ($env{'request.course.id'}) { return ''; } |
| my $what=$fnsymb.':'.$env{'user.name'}.':'.$env{'user.domain'}; |
my $what=$fnsymb.':'.$env{'user.name'}.':'.$env{'user.domain'}; |
| if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|task|page)$/) { |
if ($fnsymb=~/$LONCAPA::assess_re/) { |
| $what.=':POST'; |
$what.=':POST'; |
| # 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(?:[^.]+)$/) { |
| |
if ($formitem eq 'proctorpassword') { |
| |
$what.=':'.$formitem.'=' . '*' x length($env{$key}); |
| |
} else { |
| |
$what.=':'.$formitem.'='.$env{$key}; |
| |
} |
| |
} |
| } |
} |
| } |
} |
| } elsif ($fnsymb =~ m:^/adm/searchcat:) { |
} elsif ($fnsymb =~ m:^/adm/searchcat:) { |
|
Line 1958 sub countacc {
|
Line 5101 sub countacc {
|
| my $url=&declutter(shift); |
my $url=&declutter(shift); |
| return if (! defined($url) || $url eq ''); |
return if (! defined($url) || $url eq ''); |
| unless ($env{'request.course.id'}) { return ''; } |
unless ($env{'request.course.id'}) { return ''; } |
| |
# |
| |
# Mark that this url was used in this course |
| |
# |
| $accesshash{$env{'request.course.id'}.'___'.$url.'___course'}=1; |
$accesshash{$env{'request.course.id'}.'___'.$url.'___course'}=1; |
| |
# |
| |
# Increase the access count for this resource in this child process |
| |
# |
| my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count'; |
my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count'; |
| $accesshash{$key}++; |
$accesshash{$key}++; |
| } |
} |
|
Line 1970 sub linklog {
|
Line 5119 sub linklog {
|
| $accesshash{$from.'___'.$to.'___comefrom'}=1; |
$accesshash{$from.'___'.$to.'___comefrom'}=1; |
| $accesshash{$to.'___'.$from.'___goto'}=1; |
$accesshash{$to.'___'.$from.'___goto'}=1; |
| } |
} |
| |
|
| |
sub statslog { |
| |
my ($symb,$part,$users,$av_attempts,$degdiff)=@_; |
| |
if ($users<2) { return; } |
| |
my %dynstore=&LONCAPA::lonmetadata::dynamic_metadata_storage({ |
| |
'course' => $env{'request.course.id'}, |
| |
'sections' => '"all"', |
| |
'num_students' => $users, |
| |
'part' => $part, |
| |
'symb' => $symb, |
| |
'mean_tries' => $av_attempts, |
| |
'deg_of_diff' => $degdiff}); |
| |
foreach my $key (keys(%dynstore)) { |
| |
$accesshash{$key}=$dynstore{$key}; |
| |
} |
| |
} |
| |
|
| sub userrolelog { |
sub userrolelog { |
| my ($trole,$username,$domain,$area,$tstart,$tend)=@_; |
my ($trole,$username,$domain,$area,$tstart,$tend)=@_; |
| if (($trole=~/^ca/) || ($trole=~/^aa/) || |
if ( $trole =~ /^(ca|aa|in|cc|ep|cr|ta|co)/ ) { |
| ($trole=~/^in/) || ($trole=~/^cc/) || |
|
| ($trole=~/^ep/) || ($trole=~/^cr/) || |
|
| ($trole=~/^ta/)) { |
|
| 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} |
| =$tend.':'.$tstart; |
=$tend.':'.$tstart; |
| } |
} |
| if (($trole=~/^dc/) || ($trole=~/^ad/) || |
if ($env{'request.role'} =~ /dc\./ && $trole =~ /^(au|in|cc|ep|cr|ta|co)/) { |
| ($trole=~/^li/) || ($trole=~/^li/) || |
$userrolehash |
| ($trole=~/^au/) || ($trole=~/^dg/) || |
{$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'} |
| ($trole=~/^sc/)) { |
=$tend.':'.$tstart; |
| |
} |
| |
if ($trole =~ /^(dc|ad|li|au|dg|sc|dh|da)/ ) { |
| my (undef,$rudom,$runame,$rsec)=split(/\//,$area); |
my (undef,$rudom,$runame,$rsec)=split(/\//,$area); |
| $domainrolehash |
$domainrolehash |
| {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} |
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} |
|
Line 1993 sub userrolelog {
|
Line 5157 sub userrolelog {
|
| } |
} |
| } |
} |
| |
|
| |
sub courserolelog { |
| |
my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_; |
| |
if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) { |
| |
my $cdom = $1; |
| |
my $cnum = $2; |
| |
my $sec = $3; |
| |
my $namespace = 'rolelog'; |
| |
my %storehash = ( |
| |
role => $trole, |
| |
start => $tstart, |
| |
end => $tend, |
| |
selfenroll => $selfenroll, |
| |
context => $context, |
| |
); |
| |
if ($trole eq 'gr') { |
| |
$namespace = 'groupslog'; |
| |
$storehash{'group'} = $sec; |
| |
} else { |
| |
$storehash{'section'} = $sec; |
| |
} |
| |
&write_log('course',$namespace,\%storehash,$delflag,$username, |
| |
$domain,$cnum,$cdom); |
| |
if (($trole ne 'st') || ($sec ne '')) { |
| |
&devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum); |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| |
sub domainrolelog { |
| |
my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_; |
| |
if ($area =~ m{^/($match_domain)/$}) { |
| |
my $cdom = $1; |
| |
my $domconfiguser = &Apache::lonnet::get_domainconfiguser($cdom); |
| |
my $namespace = 'rolelog'; |
| |
my %storehash = ( |
| |
role => $trole, |
| |
start => $tstart, |
| |
end => $tend, |
| |
context => $context, |
| |
); |
| |
&write_log('domain',$namespace,\%storehash,$delflag,$username, |
| |
$domain,$domconfiguser,$cdom); |
| |
} |
| |
return; |
| |
|
| |
} |
| |
|
| |
sub coauthorrolelog { |
| |
my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_; |
| |
if ($area =~ m{^/($match_domain)/($match_username)$}) { |
| |
my $audom = $1; |
| |
my $auname = $2; |
| |
my $namespace = 'rolelog'; |
| |
my %storehash = ( |
| |
role => $trole, |
| |
start => $tstart, |
| |
end => $tend, |
| |
context => $context, |
| |
); |
| |
&write_log('author',$namespace,\%storehash,$delflag,$username, |
| |
$domain,$auname,$audom); |
| |
} |
| |
return; |
| |
} |
| |
|
| sub get_course_adv_roles { |
sub get_course_adv_roles { |
| my $cid=shift; |
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'})) { |
| $nothide{join(':',split(/[\@\:]/,$user))}=1; |
if ($user !~ /:/) { |
| |
$nothide{join(':',split(/[\@]/,$user))}=1; |
| |
} else { |
| |
$nothide{$user}=1; |
| |
} |
| |
} |
| |
my @possdoms = ($coursehash{'domain'}); |
| |
if ($coursehash{'checkforpriv'}) { |
| |
push(@possdoms,split(/,/,$coursehash{'checkforpriv'})); |
| } |
} |
| my %returnhash=(); |
my %returnhash=(); |
| 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)) && |
if ((&privileged($username,$domain,\@possdoms)) && |
| (!$nothide{$username.':'.$domain})) { next; } |
(!$nothide{$username.':'.$domain})) { next; } |
| if ($role eq 'cr') { next; } |
if ($role eq 'cr') { next; } |
| my $key=&plaintext($role); |
if ($codes) { |
| if ($section) { $key.=' (Sec/Grp '.$section.')'; } |
if ($section) { $role .= ':'.$section; } |
| if ($returnhash{$key}) { |
if ($returnhash{$role}) { |
| $returnhash{$key}.=','.$username.':'.$domain; |
$returnhash{$role}.=','.$username.':'.$domain; |
| |
} else { |
| |
$returnhash{$role}=$username.':'.$domain; |
| |
} |
| } else { |
} else { |
| $returnhash{$key}=$username.':'.$domain; |
my $key=&plaintext($role,$crstype); |
| |
if ($section) { $key.=' ('.&Apache::lonlocal::mt('Section [_1]',$section).')'; } |
| |
if ($returnhash{$key}) { |
| |
$returnhash{$key}.=','.$username.':'.$domain; |
| |
} else { |
| |
$returnhash{$key}=$username.':'.$domain; |
| |
} |
| } |
} |
| } |
} |
| return %returnhash; |
return %returnhash; |
| } |
} |
| |
|
| sub get_my_roles { |
sub get_my_roles { |
| my ($uname,$udom,$types,$roles,$roledoms)=@_; |
my ($uname,$udom,$context,$types,$roles,$roledoms,$withsec,$hidepriv)=@_; |
| unless (defined($uname)) { $uname=$env{'user.name'}; } |
unless (defined($uname)) { $uname=$env{'user.name'}; } |
| unless (defined($udom)) { $udom=$env{'user.domain'}; } |
unless (defined($udom)) { $udom=$env{'user.domain'}; } |
| my %dumphash= |
my (%dumphash,%nothide); |
| &dump('nohist_userroles',$udom,$uname); |
if ($context eq 'userroles') { |
| |
%dumphash = &dump('roles',$udom,$uname); |
| |
} else { |
| |
%dumphash = &dump('nohist_userroles',$udom,$uname); |
| |
if ($hidepriv) { |
| |
my %coursehash=&coursedescription($udom.'_'.$uname); |
| |
foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { |
| |
if ($user !~ /:/) { |
| |
$nothide{join(':',split(/[\@]/,$user))} = 1; |
| |
} else { |
| |
$nothide{$user} = 1; |
| |
} |
| |
} |
| |
} |
| |
} |
| my %returnhash=(); |
my %returnhash=(); |
| my $now=time; |
my $now=time; |
| |
my %privileged; |
| foreach my $entry (keys(%dumphash)) { |
foreach my $entry (keys(%dumphash)) { |
| my ($tend,$tstart)=split(/\:/,$dumphash{$entry}); |
my ($role,$tend,$tstart); |
| |
if ($context eq 'userroles') { |
| |
next if ($entry =~ /^rolesdef/); |
| |
($role,$tend,$tstart)=split(/_/,$dumphash{$entry}); |
| |
} else { |
| |
($tend,$tstart)=split(/\:/,$dumphash{$entry}); |
| |
} |
| if (($tstart) && ($tstart<0)) { next; } |
if (($tstart) && ($tstart<0)) { next; } |
| my $status = 'active'; |
my $status = 'active'; |
| if (($tend) && ($tend<$now)) { |
if (($tend) && ($tend<=$now)) { |
| $status = 'previous'; |
$status = 'previous'; |
| } |
} |
| if (($tstart) && ($now<$tstart)) { |
if (($tstart) && ($now<$tstart)) { |
|
Line 2053 sub get_my_roles {
|
Line 5323 sub get_my_roles {
|
| next; |
next; |
| } |
} |
| } |
} |
| my ($role,$username,$domain,$section)=split(/\:/,$entry); |
my ($rolecode,$username,$domain,$section,$area); |
| |
if ($context eq 'userroles') { |
| |
($area,$rolecode) = ($entry =~ /^(.+)_([^_]+)$/); |
| |
(undef,$domain,$username,$section) = split(/\//,$area); |
| |
} else { |
| |
($role,$username,$domain,$section) = split(/\:/,$entry); |
| |
} |
| if (ref($roledoms) eq 'ARRAY') { |
if (ref($roledoms) eq 'ARRAY') { |
| if (!grep(/^\Q$domain\E$/,@{$roledoms})) { |
if (!grep(/^\Q$domain\E$/,@{$roledoms})) { |
| next; |
next; |
|
Line 2061 sub get_my_roles {
|
Line 5337 sub get_my_roles {
|
| } |
} |
| if (ref($roles) eq 'ARRAY') { |
if (ref($roles) eq 'ARRAY') { |
| if (!grep(/^\Q$role\E$/,@{$roles})) { |
if (!grep(/^\Q$role\E$/,@{$roles})) { |
| next; |
if ($role =~ /^cr\//) { |
| |
if (!grep(/^cr$/,@{$roles})) { |
| |
next; |
| |
} |
| |
} elsif ($role =~ /^gr\//) { |
| |
if (!grep(/^gr$/,@{$roles})) { |
| |
next; |
| |
} |
| |
} else { |
| |
next; |
| |
} |
| } |
} |
| } |
} |
| $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend; |
if ($hidepriv) { |
| |
my @privroles = ('dc','su'); |
| |
if ($context eq 'userroles') { |
| |
next if (grep(/^\Q$role\E$/,@privroles)); |
| |
} else { |
| |
my $possdoms = [$domain]; |
| |
if (ref($roledoms) eq 'ARRAY') { |
| |
push(@{$possdoms},@{$roledoms}); |
| |
} |
| |
if (&privileged($username,$domain,$possdoms,\@privroles)) { |
| |
if (!$nothide{$username.':'.$domain}) { |
| |
next; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if ($withsec) { |
| |
$returnhash{$username.':'.$domain.':'.$role.':'.$section} = |
| |
$tstart.':'.$tend; |
| |
} else { |
| |
$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend; |
| |
} |
| } |
} |
| return %returnhash; |
return %returnhash; |
| } |
} |
| |
|
| |
sub get_all_adhocroles { |
| |
my ($dom) = @_; |
| |
my @roles_by_num = (); |
| |
my %domdefaults = &get_domain_defaults($dom); |
| |
my (%description,%access_in_dom,%access_info); |
| |
if (ref($domdefaults{'adhocroles'}) eq 'HASH') { |
| |
my $count = 0; |
| |
my %domcurrent = %{$domdefaults{'adhocroles'}}; |
| |
my %ordered; |
| |
foreach my $role (sort(keys(%domcurrent))) { |
| |
my ($order,$desc,$access_in_dom); |
| |
if (ref($domcurrent{$role}) eq 'HASH') { |
| |
$order = $domcurrent{$role}{'order'}; |
| |
$desc = $domcurrent{$role}{'desc'}; |
| |
$access_in_dom{$role} = $domcurrent{$role}{'access'}; |
| |
$access_info{$role} = $domcurrent{$role}{$access_in_dom{$role}}; |
| |
} |
| |
if ($order eq '') { |
| |
$order = $count; |
| |
} |
| |
$ordered{$order} = $role; |
| |
if ($desc ne '') { |
| |
$description{$role} = $desc; |
| |
} else { |
| |
$description{$role}= $role; |
| |
} |
| |
$count++; |
| |
} |
| |
foreach my $item (sort {$a <=> $b } (keys(%ordered))) { |
| |
push(@roles_by_num,$ordered{$item}); |
| |
} |
| |
} |
| |
return (\@roles_by_num,\%description,\%access_in_dom,\%access_info); |
| |
} |
| |
|
| |
sub get_my_adhocroles { |
| |
my ($cid,$checkreg) = @_; |
| |
my ($cdom,$cnum,%info,@possroles,$description,$roles_by_num); |
| |
if ($env{'request.course.id'} eq $cid) { |
| |
$cdom = $env{'course.'.$cid.'.domain'}; |
| |
$cnum = $env{'course.'.$cid.'.num'}; |
| |
$info{'internal.coursecode'} = $env{'course.'.$cid.'.internal.coursecode'}; |
| |
} elsif ($cid =~ /^($match_domain)_($match_courseid)$/) { |
| |
$cdom = $1; |
| |
$cnum = $2; |
| |
%info = &Apache::lonnet::get('environment',['internal.coursecode'], |
| |
$cdom,$cnum); |
| |
} |
| |
if (($info{'internal.coursecode'} ne '') && ($checkreg)) { |
| |
my $user = $env{'user.name'}.':'.$env{'user.domain'}; |
| |
my %rosterhash = &get('classlist',[$user],$cdom,$cnum); |
| |
if ($rosterhash{$user} ne '') { |
| |
my $type = (split(/:/,$rosterhash{$user}))[5]; |
| |
return ([],{}) if ($type eq 'auto'); |
| |
} |
| |
} |
| |
if (($cdom ne '') && ($cnum ne '')) { |
| |
if (($env{"user.role.dh./$cdom/"}) || ($env{"user.role.da./$cdom/"})) { |
| |
my $then=$env{'user.login.time'}; |
| |
my $update=$env{'user.update.time'}; |
| |
if (!$update) { |
| |
$update = $then; |
| |
} |
| |
my @liveroles; |
| |
foreach my $role ('dh','da') { |
| |
if ($env{"user.role.$role./$cdom/"}) { |
| |
my ($tstart,$tend)=split(/\./,$env{"user.role.$role./$cdom/"}); |
| |
my $limit = $update; |
| |
if ($env{'request.role'} eq "$role./$cdom/") { |
| |
$limit = $then; |
| |
} |
| |
my $activerole = 1; |
| |
if ($tstart && $tstart>$limit) { $activerole = 0; } |
| |
if ($tend && $tend <$limit) { $activerole = 0; } |
| |
if ($activerole) { |
| |
push(@liveroles,$role); |
| |
} |
| |
} |
| |
} |
| |
if (@liveroles) { |
| |
if (&homeserver($cnum,$cdom) ne 'no_host') { |
| |
my ($accessref,$accessinfo,%access_in_dom); |
| |
($roles_by_num,$description,$accessref,$accessinfo) = &get_all_adhocroles($cdom); |
| |
if (ref($roles_by_num) eq 'ARRAY') { |
| |
if (@{$roles_by_num}) { |
| |
my %settings; |
| |
if ($env{'request.course.id'} eq $cid) { |
| |
foreach my $envkey (keys(%env)) { |
| |
if ($envkey =~ /^\Qcourse.$cid.\E(internal\.adhoc.+)$/) { |
| |
$settings{$1} = $env{$envkey}; |
| |
} |
| |
} |
| |
} else { |
| |
%settings = &dump('environment',$cdom,$cnum,'internal\.adhoc'); |
| |
} |
| |
my %setincrs; |
| |
if ($settings{'internal.adhocaccess'}) { |
| |
map { $setincrs{$_} = 1; } split(/,/,$settings{'internal.adhocaccess'}); |
| |
} |
| |
my @statuses; |
| |
if ($env{'environment.inststatus'}) { |
| |
@statuses = split(/,/,$env{'environment.inststatus'}); |
| |
} |
| |
my $user = $env{'user.name'}.':'.$env{'user.domain'}; |
| |
if (ref($accessref) eq 'HASH') { |
| |
%access_in_dom = %{$accessref}; |
| |
} |
| |
foreach my $role (@{$roles_by_num}) { |
| |
my ($curraccess,@okstatus,@personnel); |
| |
if ($setincrs{$role}) { |
| |
($curraccess,my $rest) = split(/=/,$settings{'internal.adhoc.'.$role}); |
| |
if ($curraccess eq 'status') { |
| |
@okstatus = split(/\&/,$rest); |
| |
} elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) { |
| |
@personnel = split(/\&/,$rest); |
| |
} |
| |
} else { |
| |
$curraccess = $access_in_dom{$role}; |
| |
if (ref($accessinfo) eq 'HASH') { |
| |
if ($curraccess eq 'status') { |
| |
if (ref($accessinfo->{$role}) eq 'ARRAY') { |
| |
@okstatus = @{$accessinfo->{$role}}; |
| |
} |
| |
} elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) { |
| |
if (ref($accessinfo->{$role}) eq 'ARRAY') { |
| |
@personnel = @{$accessinfo->{$role}}; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if ($curraccess eq 'none') { |
| |
next; |
| |
} elsif ($curraccess eq 'all') { |
| |
push(@possroles,$role); |
| |
} elsif ($curraccess eq 'dh') { |
| |
if (grep(/^dh$/,@liveroles)) { |
| |
push(@possroles,$role); |
| |
} else { |
| |
next; |
| |
} |
| |
} elsif ($curraccess eq 'da') { |
| |
if (grep(/^da$/,@liveroles)) { |
| |
push(@possroles,$role); |
| |
} else { |
| |
next; |
| |
} |
| |
} elsif ($curraccess eq 'status') { |
| |
if (@okstatus) { |
| |
if (!@statuses) { |
| |
if (grep(/^default$/,@okstatus)) { |
| |
push(@possroles,$role); |
| |
} |
| |
} else { |
| |
foreach my $status (@okstatus) { |
| |
if (grep(/^\Q$status\E$/,@statuses)) { |
| |
push(@possroles,$role); |
| |
last; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) { |
| |
if (grep(/^\Q$user\E$/,@personnel)) { |
| |
if ($curraccess eq 'exc') { |
| |
push(@possroles,$role); |
| |
} |
| |
} elsif ($curraccess eq 'inc') { |
| |
push(@possroles,$role); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
unless (ref($description) eq 'HASH') { |
| |
if (ref($roles_by_num) eq 'ARRAY') { |
| |
my %desc; |
| |
map { $desc{$_} = $_; } (@{$roles_by_num}); |
| |
$description = \%desc; |
| |
} else { |
| |
$description = {}; |
| |
} |
| |
} |
| |
return (\@possroles,$description); |
| |
} |
| |
|
| # ----------------------------------------------------- Frontpage Announcements |
# ----------------------------------------------------- Frontpage Announcements |
| # |
# |
| # |
# |
| |
|
| sub postannounce { |
sub postannounce { |
| my ($server,$text)=@_; |
my ($server,$text)=@_; |
| unless (&allowed('psa',$hostdom{$server})) { return 'refused'; } |
unless (&allowed('psa',&host_domain($server))) { return 'refused'; } |
| unless ($text=~/\w/) { $text=''; } |
unless ($text=~/\w/) { $text=''; } |
| return &reply('setannounce:'.&escape($text),$server); |
return &reply('setannounce:'.&escape($text),$server); |
| } |
} |
| |
|
| sub getannounce { |
sub getannounce { |
| |
|
| if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) { |
if (open(my $fh,"<",$perlvar{'lonDocRoot'}.'/announcement.txt')) { |
| my $announcement=''; |
my $announcement=''; |
| while (my $line = <$fh>) { $announcement .= $line; } |
while (my $line = <$fh>) { $announcement .= $line; } |
| close($fh); |
close($fh); |
|
Line 2103 sub getannounce {
|
Line 5599 sub getannounce {
|
| # |
# |
| |
|
| sub courseidput { |
sub courseidput { |
| my ($domain,$what,$coursehome)=@_; |
my ($domain,$storehash,$coursehome,$caller) = @_; |
| return &reply('courseidput:'.$domain.':'.$what,$coursehome); |
return unless (ref($storehash) eq 'HASH'); |
| |
my $outcome; |
| |
if ($caller eq 'timeonly') { |
| |
my $cids = ''; |
| |
foreach my $item (keys(%$storehash)) { |
| |
$cids.=&escape($item).'&'; |
| |
} |
| |
$cids=~s/\&$//; |
| |
$outcome = &reply('courseidputhash:'.$domain.':'.$caller.':'.$cids, |
| |
$coursehome); |
| |
} else { |
| |
my $items = ''; |
| |
foreach my $item (keys(%$storehash)) { |
| |
$items.= &escape($item).'='. |
| |
&freeze_escape($$storehash{$item}).'&'; |
| |
} |
| |
$items=~s/\&$//; |
| |
$outcome = &reply('courseidputhash:'.$domain.':'.$caller.':'.$items, |
| |
$coursehome); |
| |
} |
| |
if ($outcome eq 'unknown_cmd') { |
| |
my $what; |
| |
foreach my $cid (keys(%$storehash)) { |
| |
$what .= &escape($cid).'='; |
| |
foreach my $item ('description','inst_code','owner','type') { |
| |
$what .= &escape($storehash->{$cid}{$item}).':'; |
| |
} |
| |
$what =~ s/\:$/&/; |
| |
} |
| |
$what =~ s/\&$//; |
| |
return &reply('courseidput:'.$domain.':'.$what,$coursehome); |
| |
} else { |
| |
return $outcome; |
| |
} |
| } |
} |
| |
|
| sub courseiddump { |
sub courseiddump { |
| my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_; |
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter, |
| my %returnhash=(); |
$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok, |
| unless ($domfilter) { $domfilter=''; } |
$selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone, |
| foreach my $tryserver (keys %libserv) { |
$cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner, |
| if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) || (!defined($hostidflag)) ) { |
$hasuniquecode,$reqcrsdom,$reqinstcode)=@_; |
| if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) { |
my $as_hash = 1; |
| foreach my $line ( |
my %returnhash; |
| split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'. |
if (!$domfilter) { $domfilter=''; } |
| $sincefilter.':'.&escape($descfilter).':'. |
my %libserv = &all_library(); |
| &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter).':'.&escape($regexp_ok), |
foreach my $tryserver (keys(%libserv)) { |
| $tryserver))) { |
if ( ( $hostidflag == 1 |
| my ($key,$value)=split(/\=/,$line,2); |
&& grep(/^\Q$tryserver\E$/,@{$hostidref}) ) |
| if (($key) && ($value)) { |
|| (!defined($hostidflag)) ) { |
| $returnhash{&unescape($key)}=$value; |
|
| |
if (($domfilter eq '') || |
| |
(&host_domain($tryserver) eq $domfilter)) { |
| |
my $rep; |
| |
if (grep { $_ eq $tryserver } current_machine_ids()) { |
| |
$rep = LONCAPA::Lond::dump_course_id_handler( |
| |
join(":", (&host_domain($tryserver), $sincefilter, |
| |
&escape($descfilter), &escape($instcodefilter), |
| |
&escape($ownerfilter), &escape($coursefilter), |
| |
&escape($typefilter), &escape($regexp_ok), |
| |
$as_hash, &escape($selfenrollonly), |
| |
&escape($catfilter), $showhidden, $caller, |
| |
&escape($cloner), &escape($cc_clone), $cloneonly, |
| |
&escape($createdbefore), &escape($createdafter), |
| |
&escape($creationcontext),$domcloner,$hasuniquecode, |
| |
$reqcrsdom,&escape($reqinstcode)))); |
| |
} else { |
| |
$rep = &reply('courseiddump:'.&host_domain($tryserver).':'. |
| |
$sincefilter.':'.&escape($descfilter).':'. |
| |
&escape($instcodefilter).':'.&escape($ownerfilter). |
| |
':'.&escape($coursefilter).':'.&escape($typefilter). |
| |
':'.&escape($regexp_ok).':'.$as_hash.':'. |
| |
&escape($selfenrollonly).':'.&escape($catfilter).':'. |
| |
$showhidden.':'.$caller.':'.&escape($cloner).':'. |
| |
&escape($cc_clone).':'.$cloneonly.':'. |
| |
&escape($createdbefore).':'.&escape($createdafter).':'. |
| |
&escape($creationcontext).':'.$domcloner.':'.$hasuniquecode. |
| |
':'.$reqcrsdom.':'.&escape($reqinstcode),$tryserver); |
| |
} |
| |
|
| |
my @pairs=split(/\&/,$rep); |
| |
foreach my $item (@pairs) { |
| |
my ($key,$value)=split(/\=/,$item,2); |
| |
$key = &unescape($key); |
| |
next if ($key =~ /^error: 2 /); |
| |
my $result = &thaw_unescape($value); |
| |
if (ref($result) eq 'HASH') { |
| |
$returnhash{$key}=$result; |
| |
} else { |
| |
my @responses = split(/:/,$value); |
| |
my @items = ('description','inst_code','owner','type'); |
| |
for (my $i=0; $i<@responses; $i++) { |
| |
$returnhash{$key}{$items[$i]} = &unescape($responses[$i]); |
| |
} |
| } |
} |
| } |
} |
| } |
} |
|
Line 2130 sub courseiddump {
|
Line 5702 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 2143 sub dcmailput {
|
Line 5758 sub dcmailput {
|
| sub dcmaildump { |
sub dcmaildump { |
| my ($dom,$startdate,$enddate,$senders) = @_; |
my ($dom,$startdate,$enddate,$senders) = @_; |
| my %returnhash=(); |
my %returnhash=(); |
| if (exists($domain_primary{$dom})) { |
|
| |
if (defined(&domain($dom,'primary'))) { |
| my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'. |
my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'. |
| &escape($enddate).':'; |
&escape($enddate).':'; |
| my @esc_senders=map { &escape($_)} @$senders; |
my @esc_senders=map { &escape($_)} @$senders; |
| $cmd.=&escape(join('&',@esc_senders)); |
$cmd.=&escape(join('&',@esc_senders)); |
| foreach my $line (split(/\&/,&reply($cmd,$domain_primary{$dom}))) { |
foreach my $line (split(/\&/,&reply($cmd,&domain($dom,'primary')))) { |
| my ($key,$value) = split(/\=/,$line,2); |
my ($key,$value) = split(/\=/,$line,2); |
| if (($key) && ($value)) { |
if (($key) && ($value)) { |
| $returnhash{&unescape($key)} = &unescape($value); |
$returnhash{&unescape($key)} = &unescape($value); |
|
Line 2161 sub dcmaildump {
|
Line 5777 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 = join(':',@{$roles}); |
my $rolelist; |
| |
if (ref($roles) eq 'ARRAY') { |
| |
$rolelist = join('&',@{$roles}); |
| |
} |
| my %personnel = (); |
my %personnel = (); |
| foreach my $tryserver (keys(%libserv)) { |
|
| if ($hostdom{$tryserver} eq $dom) { |
my %servers = &get_servers($dom,'library'); |
| %{$personnel{$tryserver}}=(); |
foreach my $tryserver (keys(%servers)) { |
| foreach my $line ( |
%{$personnel{$tryserver}}=(); |
| split(/\&/,&reply('domrolesdump:'.$dom.':'. |
foreach my $line (split(/\&/,&reply('domrolesdump:'.$dom.':'. |
| &escape($startdate).':'.&escape($enddate).':'. |
&escape($startdate).':'. |
| &escape($rolelist), $tryserver))) { |
&escape($enddate).':'. |
| my ($key,$value) = split(/\=/,$line,2); |
&escape($rolelist), $tryserver))) { |
| if (($key) && ($value)) { |
my ($key,$value) = split(/\=/,$line,2); |
| $personnel{$tryserver}{&unescape($key)} = &unescape($value); |
if (($key) && ($value)) { |
| } |
$personnel{$tryserver}{&unescape($key)} = &unescape($value); |
| } |
} |
| } |
} |
| } |
} |
| return %personnel; |
return %personnel; |
| } |
} |
| |
|
| # ----------------------------------------------------------- Check out an item |
sub get_active_domroles { |
| |
my ($dom,$roles) = @_; |
| |
return () unless (ref($roles) eq 'ARRAY'); |
| |
my $now = time; |
| |
my %dompersonnel = &get_domain_roles($dom,$roles,$now,$now); |
| |
my %domroles; |
| |
foreach my $server (keys(%dompersonnel)) { |
| |
foreach my $user (sort(keys(%{$dompersonnel{$server}}))) { |
| |
my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,$user); |
| |
$domroles{$uname.':'.$udom} = $dompersonnel{$server}{$user}; |
| |
} |
| |
} |
| |
return %domroles; |
| |
} |
| |
|
| |
# ----------------------------------------------------------- Interval timing |
| |
|
| |
{ |
| |
# Caches needed for speedup of navmaps |
| |
# We don't want to cache this for very long at all (5 seconds at most) |
| |
# |
| |
# The user for whom we cache |
| |
my $cachedkey=''; |
| |
# The cached times for this user |
| |
my %cachedtimes=(); |
| |
# When this was last done |
| |
my $cachedtime=''; |
| |
|
| |
sub load_all_first_access { |
| |
my ($uname,$udom,$ignorecache)=@_; |
| |
if (($cachedkey eq $uname.':'.$udom) && |
| |
(abs($cachedtime-time)<5) && (!$env{'form.markaccess'}) && |
| |
(!$ignorecache)) { |
| |
return; |
| |
} |
| |
$cachedtime=time; |
| |
$cachedkey=$uname.':'.$udom; |
| |
%cachedtimes=&dump('firstaccesstimes',$udom,$uname); |
| |
} |
| |
|
| sub get_first_access { |
sub get_first_access { |
| my ($type,$argsymb)=@_; |
my ($type,$argsymb,$argmap,$ignorecache)=@_; |
| my ($symb,$courseid,$udom,$uname)=&whichuser(); |
my ($symb,$courseid,$udom,$uname)=&whichuser(); |
| if ($argsymb) { $symb=$argsymb; } |
if ($argsymb) { $symb=$argsymb; } |
| my ($map,$id,$res)=&decode_symb($symb); |
my ($map,$id,$res)=&decode_symb($symb); |
| if ($type eq 'map') { |
if ($argmap) { $map = $argmap; } |
| |
if ($type eq 'course') { |
| |
$res='course'; |
| |
} elsif ($type eq 'map') { |
| $res=&symbread($map); |
$res=&symbread($map); |
| } else { |
} else { |
| $res=$symb; |
$res=$symb; |
| } |
} |
| my %times=&get('firstaccesstimes',["$courseid\0$res"],$udom,$uname); |
&load_all_first_access($uname,$udom,$ignorecache); |
| return $times{"$courseid\0$res"}; |
return $cachedtimes{"$courseid\0$res"}; |
| } |
} |
| |
|
| sub set_first_access { |
sub set_first_access { |
| my ($type)=@_; |
my ($type,$interval)=@_; |
| my ($symb,$courseid,$udom,$uname)=&whichuser(); |
my ($symb,$courseid,$udom,$uname)=&whichuser(); |
| my ($map,$id,$res)=&decode_symb($symb); |
my ($map,$id,$res)=&decode_symb($symb); |
| if ($type eq 'map') { |
if ($type eq 'course') { |
| |
$res='course'; |
| |
} elsif ($type eq 'map') { |
| $res=&symbread($map); |
$res=&symbread($map); |
| } else { |
} else { |
| $res=$symb; |
$res=$symb; |
| } |
} |
| my $firstaccess=&get_first_access($type,$symb); |
$cachedkey=''; |
| if (!$firstaccess) { |
my $firstaccess=&get_first_access($type,$symb,$map); |
| return &put('firstaccesstimes',{"$courseid\0$res"=>time},$udom,$uname); |
if ($firstaccess) { |
| |
&logthis("First access time already set ($firstaccess) when attempting ". |
| |
"to set new value (type: $type, extent: $res) for $uname:$udom ". |
| |
"in $courseid"); |
| |
return 'already_set'; |
| |
} else { |
| |
my $start = time; |
| |
my $putres = &put('firstaccesstimes',{"$courseid\0$res"=>$start}, |
| |
$udom,$uname); |
| |
if ($putres eq 'ok') { |
| |
&put('timerinterval',{"$courseid\0$res"=>$interval}, |
| |
$udom,$uname); |
| |
&appenv( |
| |
{ |
| |
'course.'.$courseid.'.firstaccess.'.$res => $start, |
| |
'course.'.$courseid.'.timerinterval.'.$res => $interval, |
| |
} |
| |
); |
| |
if (($cachedtime) && (abs($start-$cachedtime) < 5)) { |
| |
$cachedtimes{"$courseid\0$res"} = $start; |
| |
} |
| |
} elsif ($putres ne 'refused') { |
| |
&logthis("Result: $putres when attempting to set first access time ". |
| |
"(type: $type, extent: $res) for $uname:$udom in $courseid"); |
| |
} |
| |
return $putres; |
| } |
} |
| 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 |
|
Line 2407 sub hashref2str {
|
Line 6010 sub hashref2str {
|
| $result.='='; |
$result.='='; |
| #print("Got a ref of ".(ref($key))." skipping."); |
#print("Got a ref of ".(ref($key))." skipping."); |
| } else { |
} else { |
| if ($key) {$result.=&escape($key).'=';} else { last; } |
if (defined($key)) {$result.=&escape($key).'=';} else { last; } |
| } |
} |
| |
|
| if(ref($hashref->{$key}) eq 'ARRAY') { |
if(ref($hashref->{$key}) eq 'ARRAY') { |
|
Line 2557 sub tmpreset {
|
Line 6160 sub tmpreset {
|
| if (!$domain) { $domain=$env{'user.domain'}; } |
if (!$domain) { $domain=$env{'user.domain'}; } |
| if (!$stuname) { $stuname=$env{'user.name'}; } |
if (!$stuname) { $stuname=$env{'user.name'}; } |
| if ($domain eq 'public' && $stuname eq 'public') { |
if ($domain eq 'public' && $stuname eq 'public') { |
| $stuname=$ENV{'REMOTE_ADDR'}; |
$stuname=&get_requestor_ip(); |
| } |
} |
| my $path=$perlvar{'lonDaemons'}.'/tmp'; |
my $path=LONCAPA::tempdir(); |
| my %hash; |
my %hash; |
| 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 2594 sub tmpstore {
|
Line 6197 sub tmpstore {
|
| if (!$domain) { $domain=$env{'user.domain'}; } |
if (!$domain) { $domain=$env{'user.domain'}; } |
| if (!$stuname) { $stuname=$env{'user.name'}; } |
if (!$stuname) { $stuname=$env{'user.name'}; } |
| if ($domain eq 'public' && $stuname eq 'public') { |
if ($domain eq 'public' && $stuname eq 'public') { |
| $stuname=$ENV{'REMOTE_ADDR'}; |
$stuname=&get_requestor_ip(); |
| } |
} |
| my $now=time; |
my $now=time; |
| my %hash; |
my %hash; |
| my $path=$perlvar{'lonDaemons'}.'/tmp'; |
my $path=LONCAPA::tempdir(); |
| 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)) { |
|
Line 2638 sub tmprestore {
|
Line 6241 sub tmprestore {
|
| if (!$domain) { $domain=$env{'user.domain'}; } |
if (!$domain) { $domain=$env{'user.domain'}; } |
| if (!$stuname) { $stuname=$env{'user.name'}; } |
if (!$stuname) { $stuname=$env{'user.name'}; } |
| if ($domain eq 'public' && $stuname eq 'public') { |
if ($domain eq 'public' && $stuname eq 'public') { |
| $stuname=$ENV{'REMOTE_ADDR'}; |
$stuname=&get_requestor_ip(); |
| } |
} |
| my %returnhash; |
my %returnhash; |
| $namespace=~s/\//\_/g; |
$namespace=~s/\//\_/g; |
| $namespace=~s/\W//g; |
$namespace=~s/\W//g; |
| my %hash; |
my %hash; |
| my $path=$perlvar{'lonDaemons'}.'/tmp'; |
my $path=LONCAPA::tempdir(); |
| if (tie(%hash,'GDBM_File', |
if (tie(%hash,'GDBM_File', |
| $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', |
$path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', |
| &GDBM_READER(),0640)) { |
&GDBM_READER(),0640)) { |
|
Line 2673 sub tmprestore {
|
Line 6276 sub tmprestore {
|
| # ----------------------------------------------------------------------- Store |
# ----------------------------------------------------------------------- Store |
| |
|
| sub store { |
sub store { |
| my ($storehash,$symb,$namespace,$domain,$stuname) = @_; |
my ($storehash,$symb,$namespace,$domain,$stuname,$laststore) = @_; |
| my $home=''; |
my $home=''; |
| |
|
| if ($stuname) { $home=&homeserver($stuname,$domain); } |
if ($stuname) { $home=&homeserver($stuname,$domain); } |
|
Line 2694 sub store {
|
Line 6297 sub store {
|
| } |
} |
| if (!$home) { $home=$env{'user.home'}; } |
if (!$home) { $home=$env{'user.home'}; } |
| |
|
| $$storehash{'ip'}=$ENV{'REMOTE_ADDR'}; |
$$storehash{'ip'}=&get_requestor_ip(); |
| $$storehash{'host'}=$perlvar{'lonHostID'}; |
$$storehash{'host'}=$perlvar{'lonHostID'}; |
| |
|
| my $namevalue=''; |
my $namevalue=''; |
|
Line 2703 sub store {
|
Line 6306 sub store {
|
| } |
} |
| $namevalue=~s/\&$//; |
$namevalue=~s/\&$//; |
| &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue); |
&courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue); |
| return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home"); |
return reply("store:$domain:$stuname:$namespace:$symb:$namevalue:$laststore","$home"); |
| } |
} |
| |
|
| # -------------------------------------------------------------- Critical Store |
# -------------------------------------------------------------- Critical Store |
| |
|
| sub cstore { |
sub cstore { |
| my ($storehash,$symb,$namespace,$domain,$stuname) = @_; |
my ($storehash,$symb,$namespace,$domain,$stuname,$laststore) = @_; |
| my $home=''; |
my $home=''; |
| |
|
| if ($stuname) { $home=&homeserver($stuname,$domain); } |
if ($stuname) { $home=&homeserver($stuname,$domain); } |
|
Line 2730 sub cstore {
|
Line 6333 sub cstore {
|
| } |
} |
| if (!$home) { $home=$env{'user.home'}; } |
if (!$home) { $home=$env{'user.home'}; } |
| |
|
| $$storehash{'ip'}=$ENV{'REMOTE_ADDR'}; |
$$storehash{'ip'}=&get_requestor_ip(); |
| $$storehash{'host'}=$perlvar{'lonHostID'}; |
$$storehash{'host'}=$perlvar{'lonHostID'}; |
| |
|
| my $namevalue=''; |
my $namevalue=''; |
|
Line 2740 sub cstore {
|
Line 6343 sub cstore {
|
| $namevalue=~s/\&$//; |
$namevalue=~s/\&$//; |
| &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue); |
&courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue); |
| return critical |
return critical |
| ("store:$domain:$stuname:$namespace:$symb:$namevalue","$home"); |
("store:$domain:$stuname:$namespace:$symb:$namevalue:$laststore","$home"); |
| } |
} |
| |
|
| # --------------------------------------------------------------------- Restore |
# --------------------------------------------------------------------- Restore |
|
Line 2752 sub restore {
|
Line 6355 sub restore {
|
| if ($stuname) { $home=&homeserver($stuname,$domain); } |
if ($stuname) { $home=&homeserver($stuname,$domain); } |
| |
|
| if (!$symb) { |
if (!$symb) { |
| unless ($symb=escape(&symbread())) { return ''; } |
return if ($namespace eq 'courserequests'); |
| |
unless ($symb=escape(&symbread())) { return ''; } |
| } else { |
} else { |
| $symb=&escape(&symbclean($symb)); |
unless ($namespace eq 'courserequests') { |
| |
$symb=&escape(&symbclean($symb)); |
| |
} |
| } |
} |
| if (!$namespace) { |
if (!$namespace) { |
| unless ($namespace=$env{'request.course.id'}) { |
unless ($namespace=$env{'request.course.id'}) { |
|
Line 2781 sub restore {
|
Line 6387 sub restore {
|
| } |
} |
| |
|
| # ---------------------------------------------------------- Course Description |
# ---------------------------------------------------------- Course Description |
| |
# |
| |
# |
| |
|
| sub coursedescription { |
sub coursedescription { |
| my ($courseid,$args)=@_; |
my ($courseid,$args)=@_; |
|
Line 2810 sub coursedescription {
|
Line 6418 sub coursedescription {
|
| return %returnhash; |
return %returnhash; |
| } |
} |
| |
|
| # get the data agin |
# get the data again |
| |
|
| if (!$args->{'one_time'}) { |
if (!$args->{'one_time'}) { |
| $envhash{'course.'.$normalid.'.last_cache'}=time; |
$envhash{'course.'.$normalid.'.last_cache'}=time; |
| } |
} |
|
Line 2818 sub coursedescription {
|
Line 6427 sub coursedescription {
|
| if ($chome ne 'no_host') { |
if ($chome ne 'no_host') { |
| %returnhash=&dump('environment',$cdomain,$cnum); |
%returnhash=&dump('environment',$cdomain,$cnum); |
| if (!exists($returnhash{'con_lost'})) { |
if (!exists($returnhash{'con_lost'})) { |
| |
my $username = $env{'user.name'}; # Defult username |
| |
if(defined $args->{'user'}) { |
| |
$username = $args->{'user'}; |
| |
} |
| $returnhash{'home'}= $chome; |
$returnhash{'home'}= $chome; |
| $returnhash{'domain'} = $cdomain; |
$returnhash{'domain'} = $cdomain; |
| $returnhash{'num'} = $cnum; |
$returnhash{'num'} = $cnum; |
|
Line 2828 sub coursedescription {
|
Line 6441 sub coursedescription {
|
| $envhash{'course.'.$normalid.'.'.$name}=$value; |
$envhash{'course.'.$normalid.'.'.$name}=$value; |
| } |
} |
| $returnhash{'url'}=&clutter($returnhash{'url'}); |
$returnhash{'url'}=&clutter($returnhash{'url'}); |
| $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'. |
$returnhash{'fn'}=LONCAPA::tempdir() . |
| $env{'user.name'}.'_'.$cdomain.'_'.$cnum; |
$username.'_'.$cdomain.'_'.$cnum; |
| $envhash{'course.'.$normalid.'.home'}=$chome; |
$envhash{'course.'.$normalid.'.home'}=$chome; |
| $envhash{'course.'.$normalid.'.domain'}=$cdomain; |
$envhash{'course.'.$normalid.'.domain'}=$cdomain; |
| $envhash{'course.'.$normalid.'.num'}=$cnum; |
$envhash{'course.'.$normalid.'.num'}=$cnum; |
| } |
} |
| } |
} |
| if (!$args->{'one_time'}) { |
if (!$args->{'one_time'}) { |
| &appenv(%envhash); |
&appenv(\%envhash); |
| } |
} |
| return %returnhash; |
return %returnhash; |
| } |
} |
| |
|
| |
sub update_released_required { |
| |
my ($needsrelease,$cdom,$cnum,$chome,$cid) = @_; |
| |
if ($cdom eq '' || $cnum eq '' || $chome eq '' || $cid eq '') { |
| |
$cid = $env{'request.course.id'}; |
| |
$cdom = $env{'course.'.$cid.'.domain'}; |
| |
$cnum = $env{'course.'.$cid.'.num'}; |
| |
$chome = $env{'course.'.$cid.'.home'}; |
| |
} |
| |
if ($needsrelease) { |
| |
my %curr_reqd_hash = &userenvironment($cdom,$cnum,'internal.releaserequired'); |
| |
my $needsupdate; |
| |
if ($curr_reqd_hash{'internal.releaserequired'} eq '') { |
| |
$needsupdate = 1; |
| |
} else { |
| |
my ($currmajor,$currminor) = split(/\./,$curr_reqd_hash{'internal.releaserequired'}); |
| |
my ($needsmajor,$needsminor) = split(/\./,$needsrelease); |
| |
if (($currmajor < $needsmajor) || ($currmajor == $needsmajor && $currminor < $needsminor)) { |
| |
$needsupdate = 1; |
| |
} |
| |
} |
| |
if ($needsupdate) { |
| |
my %needshash = ( |
| |
'internal.releaserequired' => $needsrelease, |
| |
); |
| |
my $putresult = &put('environment',\%needshash,$cdom,$cnum); |
| |
if ($putresult eq 'ok') { |
| |
&appenv({'course.'.$cid.'.internal.releaserequired' => $needsrelease}); |
| |
my %crsinfo = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.'); |
| |
if (ref($crsinfo{$cid}) eq 'HASH') { |
| |
$crsinfo{$cid}{'releaserequired'} = $needsrelease; |
| |
&courseidput($cdom,\%crsinfo,$chome,'notime'); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| # -------------------------------------------------See if a user is privileged |
# -------------------------------------------------See if a user is privileged |
| |
|
| sub privileged { |
sub privileged { |
| my ($username,$domain)=@_; |
my ($username,$domain,$possdomains,$possroles)=@_; |
| my $rolesdump=&reply("dump:$domain:$username:roles", |
my $now = time; |
| &homeserver($username,$domain)); |
my $roles; |
| if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return 0; } |
if (ref($possroles) eq 'ARRAY') { |
| my $now=time; |
$roles = $possroles; |
| if ($rolesdump ne '') { |
} else { |
| foreach my $entry (split(/&/,$rolesdump)) { |
$roles = ['dc','su']; |
| if ($entry!~/^rolesdef_/) { |
} |
| my ($area,$role)=split(/=/,$entry); |
if (ref($possdomains) eq 'ARRAY') { |
| $area=~s/\_\w\w$//; |
my %privileged = &privileged_by_domain($possdomains,$roles); |
| my ($trole,$tend,$tstart)=split(/_/,$role); |
foreach my $dom (@{$possdomains}) { |
| if (($trole eq 'dc') || ($trole eq 'su')) { |
if (($username =~ /^$match_username$/) && ($domain =~ /^$match_domain$/) && |
| my $active=1; |
(ref($privileged{$dom}) eq 'HASH')) { |
| if ($tend) { |
foreach my $role (@{$roles}) { |
| if ($tend<$now) { $active=0; } |
if (ref($privileged{$dom}{$role}) eq 'HASH') { |
| } |
if (exists($privileged{$dom}{$role}{$username.':'.$domain})) { |
| if ($tstart) { |
my ($end,$start) = split(/:/,$privileged{$dom}{$role}{$username.':'.$domain}); |
| if ($tstart>$now) { $active=0; } |
return 1 unless (($end && $end < $now) || |
| } |
($start && $start > $now)); |
| if ($active) { return 1; } |
} |
| } |
} |
| } |
} |
| } |
} |
| |
} |
| |
} else { |
| |
my %rolesdump = &dump("roles", $domain, $username) or return 0; |
| |
my $now = time; |
| |
|
| |
for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys(%rolesdump)}) { |
| |
my ($trole, $tend, $tstart) = split(/_/, $role); |
| |
if (grep(/^\Q$trole\E$/,@{$roles})) { |
| |
return 1 unless ($tend && $tend < $now) |
| |
or ($tstart && $tstart > $now); |
| |
} |
| |
} |
| } |
} |
| return 0; |
return 0; |
| } |
} |
| |
|
| |
sub privileged_by_domain { |
| |
my ($domains,$roles) = @_; |
| |
my %privileged = (); |
| |
my $cachetime = 60*60*24; |
| |
my $now = time; |
| |
unless ((ref($domains) eq 'ARRAY') && (ref($roles) eq 'ARRAY')) { |
| |
return %privileged; |
| |
} |
| |
foreach my $dom (@{$domains}) { |
| |
next if (ref($privileged{$dom}) eq 'HASH'); |
| |
my $needroles; |
| |
foreach my $role (@{$roles}) { |
| |
my ($result,$cached)=&is_cached_new('priv_'.$role,$dom); |
| |
if (defined($cached)) { |
| |
if (ref($result) eq 'HASH') { |
| |
$privileged{$dom}{$role} = $result; |
| |
} |
| |
} else { |
| |
$needroles = 1; |
| |
} |
| |
} |
| |
if ($needroles) { |
| |
my %dompersonnel = &get_domain_roles($dom,$roles); |
| |
$privileged{$dom} = {}; |
| |
foreach my $server (keys(%dompersonnel)) { |
| |
if (ref($dompersonnel{$server}) eq 'HASH') { |
| |
foreach my $item (keys(%{$dompersonnel{$server}})) { |
| |
my ($trole,$uname,$udom,$rest) = split(/:/,$item,4); |
| |
my ($end,$start) = split(/:/,$dompersonnel{$server}{$item}); |
| |
next if ($end && $end < $now); |
| |
$privileged{$dom}{$trole}{$uname.':'.$udom} = |
| |
$dompersonnel{$server}{$item}; |
| |
} |
| |
} |
| |
} |
| |
if (ref($privileged{$dom}) eq 'HASH') { |
| |
foreach my $role (@{$roles}) { |
| |
if (ref($privileged{$dom}{$role}) eq 'HASH') { |
| |
&do_cache_new('priv_'.$role,$dom,$privileged{$dom}{$role},$cachetime); |
| |
} else { |
| |
my %hash = (); |
| |
&do_cache_new('priv_'.$role,$dom,\%hash,$cachetime); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return %privileged; |
| |
} |
| |
|
| # -------------------------------------------------------- Get user privileges |
# -------------------------------------------------------- Get user privileges |
| |
|
| sub rolesinit { |
sub rolesinit { |
| my ($domain,$username,$authhost)=@_; |
my ($domain, $username) = @_; |
| my $rolesdump=reply("dump:$domain:$username:roles",$authhost); |
my %userroles = ('user.login.time' => time); |
| if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; } |
my %rolesdump = &dump("roles", $domain, $username) or return \%userroles; |
| |
|
| |
# firstaccess and timerinterval are related to timed maps/resources. |
| |
# also, blocking can be triggered by an activating timer |
| |
# it's saved in the user's %env. |
| |
my %firstaccess = &dump('firstaccesstimes', $domain, $username); |
| |
my %timerinterval = &dump('timerinterval', $domain, $username); |
| |
my (%coursetimerstarts, %firstaccchk, %firstaccenv, %coursetimerintervals, |
| |
%timerintchk, %timerintenv); |
| |
|
| |
foreach my $key (keys(%firstaccess)) { |
| |
my ($cid, $rest) = split(/\0/, $key); |
| |
$coursetimerstarts{$cid}{$rest} = $firstaccess{$key}; |
| |
} |
| |
|
| |
foreach my $key (keys(%timerinterval)) { |
| |
my ($cid,$rest) = split(/\0/,$key); |
| |
$coursetimerintervals{$cid}{$rest} = $timerinterval{$key}; |
| |
} |
| |
|
| my %allroles=(); |
my %allroles=(); |
| my %allgroups=(); |
my %allgroups=(); |
| my $now=time; |
|
| my %userroles = ('user.login.time' => $now); |
|
| my $group_privs; |
|
| |
|
| if ($rolesdump ne '') { |
for my $area (grep { ! /^rolesdef_/ } keys(%rolesdump)) { |
| foreach my $entry (split(/&/,$rolesdump)) { |
my $role = $rolesdump{$area}; |
| if ($entry!~/^rolesdef_/) { |
$area =~ s/\_\w\w$//; |
| my ($area,$role)=split(/=/,$entry); |
|
| $area=~s/\_\w\w$//; |
my ($trole, $tend, $tstart, $group_privs); |
| my ($trole,$tend,$tstart,$group_privs); |
|
| if ($role=~/^cr/) { |
if ($role =~ /^cr/) { |
| if ($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) { |
# Custom role, defined by a user |
| ($trole,my $trest)=($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|); |
# e.g., user.role.cr/msu/smith/mynewrole |
| ($tend,$tstart)=split('_',$trest); |
if ($role =~ m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) { |
| } else { |
$trole = $1; |
| $trole=$role; |
($tend, $tstart) = split('_', $2); |
| } |
} else { |
| } elsif ($role =~ m|^gr/|) { |
$trole = $role; |
| ($trole,$tend,$tstart) = split(/_/,$role); |
|
| ($trole,$group_privs) = split(/\//,$trole); |
|
| $group_privs = &unescape($group_privs); |
|
| } else { |
|
| ($trole,$tend,$tstart)=split(/_/,$role); |
|
| } |
|
| my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain, |
|
| $username); |
|
| @userroles{keys(%new_role)} = @new_role{keys(%new_role)}; |
|
| if (($tend!=0) && ($tend<$now)) { $trole=''; } |
|
| if (($tstart!=0) && ($tstart>$now)) { $trole=''; } |
|
| if (($area ne '') && ($trole ne '')) { |
|
| my $spec=$trole.'.'.$area; |
|
| my ($tdummy,$tdomain,$trest)=split(/\//,$area); |
|
| if ($trole =~ /^cr\//) { |
|
| &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area); |
|
| } elsif ($trole eq 'gr') { |
|
| &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart); |
|
| } else { |
|
| &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area); |
|
| } |
|
| } |
} |
| } |
} elsif ($role =~ m|^gr/|) { |
| |
# Role of member in a group, defined within a course/community |
| |
# e.g., user.role.gr/msu/04935610a19ee4a5fmsul1/leopards |
| |
($trole, $tend, $tstart) = split(/_/, $role); |
| |
next if $tstart eq '-1'; |
| |
($trole, $group_privs) = split(/\//, $trole); |
| |
$group_privs = &unescape($group_privs); |
| |
} else { |
| |
# Just a normal role, defined in roles.tab |
| |
($trole, $tend, $tstart) = split(/_/,$role); |
| |
} |
| |
|
| |
my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain, |
| |
$username); |
| |
@userroles{keys(%new_role)} = @new_role{keys(%new_role)}; |
| |
|
| |
# role expired or not available yet? |
| |
$trole = '' if ($tend != 0 && $tend < $userroles{'user.login.time'}) or |
| |
($tstart != 0 && $tstart > $userroles{'user.login.time'}); |
| |
|
| |
next if $area eq '' or $trole eq ''; |
| |
|
| |
my $spec = "$trole.$area"; |
| |
my ($tdummy, $tdomain, $trest) = split(/\//, $area); |
| |
|
| |
if ($trole =~ /^cr\//) { |
| |
# Custom role, defined by a user |
| |
&custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area); |
| |
} elsif ($trole eq 'gr') { |
| |
# Role of a member in a group, defined within a course/community |
| |
&group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart); |
| |
next; |
| |
} else { |
| |
# Normal role, defined in roles.tab |
| |
&standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area); |
| |
} |
| |
|
| |
my $cid = $tdomain.'_'.$trest; |
| |
unless ($firstaccchk{$cid}) { |
| |
if (ref($coursetimerstarts{$cid}) eq 'HASH') { |
| |
foreach my $item (keys(%{$coursetimerstarts{$cid}})) { |
| |
$firstaccenv{'course.'.$cid.'.firstaccess.'.$item} = |
| |
$coursetimerstarts{$cid}{$item}; |
| |
} |
| |
} |
| |
$firstaccchk{$cid} = 1; |
| |
} |
| |
unless ($timerintchk{$cid}) { |
| |
if (ref($coursetimerintervals{$cid}) eq 'HASH') { |
| |
foreach my $item (keys(%{$coursetimerintervals{$cid}})) { |
| |
$timerintenv{'course.'.$cid.'.timerinterval.'.$item} = |
| |
$coursetimerintervals{$cid}{$item}; |
| |
} |
| |
} |
| |
$timerintchk{$cid} = 1; |
| } |
} |
| my ($author,$adv) = &set_userprivs(\%userroles,\%allroles,\%allgroups); |
|
| $userroles{'user.adv'} = $adv; |
|
| $userroles{'user.author'} = $author; |
|
| $env{'user.adv'}=$adv; |
|
| } |
} |
| return \%userroles; |
|
| |
@userroles{'user.author','user.adv','user.rar'} = &set_userprivs(\%userroles, |
| |
\%allroles, \%allgroups); |
| |
$env{'user.adv'} = $userroles{'user.adv'}; |
| |
$env{'user.rar'} = $userroles{'user.rar'}; |
| |
|
| |
return (\%userroles,\%firstaccenv,\%timerintenv); |
| } |
} |
| |
|
| sub set_arearole { |
sub set_arearole { |
| my ($trole,$area,$tstart,$tend,$domain,$username) = @_; |
my ($trole,$area,$tstart,$tend,$domain,$username,$nolog) = @_; |
| |
unless ($nolog) { |
| # log the associated role with the area |
# log the associated role with the area |
| &userrolelog($trole,$username,$domain,$area,$tstart,$tend); |
&userrolelog($trole,$username,$domain,$area,$tstart,$tend); |
| |
} |
| return ('user.role.'.$trole.'.'.$area => $tstart.'.'.$tend); |
return ('user.role.'.$trole.'.'.$area => $tstart.'.'.$tend); |
| } |
} |
| |
|
| sub custom_roleprivs { |
sub custom_roleprivs { |
| my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_; |
my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_; |
| my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole); |
my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole); |
| my $homsvr=homeserver($rauthor,$rdomain); |
my $homsvr = &homeserver($rauthor,$rdomain); |
| if ($hostname{$homsvr} ne '') { |
if (&hostname($homsvr) ne '') { |
| my ($rdummy,$roledef)= |
my ($rdummy,$roledef)= |
| &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor); |
&get('roles',["rolesdef_$rrole"],$rdomain,$rauthor); |
| 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 2955 sub custom_roleprivs {
|
Line 6724 sub custom_roleprivs {
|
| $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv; |
$$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv; |
| } |
} |
| if (($trest ne '') && (defined($coursepriv))) { |
if (($trest ne '') && (defined($coursepriv))) { |
| |
if ($trole =~ m{^cr/$tdomain/$tdomain\Q-domainconfig\E/([^/]+)$}) { |
| |
my $rolename = $1; |
| |
$coursepriv = &course_adhocrole_privs($rolename,$tdomain,$trest,$coursepriv); |
| |
} |
| $$allroles{'cm.'.$area}.=':'.$coursepriv; |
$$allroles{'cm.'.$area}.=':'.$coursepriv; |
| $$allroles{$spec.'.'.$area}.=':'.$coursepriv; |
$$allroles{$spec.'.'.$area}.=':'.$coursepriv; |
| } |
} |
|
Line 2963 sub custom_roleprivs {
|
Line 6736 sub custom_roleprivs {
|
| } |
} |
| } |
} |
| |
|
| |
sub course_adhocrole_privs { |
| |
my ($rolename,$cdom,$cnum,$coursepriv) = @_; |
| |
my %overrides = &get('environment',["internal.adhocpriv.$rolename"],$cdom,$cnum); |
| |
if ($overrides{"internal.adhocpriv.$rolename"}) { |
| |
my (%currprivs,%storeprivs); |
| |
foreach my $item (split(/:/,$coursepriv)) { |
| |
my ($priv,$restrict) = split(/\&/,$item); |
| |
$currprivs{$priv} = $restrict; |
| |
} |
| |
my (%possadd,%possremove,%full); |
| |
foreach my $item (split(/\:/,$Apache::lonnet::pr{'cr:c'})) { |
| |
my ($priv,$restrict)=split(/\&/,$item); |
| |
$full{$priv} = $restrict; |
| |
} |
| |
foreach my $item (split(/,/,$overrides{"internal.adhocpriv.$rolename"})) { |
| |
next if ($item eq ''); |
| |
my ($rule,$rest) = split(/=/,$item); |
| |
next unless (($rule eq 'off') || ($rule eq 'on')); |
| |
foreach my $priv (split(/:/,$rest)) { |
| |
if ($priv ne '') { |
| |
if ($rule eq 'off') { |
| |
$possremove{$priv} = 1; |
| |
} else { |
| |
$possadd{$priv} = 1; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
foreach my $priv (sort(keys(%full))) { |
| |
if (exists($currprivs{$priv})) { |
| |
unless (exists($possremove{$priv})) { |
| |
$storeprivs{$priv} = $currprivs{$priv}; |
| |
} |
| |
} elsif (exists($possadd{$priv})) { |
| |
$storeprivs{$priv} = $full{$priv}; |
| |
} |
| |
} |
| |
$coursepriv = ':'.join(':',map { $_.'&'.$storeprivs{$_}; } sort(keys(%storeprivs))); |
| |
} |
| |
return $coursepriv; |
| |
} |
| |
|
| sub group_roleprivs { |
sub group_roleprivs { |
| my ($allgroups,$area,$group_privs,$tend,$tstart) = @_; |
my ($allgroups,$area,$group_privs,$tend,$tstart) = @_; |
| my $access = 1; |
my $access = 1; |
|
Line 2994 sub standard_roleprivs {
|
Line 6809 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 $rar=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 3021 sub set_userprivs {
|
Line 6850 sub set_userprivs {
|
| } |
} |
| foreach my $role (keys(%{$allroles})) { |
foreach my $role (keys(%{$allroles})) { |
| my %thesepriv; |
my %thesepriv; |
| if (($role=~/^au/) || ($role=~/^ca/)) { $author=1; } |
if (($role=~/^au/) || ($role=~/^ca/) || ($role=~/^aa/)) { $author=1; } |
| foreach my $item (split(/:/,$$allroles{$role})) { |
foreach my $item (split(/:/,$$allroles{$role})) { |
| if ($item ne '') { |
if ($item ne '') { |
| my ($privilege,$restrictions)=split(/&/,$item); |
my ($privilege,$restrictions)=split(/&/,$item); |
|
Line 3031 sub set_userprivs {
|
Line 6860 sub set_userprivs {
|
| $thesepriv{$privilege}.=$restrictions; |
$thesepriv{$privilege}.=$restrictions; |
| } |
} |
| if ($thesepriv{'adv'} eq 'F') { $adv=1; } |
if ($thesepriv{'adv'} eq 'F') { $adv=1; } |
| |
if ($thesepriv{'rar'} eq 'F') { $rar=1; } |
| } |
} |
| } |
} |
| my $thesestr=''; |
my $thesestr=''; |
| foreach my $priv (keys(%thesepriv)) { |
foreach my $priv (sort(keys(%thesepriv))) { |
| $thesestr.=':'.$priv.'&'.$thesepriv{$priv}; |
$thesestr.=':'.$priv.'&'.$thesepriv{$priv}; |
| } |
} |
| $userroles->{'user.priv.'.$role} = $thesestr; |
$userroles->{'user.priv.'.$role} = $thesestr; |
| } |
} |
| return ($author,$adv); |
return ($author,$adv,$rar); |
| |
} |
| |
|
| |
sub role_status { |
| |
my ($rolekey,$update,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_; |
| |
if (exists($env{$rolekey}) && $env{$rolekey} ne '') { |
| |
my ($one,$two) = split(m{\./},$rolekey,2); |
| |
(undef,undef,$$role) = split(/\./,$one,3); |
| |
unless (!defined($$role) || $$role eq '') { |
| |
$$where = '/'.$two; |
| |
$$trolecode=$$role.'.'.$$where; |
| |
($$tstart,$$tend)=split(/\./,$env{$rolekey}); |
| |
$$tstatus='is'; |
| |
if ($$tstart && $$tstart>$update) { |
| |
$$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); |
| |
&get_groups_roles($tdomain,$trest, |
| |
\%course_roles,\@rolecodes, |
| |
\%groups_roles); |
| |
} else { |
| |
push(@rolecodes,$$role); |
| |
&standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where); |
| |
} |
| |
my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%allroles,\%allgroups, |
| |
\%groups_roles); |
| |
&appenv(\%userroles,\@rolecodes); |
| |
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec); |
| |
} |
| |
} |
| |
$$tstatus = 'is'; |
| |
} |
| |
} |
| |
if ($$tend) { |
| |
if ($$tend<$update) { |
| |
$$tstatus='expired'; |
| |
} elsif ($$tend<$now) { |
| |
$$tstatus='will_not'; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
|
| |
sub get_groups_roles { |
| |
my ($cdom,$rest,$cdom_courseroles,$rolecodes,$groups_roles) = @_; |
| |
return unless((ref($cdom_courseroles) eq 'HASH') && |
| |
(ref($rolecodes) eq 'ARRAY') && |
| |
(ref($groups_roles) eq 'HASH')); |
| |
if (keys(%{$cdom_courseroles}) > 0) { |
| |
my ($cnum) = ($rest =~ /^($match_courseid)/); |
| |
if ($cdom ne '' && $cnum ne '') { |
| |
foreach my $key (keys(%{$cdom_courseroles})) { |
| |
if ($key =~ /^\Q$cnum\E:\Q$cdom\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./$cdom/$cnum"; |
| |
if ($crssec ne '') { |
| |
$rolekey .= "/$crssec"; |
| |
} |
| |
$rolekey .= './'; |
| |
$groups_roles->{$rolekey} = $rolecodes; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| |
sub delete_env_groupprivs { |
| |
my ($where,$courseroles,$possroles) = @_; |
| |
return unless((ref($courseroles) eq 'HASH') && (ref($possroles) eq 'ARRAY')); |
| |
my ($dummy,$udom,$uname,$group) = split(/\//,$where); |
| |
unless (ref($courseroles->{$udom}) eq 'HASH') { |
| |
%{$courseroles->{$udom}} = |
| |
&get_my_roles('','','userroles',['active'], |
| |
$possroles,[$udom],1); |
| |
} |
| |
if (ref($courseroles->{$udom}) eq 'HASH') { |
| |
foreach my $item (keys(%{$courseroles->{$udom}})) { |
| |
my ($cnum,$cdom,$crsrole,$crssec) = split(/:/,$item); |
| |
my $area = '/'.$cdom.'/'.$cnum; |
| |
my $privkey = "user.priv.$crsrole.$area"; |
| |
if ($crssec ne '') { |
| |
$privkey .= '/'.$crssec; |
| |
} |
| |
$privkey .= ".$area/$group"; |
| |
&Apache::lonnet::delenv($privkey,undef,[$crsrole]); |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| |
sub check_adhoc_privs { |
| |
my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller,$sec) = @_; |
| |
my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum; |
| |
if ($sec) { |
| |
$cckey .= '/'.$sec; |
| |
} |
| |
my $setprivs; |
| |
if ($env{$cckey}) { |
| |
my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend); |
| |
&role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend); |
| |
unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) { |
| |
&set_adhoc_privileges($cdom,$cnum,$checkrole,$caller,$sec); |
| |
$setprivs = 1; |
| |
} |
| |
} else { |
| |
&set_adhoc_privileges($cdom,$cnum,$checkrole,$caller,$sec); |
| |
$setprivs = 1; |
| |
} |
| |
return $setprivs; |
| |
} |
| |
|
| |
sub set_adhoc_privileges { |
| |
# role can be cc, ca, or cr/<dom>/<dom>-domainconfig/role |
| |
my ($dcdom,$pickedcourse,$role,$caller,$sec) = @_; |
| |
my $area = '/'.$dcdom.'/'.$pickedcourse; |
| |
if ($sec ne '') { |
| |
$area .= '/'.$sec; |
| |
} |
| |
my $spec = $role.'.'.$area; |
| |
my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'}, |
| |
$env{'user.name'},1); |
| |
my %rolehash = (); |
| |
if ($role =~ m{^\Qcr/$dcdom/$dcdom\E\-domainconfig/(\w+)$}) { |
| |
my $rolename = $1; |
| |
&custom_roleprivs(\%rolehash,$role,$dcdom,$pickedcourse,$spec,$area); |
| |
my %domdef = &get_domain_defaults($dcdom); |
| |
if (ref($domdef{'adhocroles'}) eq 'HASH') { |
| |
if (ref($domdef{'adhocroles'}{$rolename}) eq 'HASH') { |
| |
&appenv({'request.role.desc' => $domdef{'adhocroles'}{$rolename}{'desc'},}); |
| |
} |
| |
} |
| |
} else { |
| |
&standard_roleprivs(\%rolehash,$role,$dcdom,$spec,$pickedcourse,$area); |
| |
} |
| |
my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%rolehash); |
| |
&appenv(\%userroles,[$role,'cm']); |
| |
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec); |
| |
unless (($caller eq 'constructaccess' && $env{'request.course.id'}) || |
| |
($caller eq 'tiny')) { |
| |
&appenv( {'request.role' => $spec, |
| |
'request.role.domain' => $dcdom, |
| |
'request.course.sec' => $sec, |
| |
} |
| |
); |
| |
my $tadv=0; |
| |
if (&allowed('adv') eq 'F') { $tadv=1; } |
| |
&appenv({'request.role.adv' => $tadv}); |
| |
} |
| } |
} |
| |
|
| # --------------------------------------------------------------- get interface |
# --------------------------------------------------------------- get interface |
|
Line 3077 sub del {
|
Line 7087 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); |
| } |
} |
| |
|
| # -------------------------------------------------------------- dump interface |
# -------------------------------------------------------------- dump interface |
| |
|
| |
sub unserialize { |
| |
my ($rep, $escapedkeys) = @_; |
| |
|
| |
return {} if $rep =~ /^error/; |
| |
|
| |
my %returnhash=(); |
| |
foreach my $item (split(/\&/,$rep)) { |
| |
my ($key, $value) = split(/=/, $item, 2); |
| |
$key = unescape($key) unless $escapedkeys; |
| |
next if $key =~ /^error: 2 /; |
| |
$returnhash{$key} = &thaw_unescape($value); |
| |
} |
| |
#return %returnhash; |
| |
return \%returnhash; |
| |
} |
| |
|
| |
# see Lond::dump_with_regexp |
| |
# if $escapedkeys hash keys won't get unescaped. |
| sub dump { |
sub dump { |
| my ($namespace,$udomain,$uname,$regexp,$range)=@_; |
my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys)=@_; |
| 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); |
| |
|
| if ($regexp) { |
if ($regexp) { |
| $regexp=&escape($regexp); |
$regexp=&escape($regexp); |
| } else { |
} else { |
| $regexp='.'; |
$regexp='.'; |
| |
} |
| |
if (grep { $_ eq $uhome } current_machine_ids()) { |
| |
# user is hosted on this machine |
| |
my $reply = LONCAPA::Lond::dump_with_regexp(join(":", ($udomain, |
| |
$uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'}); |
| |
return %{unserialize($reply, $escapedkeys)}; |
| } |
} |
| my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); |
my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); |
| my @pairs=split(/\&/,$rep); |
my @pairs=split(/\&/,$rep); |
| my %returnhash=(); |
my %returnhash=(); |
| foreach my $item (@pairs) { |
if (!($rep =~ /^error/ )) { |
| my ($key,$value)=split(/=/,$item,2); |
foreach my $item (@pairs) { |
| $key = &unescape($key); |
my ($key,$value)=split(/=/,$item,2); |
| next if ($key =~ /^error: 2 /); |
$key = unescape($key) unless $escapedkeys; |
| $returnhash{$key}=&thaw_unescape($value); |
#$key = &unescape($key); |
| |
next if ($key =~ /^error: 2 /); |
| |
$returnhash{$key}=&thaw_unescape($value); |
| |
} |
| } |
} |
| return %returnhash; |
return %returnhash; |
| } |
} |
| |
|
| |
|
| # --------------------------------------------------------- dumpstore interface |
# --------------------------------------------------------- dumpstore interface |
| |
|
| sub dumpstore { |
sub dumpstore { |
| my ($namespace,$udomain,$uname,$regexp,$range)=@_; |
my ($namespace,$udomain,$uname,$regexp,$range)=@_; |
| if (!$udomain) { $udomain=$env{'user.domain'}; } |
# same as dump but keys must be escaped. They may contain colon separated |
| if (!$uname) { $uname=$env{'user.name'}; } |
# lists of values that may themself contain colons (e.g. symbs). |
| my $uhome=&homeserver($uname,$udomain); |
return &dump($namespace, $udomain, $uname, $regexp, $range, 1); |
| if ($regexp) { |
|
| $regexp=&escape($regexp); |
|
| } else { |
|
| $regexp='.'; |
|
| } |
|
| my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); |
|
| my @pairs=split(/\&/,$rep); |
|
| my %returnhash=(); |
|
| foreach my $item (@pairs) { |
|
| my ($key,$value)=split(/=/,$item,2); |
|
| next if ($key =~ /^error: 2 /); |
|
| $returnhash{$key}=&thaw_unescape($value); |
|
| } |
|
| return %returnhash; |
|
| } |
} |
| |
|
| # -------------------------------------------------------------- keys interface |
# -------------------------------------------------------------- keys interface |
|
Line 3155 sub currentdump {
|
Line 7180 sub currentdump {
|
| $sdom = $env{'user.domain'} if (! defined($sdom)); |
$sdom = $env{'user.domain'} if (! defined($sdom)); |
| $sname = $env{'user.name'} if (! defined($sname)); |
$sname = $env{'user.name'} if (! defined($sname)); |
| my $uhome = &homeserver($sname,$sdom); |
my $uhome = &homeserver($sname,$sdom); |
| my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome); |
my $rep; |
| |
|
| |
if (grep { $_ eq $uhome } current_machine_ids()) { |
| |
$rep = LONCAPA::Lond::dump_profile_database(join(":", ($sdom, $sname, |
| |
$courseid))); |
| |
} else { |
| |
$rep = reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome); |
| |
} |
| |
|
| return if ($rep =~ /^(error:|no_such_host)/); |
return if ($rep =~ /^(error:|no_such_host)/); |
| # |
# |
| my %returnhash=(); |
my %returnhash=(); |
| # |
# |
| if ($rep eq "unknown_cmd") { |
if ($rep eq 'unknown_cmd') { |
| # an old lond will not know currentdump |
# an old lond will not know currentdump |
| # Do a dump and make it look like a currentdump |
# Do a dump and make it look like a currentdump |
| my @tmp = &dumpstore($courseid,$sdom,$sname,'.'); |
my @tmp = &dumpstore($courseid,$sdom,$sname,'.'); |
|
Line 3276 sub newput {
|
Line 7309 sub newput {
|
| # --------------------------------------------------------- putstore interface |
# --------------------------------------------------------- putstore interface |
| |
|
| sub putstore { |
sub putstore { |
| my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_; |
my ($namespace,$symb,$version,$storehash,$udomain,$uname,$tolog)=@_; |
| 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); |
|
Line 3290 sub putstore {
|
Line 7323 sub putstore {
|
| my $reply = |
my $reply = |
| &reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items", |
&reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items", |
| $uhome); |
$uhome); |
| |
if (($tolog) && ($reply eq 'ok')) { |
| |
my $namevalue=''; |
| |
foreach my $key (keys(%{$storehash})) { |
| |
$namevalue.=&escape($key).'='.&freeze_escape($storehash->{$key}).'&'; |
| |
} |
| |
my $ip = &get_requestor_ip(); |
| |
$namevalue .= 'ip='.&escape($ip). |
| |
'&host='.&escape($perlvar{'lonHostID'}). |
| |
'&version='.$esc_v. |
| |
'&by='.&escape($env{'user.name'}.':'.$env{'user.domain'}); |
| |
&Apache::lonnet::courselog($symb.':'.$uname.':'.$udomain.':PUTSTORE:'.$namevalue); |
| |
} |
| if ($reply eq 'unknown_cmd') { |
if ($reply eq 'unknown_cmd') { |
| # gfall back to way things use to be done |
# gfall back to way things use to be done |
| return &old_putstore($namespace,$symb,$version,$storehash,$udomain, |
return &old_putstore($namespace,$symb,$version,$storehash,$udomain, |
|
Line 3383 sub tmpget {
|
Line 7428 sub tmpget {
|
| if (!defined($server)) { $server = $perlvar{'lonHostID'}; } |
if (!defined($server)) { $server = $perlvar{'lonHostID'}; } |
| my $rep=&reply("tmpget:$token",$server); |
my $rep=&reply("tmpget:$token",$server); |
| my %returnhash; |
my %returnhash; |
| |
if ($rep =~ /^(con_lost|error|no_such_host)/i) { |
| |
return %returnhash; |
| |
} |
| foreach my $item (split(/\&/,$rep)) { |
foreach my $item (split(/\&/,$rep)) { |
| my ($key,$value)=split(/=/,$item); |
my ($key,$value)=split(/=/,$item); |
| $returnhash{&unescape($key)}=&thaw_unescape($value); |
$returnhash{&unescape($key)}=&thaw_unescape($value); |
|
Line 3390 sub tmpget {
|
Line 7438 sub tmpget {
|
| return %returnhash; |
return %returnhash; |
| } |
} |
| |
|
| # ------------------------------------------------------------ tmpget interface |
# ------------------------------------------------------------ tmpdel interface |
| sub tmpdel { |
sub tmpdel { |
| my ($token,$server)=@_; |
my ($token,$server)=@_; |
| if (!defined($server)) { $server = $perlvar{'lonHostID'}; } |
if (!defined($server)) { $server = $perlvar{'lonHostID'}; } |
| return &reply("tmpdel:$token",$server); |
return &reply("tmpdel:$token",$server); |
| } |
} |
| |
|
| |
# ------------------------------------------------------------ get_timebased_id |
| |
|
| |
sub get_timebased_id { |
| |
my ($prefix,$keyid,$namespace,$cdom,$cnum,$idtype,$who,$locktries, |
| |
$maxtries) = @_; |
| |
my ($newid,$error,$dellock); |
| |
unless (($prefix =~ /^\w+$/) && ($keyid =~ /^\w+$/) && ($namespace ne '')) { |
| |
return ('','ok','invalid call to get suffix'); |
| |
} |
| |
|
| |
# set defaults for any optional args for which values were not supplied |
| |
if ($who eq '') { |
| |
$who = $env{'user.name'}.':'.$env{'user.domain'}; |
| |
} |
| |
if (!$locktries) { |
| |
$locktries = 3; |
| |
} |
| |
if (!$maxtries) { |
| |
$maxtries = 10; |
| |
} |
| |
|
| |
if (($cdom eq '') || ($cnum eq '')) { |
| |
if ($env{'request.course.id'}) { |
| |
$cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; |
| |
$cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; |
| |
} |
| |
if (($cdom eq '') || ($cnum eq '')) { |
| |
return ('','ok','call to get suffix not in course context'); |
| |
} |
| |
} |
| |
|
| |
# construct locking item |
| |
my $lockhash = { |
| |
$prefix."\0".'locked_'.$keyid => $who, |
| |
}; |
| |
my $tries = 0; |
| |
|
| |
# attempt to get lock on nohist_$namespace file |
| |
my $gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum); |
| |
while (($gotlock ne 'ok') && $tries <$locktries) { |
| |
$tries ++; |
| |
sleep 1; |
| |
$gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum); |
| |
} |
| |
|
| |
# attempt to get unique identifier, based on current timestamp |
| |
if ($gotlock eq 'ok') { |
| |
my %inuse = &Apache::lonnet::dump('nohist_'.$namespace,$cdom,$cnum,$prefix); |
| |
my $id = time; |
| |
$newid = $id; |
| |
if ($idtype eq 'addcode') { |
| |
$newid .= &sixnum_code(); |
| |
} |
| |
my $idtries = 0; |
| |
while (exists($inuse{$prefix."\0".$newid}) && $idtries < $maxtries) { |
| |
if ($idtype eq 'concat') { |
| |
$newid = $id.$idtries; |
| |
} elsif ($idtype eq 'addcode') { |
| |
$newid = $newid.&sixnum_code(); |
| |
} else { |
| |
$newid ++; |
| |
} |
| |
$idtries ++; |
| |
} |
| |
if (!exists($inuse{$prefix."\0".$newid})) { |
| |
my %new_item = ( |
| |
$prefix."\0".$newid => $who, |
| |
); |
| |
my $putresult = &Apache::lonnet::put('nohist_'.$namespace,\%new_item, |
| |
$cdom,$cnum); |
| |
if ($putresult ne 'ok') { |
| |
undef($newid); |
| |
$error = 'error saving new item: '.$putresult; |
| |
} |
| |
} else { |
| |
undef($newid); |
| |
$error = ('error: no unique suffix available for the new item '); |
| |
} |
| |
# remove lock |
| |
my @del_lock = ($prefix."\0".'locked_'.$keyid); |
| |
$dellock = &Apache::lonnet::del('nohist_'.$namespace,\@del_lock,$cdom,$cnum); |
| |
} else { |
| |
$error = "error: could not obtain lockfile\n"; |
| |
$dellock = 'ok'; |
| |
if (($prefix eq 'paste') && ($namespace eq 'courseeditor') && ($keyid eq 'num')) { |
| |
$dellock = 'nolock'; |
| |
} |
| |
} |
| |
return ($newid,$dellock,$error); |
| |
} |
| |
|
| |
sub sixnum_code { |
| |
my $code; |
| |
for (0..6) { |
| |
$code .= int( rand(9) ); |
| |
} |
| |
return $code; |
| |
} |
| |
|
| # -------------------------------------------------- portfolio access checking |
# -------------------------------------------------- portfolio access checking |
| |
|
| sub portfolio_access { |
sub portfolio_access { |
| my ($requrl) = @_; |
my ($requrl,$clientip) = @_; |
| my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl); |
my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl); |
| my $result = &get_portfolio_access($udom,$unum,$file_name,$group); |
my $result = &get_portfolio_access($udom,$unum,$file_name,$group,$clientip); |
| if ($result) { |
if ($result) { |
| my %setters; |
my %setters; |
| if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') { |
if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') { |
|
Line 3428 sub portfolio_access {
|
Line 7575 sub portfolio_access {
|
| } |
} |
| |
|
| sub get_portfolio_access { |
sub get_portfolio_access { |
| my ($udom,$unum,$file_name,$group,$access_hash) = @_; |
my ($udom,$unum,$file_name,$group,$clientip,$access_hash) = @_; |
| |
|
| if (!ref($access_hash)) { |
if (!ref($access_hash)) { |
| my $current_perms = &get_portfile_permissions($udom,$unum); |
my $current_perms = &get_portfile_permissions($udom,$unum); |
|
Line 3437 sub get_portfolio_access {
|
Line 7584 sub get_portfolio_access {
|
| $access_hash = $access_controls{$file_name}; |
$access_hash = $access_controls{$file_name}; |
| } |
} |
| |
|
| my ($public,$guest,@domains,@users,@courses,@groups); |
my ($public,$guest,@domains,@users,@courses,@groups,@ips); |
| my $now = time; |
my $now = time; |
| if (ref($access_hash) eq 'HASH') { |
if (ref($access_hash) eq 'HASH') { |
| foreach my $key (keys(%{$access_hash})) { |
foreach my $key (keys(%{$access_hash})) { |
|
Line 3461 sub get_portfolio_access {
|
Line 7608 sub get_portfolio_access {
|
| push(@courses,$key); |
push(@courses,$key); |
| } elsif ($scope eq 'group') { |
} elsif ($scope eq 'group') { |
| push(@groups,$key); |
push(@groups,$key); |
| |
} elsif ($scope eq 'ip') { |
| |
push(@ips,$key); |
| } |
} |
| } |
} |
| if ($public) { |
if ($public) { |
| return 'ok'; |
return 'ok'; |
| |
} elsif (@ips > 0) { |
| |
my $allowed; |
| |
foreach my $ipkey (@ips) { |
| |
if (ref($access_hash->{$ipkey}{'ip'}) eq 'ARRAY') { |
| |
if (&Apache::loncommon::check_ip_acc(join(',',@{$access_hash->{$ipkey}{'ip'}}),$clientip)) { |
| |
$allowed = 1; |
| |
last; |
| |
} |
| |
} |
| |
} |
| |
if ($allowed) { |
| |
return 'ok'; |
| |
} |
| } |
} |
| if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') { |
if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') { |
| if ($guest) { |
if ($guest) { |
|
Line 3482 sub get_portfolio_access {
|
Line 7644 sub get_portfolio_access {
|
| } |
} |
| if (@users > 0) { |
if (@users > 0) { |
| foreach my $userkey (@users) { |
foreach my $userkey (@users) { |
| if (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) { |
if (ref($access_hash->{$userkey}{'users'}) eq 'ARRAY') { |
| return 'ok'; |
foreach my $item (@{$access_hash->{$userkey}{'users'}}) { |
| } |
if (ref($item) eq 'HASH') { |
| |
if (($item->{'uname'} eq $env{'user.name'}) && |
| |
($item->{'udom'} eq $env{'user.domain'})) { |
| |
return 'ok'; |
| |
} |
| |
} |
| |
} |
| |
} |
| } |
} |
| } |
} |
| my %roleshash; |
my %roleshash; |
|
Line 3494 sub get_portfolio_access {
|
Line 7663 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 3633 sub is_portfolio_file {
|
Line 7802 sub is_portfolio_file {
|
| return; |
return; |
| } |
} |
| |
|
| |
sub usertools_access { |
| |
my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref)=@_; |
| |
my ($access,%tools); |
| |
if ($context eq '') { |
| |
$context = 'tools'; |
| |
} |
| |
if ($context eq 'requestcourses') { |
| |
%tools = ( |
| |
official => 1, |
| |
unofficial => 1, |
| |
community => 1, |
| |
textbook => 1, |
| |
placement => 1, |
| |
lti => 1, |
| |
); |
| |
} elsif ($context eq 'requestauthor') { |
| |
%tools = ( |
| |
requestauthor => 1, |
| |
); |
| |
} else { |
| |
%tools = ( |
| |
aboutme => 1, |
| |
blog => 1, |
| |
webdav => 1, |
| |
portfolio => 1, |
| |
); |
| |
} |
| |
return if (!defined($tools{$tool})); |
| |
|
| |
if (($udom eq '') || ($uname eq '')) { |
| |
$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}; |
| |
} elsif ($context eq 'requestauthor') { |
| |
return $env{'environment.canrequest.author'}; |
| |
} else { |
| |
return $env{'environment.availabletools.'.$tool}; |
| |
} |
| |
} |
| |
} |
| |
|
| |
my ($toolstatus,$inststatus,$envkey); |
| |
if ($context eq 'requestauthor') { |
| |
$envkey = $context; |
| |
} else { |
| |
$envkey = $context.'.'.$tool; |
| |
} |
| |
|
| |
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && |
| |
($action ne 'reload')) { |
| |
$toolstatus = $env{'environment.'.$envkey}; |
| |
$inststatus = $env{'environment.inststatus'}; |
| |
} else { |
| |
if (ref($userenvref) eq 'HASH') { |
| |
$toolstatus = $userenvref->{$envkey}; |
| |
$inststatus = $userenvref->{'inststatus'}; |
| |
} else { |
| |
my %userenv = &userenvironment($udom,$uname,$envkey,'inststatus'); |
| |
$toolstatus = $userenv{$envkey}; |
| |
$inststatus = $userenv{'inststatus'}; |
| |
} |
| |
} |
| |
|
| |
if ($toolstatus ne '') { |
| |
if ($toolstatus) { |
| |
$access = 1; |
| |
} else { |
| |
$access = 0; |
| |
} |
| |
return $access; |
| |
} |
| |
|
| |
my ($is_adv,%domdef); |
| |
if (ref($is_advref) eq 'HASH') { |
| |
$is_adv = $is_advref->{'is_adv'}; |
| |
} else { |
| |
$is_adv = &is_advanced_user($udom,$uname); |
| |
} |
| |
if (ref($domdefref) eq 'HASH') { |
| |
%domdef = %{$domdefref}; |
| |
} else { |
| |
%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') && ($tool ne 'webdav')) { |
| |
$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) = @_; |
| |
if ($udom ne '' && $uname ne '') { |
| |
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { |
| |
if (wantarray) { |
| |
return ($env{'user.adv'},$env{'user.author'}); |
| |
} else { |
| |
return $env{'user.adv'}; |
| |
} |
| |
} |
| |
} |
| |
my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1); |
| |
my %allroles; |
| |
my ($is_adv,$is_author); |
| |
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); |
| |
} |
| |
if ($trole eq 'au') { |
| |
$is_author = 1; |
| |
} |
| |
} |
| |
} |
| |
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; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if (wantarray) { |
| |
return ($is_adv,$is_author); |
| |
} |
| |
return $is_adv; |
| |
} |
| |
|
| |
sub check_can_request { |
| |
my ($dom,$can_request,$request_domains,$uname,$udom) = @_; |
| |
my $canreq = 0; |
| |
if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) { |
| |
$uname = $env{'user.name'}; |
| |
$udom = $env{'user.domain'}; |
| |
} |
| |
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($uname,$udom,$type,undef, |
| |
'requestcourses')) { |
| |
$canreq ++; |
| |
if (ref($request_domains) eq 'HASH') { |
| |
push(@{$request_domains->{$type}},$udom); |
| |
} |
| |
if ($dom eq $udom) { |
| |
$can_request->{$type} = 1; |
| |
} |
| |
} |
| |
if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '') && |
| |
($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 3644 sub customaccess {
|
Line 8074 sub customaccess {
|
| $ucrs = &LONCAPA::clean_username($ucrs); |
$ucrs = &LONCAPA::clean_username($ucrs); |
| my $access=0; |
my $access=0; |
| foreach my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) { |
foreach my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) { |
| my ($effect,$realm,$role)=split(/\:/,$right); |
my ($effect,$realm,$role,$type)=split(/\:/,$right); |
| if ($role) { |
if ($type eq 'user') { |
| if ($role ne $urole) { next; } |
foreach my $scope (split(/\s*\,\s*/,$realm)) { |
| } |
my ($tdom,$tuname)=split(m{/},$scope); |
| foreach my $scope (split(/\s*\,\s*/,$realm)) { |
if ($tdom) { |
| my ($tdom,$tcrs,$tsec)=split(/\_/,$scope); |
if ($tdom ne $env{'user.domain'}) { next; } |
| if ($tdom) { |
} |
| if ($tdom ne $udom) { next; } |
if ($tuname) { |
| } |
if ($tuname ne $env{'user.name'}) { next; } |
| if ($tcrs) { |
} |
| if ($tcrs ne $ucrs) { next; } |
$access=($effect eq 'allow'); |
| } |
last; |
| if ($tsec) { |
} |
| if ($tsec ne $usec) { next; } |
} else { |
| } |
if ($role) { |
| $access=($effect eq 'allow'); |
if ($role ne $urole) { next; } |
| last; |
} |
| } |
foreach my $scope (split(/\s*\,\s*/,$realm)) { |
| if ($realm eq '' && $role eq '') { |
my ($tdom,$tcrs,$tsec)=split(/\_/,$scope); |
| $access=($effect eq 'allow'); |
if ($tdom) { |
| |
if ($tdom ne $udom) { next; } |
| |
} |
| |
if ($tcrs) { |
| |
if ($tcrs ne $ucrs) { next; } |
| |
} |
| |
if ($tsec) { |
| |
if ($tsec ne $usec) { next; } |
| |
} |
| |
$access=($effect eq 'allow'); |
| |
last; |
| |
} |
| |
if ($realm eq '' && $role eq '') { |
| |
$access=($effect eq 'allow'); |
| |
} |
| } |
} |
| } |
} |
| return $access; |
return $access; |
|
Line 3672 sub customaccess {
|
Line 8116 sub customaccess {
|
| # ------------------------------------------------- Check for a user privilege |
# ------------------------------------------------- Check for a user privilege |
| |
|
| sub allowed { |
sub allowed { |
| my ($priv,$uri,$symb,$role)=@_; |
my ($priv,$uri,$symb,$role,$clientip,$noblockcheck,$ignorecache)=@_; |
| my $ver_orguri=$uri; |
my $ver_orguri=$uri; |
| $uri=&deversion($uri); |
$uri=&deversion($uri); |
| my $orguri=$uri; |
my $orguri=$uri; |
|
Line 3689 sub allowed {
|
Line 8133 sub allowed {
|
| |
|
| if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; } |
if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; } |
| # Free bre access to adm and meta resources |
# Free bre access to adm and meta resources |
| if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$})) |
if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|viewclasslist|aboutme|ext\.tool)$})) |
| || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) |
|| (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) |
| && ($priv eq 'bre')) { |
&& ($priv eq 'bre')) { |
| return 'F'; |
return 'F'; |
|
Line 3737 sub allowed {
|
Line 8181 sub allowed {
|
| # Free bre to public access |
# Free bre to public access |
| |
|
| if ($priv eq 'bre') { |
if ($priv eq 'bre') { |
| my $copyright=&metadata($uri,'copyright'); |
my $copyright; |
| |
unless ($uri =~ /ext\.tool/) { |
| |
$copyright=&metadata($uri,'copyright'); |
| |
} |
| if (($copyright eq 'public') && (!$env{'request.course.id'})) { |
if (($copyright eq 'public') && (!$env{'request.course.id'})) { |
| return 'F'; |
return 'F'; |
| } |
} |
|
Line 3774 sub allowed {
|
Line 8221 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; |
| |
} |
| |
} |
| |
|
| |
# User who is not author or co-author might still be able to edit |
| |
# resource of an author in the domain (e.g., if Domain Coordinator). |
| |
if (($priv eq 'eco') && ($thisallowed eq '') && ($env{'request.course.id'}) && |
| |
(&allowed('mdc',$env{'request.course.id'}))) { |
| |
if ($env{"user.priv.cm./$uri/"}=~/\Q$priv\E\&([^\:]*)/) { |
| |
$thisallowed.=$1; |
| |
} |
| } |
} |
| |
|
| # Course: uri itself is a course |
# Course: uri itself is a course |
|
Line 3794 sub allowed {
|
Line 8301 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; |
if ($priv eq 'mip') { |
| |
my $rem = $1; |
| |
if (($uri ne '') && ($env{'request.course.id'} eq $uri) && |
| |
($env{'course.'.$env{'request.course.id'}.'.internal.courseowner'} eq $env{'user.name'}.':'.$env{'user.domain'})) { |
| |
my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; |
| |
if ($cdom ne '') { |
| |
my %passwdconf = &get_passwdconf($cdom); |
| |
if (ref($passwdconf{'crsownerchg'}) eq 'HASH') { |
| |
if (ref($passwdconf{'crsownerchg'}{'by'}) eq 'ARRAY') { |
| |
if (@{$passwdconf{'crsownerchg'}{'by'}}) { |
| |
my @inststatuses = split(':',$env{'environment.inststatus'}); |
| |
unless (@inststatuses) { |
| |
@inststatuses = ('default'); |
| |
} |
| |
foreach my $status (@inststatuses) { |
| |
if (grep(/^\Q$status\E$/,@{$passwdconf{'crsownerchg'}{'by'}})) { |
| |
$thisallowed.=$rem; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} else { |
| |
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 3805 sub allowed {
|
Line 8340 sub allowed {
|
| if ($match) { |
if ($match) { |
| if ($env{'user.priv.'.$env{'request.role'}.'./'} |
if ($env{'user.priv.'.$env{'request.role'}.'./'} |
| =~/\Q$priv\E\&([^\:]*)/) { |
=~/\Q$priv\E\&([^\:]*)/) { |
| $thisallowed.=$1; |
my $value = $1; |
| |
my $deeplinkblock = &deeplink_check($priv,$symb,$uri); |
| |
if ($deeplinkblock) { |
| |
$thisallowed='D'; |
| |
} elsif ($noblockcheck) { |
| |
$thisallowed.=$value; |
| |
} else { |
| |
my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache); |
| |
if (@blockers > 0) { |
| |
$thisallowed = 'B'; |
| |
} else { |
| |
$thisallowed.=$value; |
| |
} |
| |
} |
| } |
} |
| } else { |
} else { |
| my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri}; |
my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri}; |
|
Line 3816 sub allowed {
|
Line 8364 sub allowed {
|
| $refuri=&declutter($refuri); |
$refuri=&declutter($refuri); |
| my ($match) = &is_on_map($refuri); |
my ($match) = &is_on_map($refuri); |
| if ($match) { |
if ($match) { |
| $thisallowed='F'; |
my $deeplinkblock = &deeplink_check($priv,$symb,$refuri); |
| |
if ($deeplinkblock) { |
| |
$thisallowed='D'; |
| |
} elsif ($noblockcheck) { |
| |
$thisallowed='F'; |
| |
} else { |
| |
my @blockers = &has_comm_blocking($priv,'',$refuri,'',1); |
| |
if (@blockers > 0) { |
| |
$thisallowed = 'B'; |
| |
} else { |
| |
$thisallowed='F'; |
| |
} |
| |
} |
| } |
} |
| } |
} |
| } |
} |
|
Line 3827 sub allowed {
|
Line 8387 sub allowed {
|
| && $thisallowed ne 'F' |
&& $thisallowed ne 'F' |
| && $thisallowed ne '2' |
&& $thisallowed ne '2' |
| && &is_portfolio_url($uri)) { |
&& &is_portfolio_url($uri)) { |
| $thisallowed = &portfolio_access($uri); |
$thisallowed = &portfolio_access($uri,$clientip); |
| } |
} |
| |
|
| # Full access at system, domain or course-wide level? Exit. |
|
| |
|
| |
# Full access at system, domain or course-wide level? Exit. |
| if ($thisallowed=~/F/) { |
if ($thisallowed=~/F/) { |
| return 'F'; |
return 'F'; |
| } |
} |
|
Line 3858 sub allowed {
|
Line 8417 sub allowed {
|
| |
|
| if ($env{'request.course.id'}) { |
if ($env{'request.course.id'}) { |
| |
|
| |
# If this is modifying password (internal auth) domains must match for user and user's role. |
| |
|
| |
if ($priv eq 'mip') { |
| |
if ($env{'user.domain'} eq $env{'request.role.domain'}) { |
| |
return $thisallowed; |
| |
} else { |
| |
return ''; |
| |
} |
| |
} |
| |
|
| $courseprivid=$env{'request.course.id'}; |
$courseprivid=$env{'request.course.id'}; |
| if ($env{'request.course.sec'}) { |
if ($env{'request.course.sec'}) { |
| $courseprivid.='/'.$env{'request.course.sec'}; |
$courseprivid.='/'.$env{'request.course.sec'}; |
|
Line 3869 sub allowed {
|
Line 8438 sub allowed {
|
| $statecond=$cond; |
$statecond=$cond; |
| if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid} |
if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid} |
| =~/\Q$priv\E\&([^\:]*)/) { |
=~/\Q$priv\E\&([^\:]*)/) { |
| $thisallowed.=$1; |
my $value = $1; |
| |
if ($priv eq 'bre') { |
| |
if ($noblockcheck) { |
| |
$thisallowed.=$value; |
| |
} else { |
| |
my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache); |
| |
if (@blockers > 0) { |
| |
$thisallowed = 'B'; |
| |
} else { |
| |
$thisallowed.=$value; |
| |
} |
| |
} |
| |
} else { |
| |
$thisallowed.=$value; |
| |
} |
| $checkreferer=0; |
$checkreferer=0; |
| } |
} |
| } |
} |
| |
|
| if ($checkreferer) { |
if ($checkreferer) { |
| my $refuri=$env{'httpref.'.$orguri}; |
my $refuri=$env{'httpref.'.$orguri}; |
| unless ($refuri) { |
unless ($refuri) { |
|
Line 3897 sub allowed {
|
Line 8480 sub allowed {
|
| my $refstatecond=$cond; |
my $refstatecond=$cond; |
| if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid} |
if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid} |
| =~/\Q$priv\E\&([^\:]*)/) { |
=~/\Q$priv\E\&([^\:]*)/) { |
| $thisallowed.=$1; |
my $value = $1; |
| |
if ($priv eq 'bre') { |
| |
my $deeplinkblock = &deeplink_check($priv,$symb,$refuri); |
| |
if ($deeplinkblock) { |
| |
$thisallowed = 'D'; |
| |
} elsif ($noblockcheck) { |
| |
$thisallowed.=$value; |
| |
} else { |
| |
my @blockers = &has_comm_blocking($priv,'',$refuri,'',1); |
| |
if (@blockers > 0) { |
| |
$thisallowed = 'B'; |
| |
} else { |
| |
$thisallowed.=$value; |
| |
} |
| |
} |
| |
} else { |
| |
$thisallowed.=$value; |
| |
} |
| $uri=$refuri; |
$uri=$refuri; |
| $statecond=$refstatecond; |
$statecond=$refstatecond; |
| } |
} |
|
Line 3935 sub allowed {
|
Line 8535 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 3974 sub allowed {
|
Line 8574 sub allowed {
|
| } |
} |
| } |
} |
| } |
} |
| |
|
| # |
# |
| # Rest of the restrictions depend on selected course |
# Rest of the restrictions depend on selected course |
| # |
# |
|
Line 4001 sub allowed {
|
Line 8601 sub allowed {
|
| my $unamedom=$env{'user.name'}.':'.$env{'user.domain'}; |
my $unamedom=$env{'user.name'}.':'.$env{'user.domain'}; |
| if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'} |
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'} |
| =~/\Q$rolecode\E/) { |
=~/\Q$rolecode\E/) { |
| if ($priv ne 'pch') { |
if (($priv ne 'pch') && ($priv ne 'plc') && ($priv ne 'pac')) { |
| &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. |
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. |
| 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. |
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. |
| $env{'request.course.id'}); |
$env{'request.course.id'}); |
|
Line 4011 sub allowed {
|
Line 8611 sub allowed {
|
| |
|
| if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'} |
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'} |
| =~/\Q$unamedom\E/) { |
=~/\Q$unamedom\E/) { |
| if ($priv ne 'pch') { |
if (($priv ne 'pch') && ($priv ne 'plc') && ($priv ne 'pac')) { |
| &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}. |
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}. |
| 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. |
'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. |
| $env{'request.course.id'}); |
$env{'request.course.id'}); |
|
Line 4025 sub allowed {
|
Line 8625 sub allowed {
|
| if ($thisallowed=~/R/) { |
if ($thisallowed=~/R/) { |
| my $rolecode=(split(/\./,$env{'request.role'}))[0]; |
my $rolecode=(split(/\./,$env{'request.role'}))[0]; |
| if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) { |
if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) { |
| if ($priv ne 'pch') { |
if (($priv ne 'pch') && ($priv ne 'plc')) { |
| &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. |
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. |
| 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); |
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); |
| } |
} |
|
Line 4053 sub allowed {
|
Line 8653 sub allowed {
|
| return 'A'; |
return 'A'; |
| } elsif ($thisallowed eq 'B') { |
} elsif ($thisallowed eq 'B') { |
| return 'B'; |
return 'B'; |
| |
} elsif ($thisallowed eq 'D') { |
| |
return 'D'; |
| } |
} |
| return 'F'; |
return 'F'; |
| } |
} |
| |
|
| |
# ------------------------------------------- Check construction space access |
| |
|
| |
sub constructaccess { |
| |
my ($url,$setpriv)=@_; |
| |
|
| |
# We do not allow editing of previous versions of files |
| |
if ($url=~/\.(\d+)\.(\w+)$/) { return ''; } |
| |
|
| |
# Get username and domain from URL |
| |
my ($ownername,$ownerdomain,$ownerhome); |
| |
|
| |
($ownerdomain,$ownername) = |
| |
($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)(?:/daxepage|/daxeopen)?/priv/($match_domain)/($match_username)(?:/|$)}); |
| |
|
| |
# The URL does not really point to any authorspace, forget it |
| |
unless (($ownername) && ($ownerdomain)) { return ''; } |
| |
|
| |
# Now we need to see if the user has access to the authorspace of |
| |
# $ownername at $ownerdomain |
| |
|
| |
if (($ownername eq $env{'user.name'}) && ($ownerdomain eq $env{'user.domain'})) { |
| |
# Real author for this? |
| |
$ownerhome = $env{'user.home'}; |
| |
if (exists($env{'user.priv.au./'.$ownerdomain.'/./'})) { |
| |
return ($ownername,$ownerdomain,$ownerhome); |
| |
} |
| |
} else { |
| |
# Co-author for this? |
| |
if (exists($env{'user.priv.ca./'.$ownerdomain.'/'.$ownername.'./'}) || |
| |
exists($env{'user.priv.aa./'.$ownerdomain.'/'.$ownername.'./'}) ) { |
| |
$ownerhome = &homeserver($ownername,$ownerdomain); |
| |
return ($ownername,$ownerdomain,$ownerhome); |
| |
} |
| |
if ($env{'request.course.id'}) { |
| |
if (($ownername eq $env{'course.'.$env{'request.course.id'}.'.num'}) && |
| |
($ownerdomain eq $env{'course.'.$env{'request.course.id'}.'.domain'})) { |
| |
if (&allowed('mdc',$env{'request.course.id'})) { |
| |
$ownerhome = $env{'course.'.$env{'request.course.id'}.'.home'}; |
| |
return ($ownername,$ownerdomain,$ownerhome); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
|
| |
# We don't have any access right now. If we are not possibly going to do anything about this, |
| |
# we might as well leave |
| |
unless ($setpriv) { return ''; } |
| |
|
| |
# Backdoor access? |
| |
my $allowed=&allowed('eco',$ownerdomain); |
| |
# Nope |
| |
unless ($allowed) { return ''; } |
| |
# Looks like we may have access, but could be locked by the owner of the construction space |
| |
if ($allowed eq 'U') { |
| |
my %blocked=&get('environment',['domcoord.author'], |
| |
$ownerdomain,$ownername); |
| |
# Is blocked by owner |
| |
if ($blocked{'domcoord.author'} eq 'blocked') { return ''; } |
| |
} |
| |
if (($allowed eq 'F') || ($allowed eq 'U')) { |
| |
# Grant temporary access |
| |
my $then=$env{'user.login.time'}; |
| |
my $update=$env{'user.update.time'}; |
| |
if (!$update) { $update = $then; } |
| |
my $refresh=$env{'user.refresh.time'}; |
| |
if (!$refresh) { $refresh = $update; } |
| |
my $now = time; |
| |
&check_adhoc_privs($ownerdomain,$ownername,$update,$refresh, |
| |
$now,'ca','constructaccess'); |
| |
$ownerhome = &homeserver($ownername,$ownerdomain); |
| |
return($ownername,$ownerdomain,$ownerhome); |
| |
} |
| |
# No business here |
| |
return ''; |
| |
} |
| |
|
| |
# ----------------------------------------------------------- Content Blocking |
| |
|
| |
{ |
| |
# Caches for faster Course Contents display where content blocking |
| |
# is in operation (i.e., interval param set) for timed quiz. |
| |
# |
| |
# User for whom data are being temporarily cached. |
| |
my $cacheduser=''; |
| |
# Course for which data are being temporarily cached. |
| |
my $cachedcid=''; |
| |
# Cached blockers for this user (a hash of blocking items). |
| |
my %cachedblockers=(); |
| |
# When the data were last cached. |
| |
my $cachedlast=''; |
| |
|
| |
sub load_all_blockers { |
| |
my ($uname,$udom)=@_; |
| |
if (($uname ne '') && ($udom ne '')) { |
| |
if (($cacheduser eq $uname.':'.$udom) && |
| |
($cachedcid eq $env{'request.course.id'}) && |
| |
(abs($cachedlast-time)<5)) { |
| |
return; |
| |
} |
| |
} |
| |
$cachedlast=time; |
| |
$cacheduser=$uname.':'.$udom; |
| |
$cachedcid=$env{'request.course.id'}; |
| |
%cachedblockers = &get_commblock_resources(); |
| |
return; |
| |
} |
| |
|
| |
sub get_comm_blocks { |
| |
my ($cdom,$cnum) = @_; |
| |
if ($cdom eq '' || $cnum eq '') { |
| |
return unless ($env{'request.course.id'}); |
| |
$cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; |
| |
$cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; |
| |
} |
| |
my %commblocks; |
| |
my $hashid=$cdom.'_'.$cnum; |
| |
my ($blocksref,$cached)=&is_cached_new('comm_block',$hashid); |
| |
if ((defined($cached)) && (ref($blocksref) eq 'HASH')) { |
| |
%commblocks = %{$blocksref}; |
| |
} else { |
| |
%commblocks = &Apache::lonnet::dump('comm_block',$cdom,$cnum); |
| |
my $cachetime = 600; |
| |
&do_cache_new('comm_block',$hashid,\%commblocks,$cachetime); |
| |
} |
| |
return %commblocks; |
| |
} |
| |
|
| |
sub get_commblock_resources { |
| |
my ($blocks) = @_; |
| |
my %blockers = (); |
| |
return %blockers unless ($env{'request.course.id'}); |
| |
return %blockers if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/); |
| |
my %commblocks; |
| |
if (ref($blocks) eq 'HASH') { |
| |
%commblocks = %{$blocks}; |
| |
} else { |
| |
%commblocks = &get_comm_blocks(); |
| |
} |
| |
return %blockers unless (keys(%commblocks) > 0); |
| |
my $navmap = Apache::lonnavmaps::navmap->new(); |
| |
return %blockers unless (ref($navmap)); |
| |
my $now = time; |
| |
foreach my $block (keys(%commblocks)) { |
| |
if ($block =~ /^(\d+)____(\d+)$/) { |
| |
my ($start,$end) = ($1,$2); |
| |
if ($start <= $now && $end >= $now) { |
| |
if (ref($commblocks{$block}{'blocks'}) eq 'HASH') { |
| |
if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') { |
| |
if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') { |
| |
if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'maps'}})) { |
| |
$blockers{$block}{maps} = $commblocks{$block}{'blocks'}{'docs'}{'maps'}; |
| |
} |
| |
} |
| |
if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') { |
| |
if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'resources'}})) { |
| |
$blockers{$block}{'resources'} = $commblocks{$block}{'blocks'}{'docs'}{'resources'}; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} elsif ($block =~ /^firstaccess____(.+)$/) { |
| |
my $item = $1; |
| |
my @to_test; |
| |
if (ref($commblocks{$block}{'blocks'}) eq 'HASH') { |
| |
if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') { |
| |
my @interval; |
| |
my $type = 'map'; |
| |
if ($item eq 'course') { |
| |
$type = 'course'; |
| |
@interval=&EXT("resource.0.interval"); |
| |
} else { |
| |
if ($item =~ /___\d+___/) { |
| |
$type = 'resource'; |
| |
@interval=&EXT("resource.0.interval",$item); |
| |
if (ref($navmap)) { |
| |
my $res = $navmap->getBySymb($item); |
| |
push(@to_test,$res); |
| |
} |
| |
} else { |
| |
my $mapsymb = &symbread($item,1); |
| |
if ($mapsymb) { |
| |
if (ref($navmap)) { |
| |
my $mapres = $navmap->getBySymb($mapsymb); |
| |
if (ref($mapres)) { |
| |
my $first = $mapres->map_start(); |
| |
my $finish = $mapres->map_finish(); |
| |
my $it = $navmap->getIterator($first,$finish,undef,0,0); |
| |
if (ref($it)) { |
| |
my $res; |
| |
while ($res = $it->next(undef,1)) { |
| |
next unless (ref($res)); |
| |
my $symb = $res->symb(); |
| |
next if (($symb eq $mapsymb) || ($symb eq '')); |
| |
@interval=&EXT("resource.0.interval",$symb); |
| |
if ($interval[1] eq 'map') { |
| |
if ($res->answerable()) { |
| |
push(@to_test,$res); |
| |
last; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if ($interval[0] =~ /^(\d+)/) { |
| |
my $timelimit = $1; |
| |
my $first_access; |
| |
if ($type eq 'resource') { |
| |
$first_access=&get_first_access($interval[1],$item); |
| |
} elsif ($type eq 'map') { |
| |
$first_access=&get_first_access($interval[1],undef,$item); |
| |
} else { |
| |
$first_access=&get_first_access($interval[1]); |
| |
} |
| |
if ($first_access) { |
| |
my $timesup = $first_access+$timelimit; |
| |
if ($timesup > $now) { |
| |
my $activeblock; |
| |
foreach my $res (@to_test) { |
| |
if ($res->answerable()) { |
| |
$activeblock = 1; |
| |
last; |
| |
} |
| |
} |
| |
if ($activeblock) { |
| |
if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') { |
| |
if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'maps'}})) { |
| |
$blockers{$block}{'maps'} = $commblocks{$block}{'blocks'}{'docs'}{'maps'}; |
| |
} |
| |
} |
| |
if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') { |
| |
if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'resources'}})) { |
| |
$blockers{$block}{'resources'} = $commblocks{$block}{'blocks'}{'docs'}{'resources'}; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return %blockers; |
| |
} |
| |
|
| |
sub has_comm_blocking { |
| |
my ($priv,$symb,$uri,$ignoresymbdb,$noenccheck,$blocked,$blocks) = @_; |
| |
my @blockers; |
| |
return unless ($env{'request.course.id'}); |
| |
return unless ($priv eq 'bre'); |
| |
return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/); |
| |
return if ($env{'request.state'} eq 'construct'); |
| |
my %blockinfo; |
| |
if (ref($blocks) eq 'HASH') { |
| |
%blockinfo = &get_commblock_resources($blocks); |
| |
} else { |
| |
&load_all_blockers($env{'user.name'},$env{'user.domain'}); |
| |
%blockinfo = %cachedblockers; |
| |
} |
| |
return unless (keys(%blockinfo) > 0); |
| |
my (%possibles,@symbs); |
| |
if (!$symb) { |
| |
$symb = &symbread($uri,1,1,1,\%possibles,$ignoresymbdb,$noenccheck); |
| |
} |
| |
if ($symb) { |
| |
@symbs = ($symb); |
| |
} elsif (keys(%possibles)) { |
| |
@symbs = keys(%possibles); |
| |
} |
| |
my $noblock; |
| |
foreach my $symb (@symbs) { |
| |
last if ($noblock); |
| |
my ($map,$resid,$resurl)=&decode_symb($symb); |
| |
foreach my $block (keys(%blockinfo)) { |
| |
if ($block =~ /^firstaccess____(.+)$/) { |
| |
my $item = $1; |
| |
unless ($blocked) { |
| |
if (($item eq $map) || ($item eq $symb)) { |
| |
$noblock = 1; |
| |
last; |
| |
} |
| |
} |
| |
} |
| |
if (ref($blockinfo{$block}) eq 'HASH') { |
| |
if (ref($blockinfo{$block}{'resources'}) eq 'HASH') { |
| |
if ($blockinfo{$block}{'resources'}{$symb}) { |
| |
unless (grep(/^\Q$block\E$/,@blockers)) { |
| |
push(@blockers,$block); |
| |
} |
| |
} |
| |
} |
| |
if (ref($blockinfo{$block}{'maps'}) eq 'HASH') { |
| |
if ($blockinfo{$block}{'maps'}{$map}) { |
| |
unless (grep(/^\Q$block\E$/,@blockers)) { |
| |
push(@blockers,$block); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
unless ($noblock) { |
| |
return @blockers; |
| |
} |
| |
return; |
| |
} |
| |
} |
| |
|
| |
sub deeplink_check { |
| |
my ($priv,$symb,$uri) = @_; |
| |
return unless ($env{'request.course.id'}); |
| |
return unless ($priv eq 'bre'); |
| |
return if ($env{'request.state'} eq 'construct'); |
| |
return if ($env{'request.role.adv'}); |
| |
my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; |
| |
my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; |
| |
my (%possibles,@symbs); |
| |
if (!$symb) { |
| |
$symb = &symbread($uri,1,1,1,\%possibles); |
| |
} |
| |
if ($symb) { |
| |
@symbs = ($symb); |
| |
} elsif (keys(%possibles)) { |
| |
@symbs = keys(%possibles); |
| |
} |
| |
|
| |
my ($login,$switchrole,$allow); |
| |
if ($env{'request.deeplink.login'} =~ m{^\Q/tiny/$cdom/\E(\w+)$}) { |
| |
my $key = $1; |
| |
my $tinyurl; |
| |
my ($result,$cached)=&Apache::lonnet::is_cached_new('tiny',$cdom."\0".$key); |
| |
if (defined($cached)) { |
| |
$tinyurl = $result; |
| |
} else { |
| |
my $configuname = &Apache::lonnet::get_domainconfiguser($cdom); |
| |
my %currtiny = &Apache::lonnet::get('tiny',[$key],$cdom,$configuname); |
| |
if ($currtiny{$key} ne '') { |
| |
$tinyurl = $currtiny{$key}; |
| |
&Apache::lonnet::do_cache_new('tiny',$cdom."\0".$key,$currtiny{$key},600); |
| |
} |
| |
} |
| |
if ($tinyurl ne '') { |
| |
my ($cnumreq,$posslogin) = split(/\&/,$tinyurl); |
| |
if ($cnumreq eq $cnum) { |
| |
$login = $posslogin; |
| |
} else { |
| |
$switchrole = 1; |
| |
} |
| |
} |
| |
} |
| |
foreach my $symb (@symbs) { |
| |
last if ($allow); |
| |
my $deeplink = &EXT("resource.0.deeplink",$symb); |
| |
if ($deeplink eq '') { |
| |
$allow = 1; |
| |
} else { |
| |
my ($listed,$scope,$access) = split(/,/,$deeplink); |
| |
if ($access eq 'any') { |
| |
$allow = 1; |
| |
} elsif ($login) { |
| |
if ($access eq 'only') { |
| |
if ($scope eq 'res') { |
| |
if ($symb eq $login) { |
| |
$allow = 1; |
| |
} |
| |
} elsif ($scope eq 'map') { |
| |
#FIXME Compare map for $env{'request.deeplink.login'} with map for $symb |
| |
} elsif ($scope eq 'rec') { |
| |
#FIXME Recurse up for $env{'request.deeplink.login'} with map for $symb |
| |
} |
| |
} else { |
| |
my ($acctype,$item) = split(/:/,$access); |
| |
if (($acctype eq 'lti') && ($env{'user.linkprotector'})) { |
| |
if (grep(/^\Q$item\E$/,split(/,/,$env{'user.linkprotector'}))) { |
| |
my %tinyurls = &get('tiny',[$symb],$cdom,$cnum); |
| |
if (grep(/\Q$tinyurls{$symb}\E$/,split(/,/,$env{'user.linkproturis'}))) { |
| |
$allow = 1; |
| |
} |
| |
} |
| |
} elsif (($acctype eq 'key') && ($env{'user.deeplinkkey'})) { |
| |
if (grep(/^\Q$item\E$/,split(/,/,$env{'user.deeplinkkey'}))) { |
| |
my %tinyurls = &get('tiny',[$symb],$cdom,$cnum); |
| |
if (grep(/\Q$tinyurls{$symb}\E$/,split(/,/,$env{'user.keyedlinkuri'}))) { |
| |
$allow = 1; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return if ($allow); |
| |
return 1; |
| |
} |
| |
|
| |
# -------------------------------- Deversion and split uri into path an filename |
| |
|
| |
# |
| |
# Removes the version from a URI and |
| |
# splits it in to its filename and path to the filename. |
| |
# Seems like File::Basename could have done this more clearly. |
| |
# Parameters: |
| |
# $uri - input URI |
| |
# Returns: |
| |
# Two element list consisting of |
| |
# $pathname - the URI up to and excluding the trailing / |
| |
# $filename - The part of the URI following the last / |
| |
# NOTE: |
| |
# Another realization of this is simply: |
| |
# use File::Basename; |
| |
# ... |
| |
# $uri = shift; |
| |
# $filename = basename($uri); |
| |
# $path = dirname($uri); |
| |
# return ($filename, $path); |
| |
# |
| |
# The implementation below is probably faster however. |
| |
# |
| sub split_uri_for_cond { |
sub split_uri_for_cond { |
| my $uri=&deversion(&declutter(shift)); |
my $uri=&deversion(&declutter(shift)); |
| my @uriparts=split(/\//,$uri); |
my @uriparts=split(/\//,$uri); |
|
Line 4105 sub get_symb_from_alias {
|
Line 9130 sub get_symb_from_alias {
|
| |
|
| sub definerole { |
sub definerole { |
| if (allowed('mcr','/')) { |
if (allowed('mcr','/')) { |
| my ($rolename,$sysrole,$domrole,$courole)=@_; |
my ($rolename,$sysrole,$domrole,$courole,$uname,$udom)=@_; |
| foreach my $role (split(':',$sysrole)) { |
foreach my $role (split(':',$sysrole)) { |
| my ($crole,$cqual)=split(/\&/,$role); |
my ($crole,$cqual)=split(/\&/,$role); |
| if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; } |
if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; } |
|
Line 4133 sub definerole {
|
Line 9158 sub definerole {
|
| } |
} |
| } |
} |
| } |
} |
| |
my $uhome; |
| |
if (($uname ne '') && ($udom ne '')) { |
| |
$uhome = &homeserver($uname,$udom); |
| |
return $uhome if ($uhome eq 'no_host'); |
| |
} else { |
| |
$uname = $env{'user.name'}; |
| |
$udom = $env{'user.domain'}; |
| |
$uhome = $env{'user.home'}; |
| |
} |
| my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:". |
my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:". |
| "$env{'user.domain'}:$env{'user.name'}:". |
"$udom:$uname:rolesdef_$rolename=". |
| "rolesdef_$rolename=". |
|
| escape($sysrole.'_'.$domrole.'_'.$courole); |
escape($sysrole.'_'.$domrole.'_'.$courole); |
| return reply($command,$env{'user.home'}); |
return reply($command,$uhome); |
| } else { |
} else { |
| return 'refused'; |
return 'refused'; |
| } |
} |
|
Line 4146 sub definerole {
|
Line 9179 sub definerole {
|
| # ---------------- Make a metadata query against the network of library servers |
# ---------------- Make a metadata query against the network of library servers |
| |
|
| sub metadata_query { |
sub metadata_query { |
| my ($query,$custom,$customshow,$server_array)=@_; |
my ($query,$custom,$customshow,$server_array,$domains_hash)=@_; |
| my %rhash; |
my %rhash; |
| |
my %libserv = &all_library(); |
| my @server_list = (defined($server_array) ? @$server_array |
my @server_list = (defined($server_array) ? @$server_array |
| : keys(%libserv) ); |
: keys(%libserv) ); |
| for my $server (@server_list) { |
for my $server (@server_list) { |
| |
my $domains = ''; |
| |
if (ref($domains_hash) eq 'HASH') { |
| |
$domains = $domains_hash->{$server}; |
| |
} |
| unless ($custom or $customshow) { |
unless ($custom or $customshow) { |
| my $reply=&reply("querysend:".&escape($query),$server); |
my $reply=&reply("querysend:".&escape($query).':::'.&escape($domains),$server); |
| $rhash{$server}=$reply; |
$rhash{$server}=$reply; |
| } |
} |
| else { |
else { |
| my $reply=&reply("querysend:".&escape($query).':'. |
my $reply=&reply("querysend:".&escape($query).':'. |
| &escape($custom).':'.&escape($customshow), |
&escape($custom).':'.&escape($customshow).':'.&escape($domains), |
| $server); |
$server); |
| $rhash{$server}=$reply; |
$rhash{$server}=$reply; |
| } |
} |
|
Line 4171 sub log_query {
|
Line 9209 sub log_query {
|
| my ($uname,$udom,$query,%filters)=@_; |
my ($uname,$udom,$query,%filters)=@_; |
| my $uhome=&homeserver($uname,$udom); |
my $uhome=&homeserver($uname,$udom); |
| if ($uhome eq 'no_host') { return 'error: no_host'; } |
if ($uhome eq 'no_host') { return 'error: no_host'; } |
| my $uhost=$hostname{$uhome}; |
my $uhost=&hostname($uhome); |
| my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys(%filters))); |
my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys(%filters))); |
| my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command, |
my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command, |
| $uhome); |
$uhome); |
|
Line 4183 sub log_query {
|
Line 9221 sub log_query {
|
| |
|
| sub update_portfolio_table { |
sub update_portfolio_table { |
| my ($uname,$udom,$file_name,$query,$group,$action) = @_; |
my ($uname,$udom,$file_name,$query,$group,$action) = @_; |
| |
if ($group ne '') { |
| |
$file_name =~s /^\Q$group\E//; |
| |
} |
| my $homeserver = &homeserver($uname,$udom); |
my $homeserver = &homeserver($uname,$udom); |
| my $queryid= |
my $queryid= |
| &reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group). |
&reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group). |
|
Line 4191 sub update_portfolio_table {
|
Line 9232 sub update_portfolio_table {
|
| return $reply; |
return $reply; |
| } |
} |
| |
|
| |
# -------------------------- Update MySQL allusers table |
| |
|
| |
sub update_allusers_table { |
| |
my ($uname,$udom,$names) = @_; |
| |
my $homeserver = &homeserver($uname,$udom); |
| |
my $queryid= |
| |
&reply('querysend:allusers:'.&escape($uname).':'.&escape($udom).':'. |
| |
'lastname='.&escape($names->{'lastname'}).'%%'. |
| |
'firstname='.&escape($names->{'firstname'}).'%%'. |
| |
'middlename='.&escape($names->{'middlename'}).'%%'. |
| |
'generation='.&escape($names->{'generation'}).'%%'. |
| |
'permanentemail='.&escape($names->{'permanentemail'}).'%%'. |
| |
'id='.&escape($names->{'id'}),$homeserver); |
| |
return; |
| |
} |
| |
|
| # ------- Request retrieval of institutional classlists for course(s) |
# ------- Request retrieval of institutional classlists for course(s) |
| |
|
| sub fetch_enrollment_query { |
sub fetch_enrollment_query { |
| my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_; |
my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_; |
| my $homeserver; |
my ($homeserver,$sleep,$loopmax); |
| my $maxtries = 1; |
my $maxtries = 1; |
| if ($context eq 'automated') { |
if ($context eq 'automated') { |
| $homeserver = $perlvar{'lonHostID'}; |
$homeserver = $perlvar{'lonHostID'}; |
| |
$sleep = 2; |
| |
$loopmax = 100; |
| $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout |
$maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout |
| } else { |
} else { |
| $homeserver = &homeserver($cnum,$dom); |
$homeserver = &homeserver($cnum,$dom); |
| } |
} |
| 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 4216 sub fetch_enrollment_query {
|
Line 9275 sub fetch_enrollment_query {
|
| &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); |
&logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); |
| return 'error: '.$queryid; |
return 'error: '.$queryid; |
| } |
} |
| my $reply = &get_query_reply($queryid); |
my $reply = &get_query_reply($queryid,$sleep,$loopmax); |
| my $tries = 1; |
my $tries = 1; |
| while (($reply=~/^timeout/) && ($tries < $maxtries)) { |
while (($reply=~/^timeout/) && ($tries < $maxtries)) { |
| $reply = &get_query_reply($queryid); |
$reply = &get_query_reply($queryid,$sleep,$loopmax); |
| $tries ++; |
$tries ++; |
| } |
} |
| if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { |
if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { |
| &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries); |
&logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries); |
| } else { |
} else { |
| my @responses = split/:/,$reply; |
my @responses = split(/:/,$reply); |
| if ($homeserver eq $perlvar{'lonHostID'}) { |
if (grep { $_ eq $homeserver } ¤t_machine_ids()) { |
| foreach my $line (@responses) { |
foreach my $line (@responses) { |
| my ($key,$value) = split(/=/,$line,2); |
my ($key,$value) = split(/=/,$line,2); |
| $$replyref{$key} = $value; |
$$replyref{$key} = $value; |
| } |
} |
| } else { |
} else { |
| my $pathname = $perlvar{'lonDaemons'}.'/tmp'; |
my $pathname = LONCAPA::tempdir(); |
| foreach my $line (@responses) { |
foreach my $line (@responses) { |
| my ($key,$value) = split(/=/,$line); |
my ($key,$value) = split(/=/,$line); |
| $$replyref{$key} = $value; |
$$replyref{$key} = $value; |
|
Line 4244 sub fetch_enrollment_query {
|
Line 9303 sub fetch_enrollment_query {
|
| if ($xml_classlist =~ /^error/) { |
if ($xml_classlist =~ /^error/) { |
| &logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum); |
&logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum); |
| } else { |
} else { |
| if ( open(FILE,">$destname") ) { |
if ( open(FILE,">",$destname) ) { |
| print FILE &unescape($xml_classlist); |
print FILE &unescape($xml_classlist); |
| close(FILE); |
close(FILE); |
| } else { |
} else { |
|
Line 4261 sub fetch_enrollment_query {
|
Line 9320 sub fetch_enrollment_query {
|
| } |
} |
| |
|
| sub get_query_reply { |
sub get_query_reply { |
| my $queryid=shift; |
my ($queryid,$sleep,$loopmax) = @_;; |
| my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid; |
if (($sleep eq '') || ($sleep !~ /^\d+\.?\d*$/)) { |
| |
$sleep = 0.2; |
| |
} |
| |
if (($loopmax eq '') || ($loopmax =~ /\D/)) { |
| |
$loopmax = 100; |
| |
} |
| |
my $replyfile=LONCAPA::tempdir().$queryid; |
| my $reply=''; |
my $reply=''; |
| for (1..100) { |
for (1..$loopmax) { |
| sleep 2; |
sleep($sleep); |
| if (-e $replyfile.'.end') { |
if (-e $replyfile.'.end') { |
| if (open(my $fh,$replyfile)) { |
if (open(my $fh,"<",$replyfile)) { |
| $reply.=<$fh>; |
$reply = join('',<$fh>); |
| close($fh); |
close($fh); |
| } else { return 'error: reply_file_error'; } |
} else { return 'error: reply_file_error'; } |
| return &unescape($reply); |
return &unescape($reply); |
| } |
} |
|
Line 4300 sub courselog_query {
|
Line 9365 sub courselog_query {
|
| } |
} |
| |
|
| sub userlog_query { |
sub userlog_query { |
| |
# |
| |
# possible filters: |
| |
# action: log check role |
| |
# start: timestamp |
| |
# end: timestamp |
| |
# |
| my ($uname,$udom,%filters)=@_; |
my ($uname,$udom,%filters)=@_; |
| return &log_query($uname,$udom,'userlog',%filters); |
return &log_query($uname,$udom,'userlog',%filters); |
| } |
} |
|
Line 4308 sub userlog_query {
|
Line 9379 sub userlog_query {
|
| |
|
| sub auto_run { |
sub auto_run { |
| my ($cnum,$cdom) = @_; |
my ($cnum,$cdom) = @_; |
| my $homeserver = &homeserver($cnum,$cdom); |
my $response = 0; |
| my $response = &reply('autorun:'.$cdom,$homeserver); |
my $settings; |
| |
my %domconfig = &get_dom('configuration',['autoenroll'],$cdom); |
| |
if (ref($domconfig{'autoenroll'}) eq 'HASH') { |
| |
$settings = $domconfig{'autoenroll'}; |
| |
if ($settings->{'run'} eq '1') { |
| |
$response = 1; |
| |
} |
| |
} else { |
| |
my $homeserver; |
| |
if (&is_course($cdom,$cnum)) { |
| |
$homeserver = &homeserver($cnum,$cdom); |
| |
} else { |
| |
$homeserver = &domain($cdom,'primary'); |
| |
} |
| |
if ($homeserver ne 'no_host') { |
| |
$response = &reply('autorun:'.$cdom,$homeserver); |
| |
} |
| |
} |
| return $response; |
return $response; |
| } |
} |
| |
|
| 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; |
| } |
} |
| |
|
| sub auto_new_course { |
sub auto_new_course { |
| my ($cnum,$cdom,$inst_course_id,$owner) = @_; |
my ($cnum,$cdom,$inst_course_id,$owner,$coowners) = @_; |
| my $homeserver = &homeserver($cnum,$cdom); |
my $homeserver = &homeserver($cnum,$cdom); |
| my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver)); |
my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.&escape($owner).':'.$cdom.':'.&escape($coowners),$homeserver)); |
| return $response; |
return $response; |
| } |
} |
| |
|
|
Line 4338 sub auto_validate_courseID {
|
Line 9436 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,$defaultcredits) = map { &unescape($_); } split('&',$response,3); |
| |
return ($outcome,$description,$defaultcredits); |
| |
} |
| |
|
| |
sub auto_validate_inst_crosslist { |
| |
my ($cnum,$cdom,$instcode,$inst_xlist,$coowner) = @_; |
| |
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'); |
| |
} |
| |
} |
| |
unless (($homeserver eq '') || ($homeserver eq 'no_host')) { |
| |
$response=&reply('autovalidateinstcrosslist:'.$cdom.':'. |
| |
&escape($instcode).':'.&escape($inst_xlist).':'. |
| |
&escape($coowner),$homeserver); |
| |
} |
| |
return $response; |
| |
} |
| |
|
| sub auto_create_password { |
sub auto_create_password { |
| my ($cnum,$cdom,$authparam) = @_; |
my ($cnum,$cdom,$authparam,$udom) = @_; |
| my $homeserver = &homeserver($cnum,$cdom); |
my ($homeserver,$response); |
| my $create_passwd = 0; |
my $create_passwd = 0; |
| my $authchk = ''; |
my $authchk = ''; |
| my $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver)); |
if ($udom =~ /^$match_domain$/) { |
| if ($response eq 'refused') { |
$homeserver = &domain($udom,'primary'); |
| $authchk = 'refused'; |
} |
| |
if ($homeserver eq '') { |
| |
if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) { |
| |
$homeserver = &homeserver($cnum,$cdom); |
| |
} |
| |
} |
| |
if ($homeserver eq '') { |
| |
$authchk = 'nodomain'; |
| } else { |
} else { |
| ($authparam,$create_passwd,$authchk) = split/:/,$response; |
$response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver)); |
| |
if ($response eq 'refused') { |
| |
$authchk = 'refused'; |
| |
} else { |
| |
($authparam,$create_passwd,$authchk) = split(/:/,$response); |
| |
} |
| } |
} |
| return ($authparam,$create_passwd,$authchk); |
return ($authparam,$create_passwd,$authchk); |
| } |
} |
|
Line 4394 sub auto_photochoice {
|
Line 9540 sub auto_photochoice {
|
| sub auto_photoupdate { |
sub auto_photoupdate { |
| my ($affiliatesref,$dom,$cnum,$photo) = @_; |
my ($affiliatesref,$dom,$cnum,$photo) = @_; |
| my $homeserver = &homeserver($cnum,$dom); |
my $homeserver = &homeserver($cnum,$dom); |
| my $host=$hostname{$homeserver}; |
my $host=&hostname($homeserver); |
| my $cmd = ''; |
my $cmd = ''; |
| my $maxtries = 1; |
my $maxtries = 1; |
| foreach my $affiliate (keys(%{$affiliatesref})) { |
foreach my $affiliate (keys(%{$affiliatesref})) { |
|
Line 4434 sub auto_instcode_format {
|
Line 9580 sub auto_instcode_format {
|
| my $courses = ''; |
my $courses = ''; |
| my @homeservers; |
my @homeservers; |
| if ($caller eq 'global') { |
if ($caller eq 'global') { |
| foreach my $tryserver (keys(%libserv)) { |
my %servers = &get_servers($codedom,'library'); |
| if ($hostdom{$tryserver} eq $codedom) { |
foreach my $tryserver (keys(%servers)) { |
| if (!grep(/^\Q$tryserver\E$/,@homeservers)) { |
if (!grep(/^\Q$tryserver\E$/,@homeservers)) { |
| 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 { |
|
Line 4455 sub auto_instcode_format {
|
Line 9607 sub auto_instcode_format {
|
| $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server); |
$response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server); |
| if ($response !~ /(con_lost|error|no_such_host|refused)/) { |
if ($response !~ /(con_lost|error|no_such_host|refused)/) { |
| my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = |
my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = |
| split/:/,$response; |
split(/:/,$response); |
| %{$codes} = (%{$codes},&str2hash($codes_str)); |
%{$codes} = (%{$codes},&str2hash($codes_str)); |
| push(@{$codetitles},&str2array($codetitles_str)); |
push(@{$codetitles},&str2array($codetitles_str)); |
| %{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str)); |
%{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str)); |
|
Line 4473 sub auto_instcode_format {
|
Line 9625 sub auto_instcode_format {
|
| sub auto_instcode_defaults { |
sub auto_instcode_defaults { |
| my ($domain,$returnhash,$code_order) = @_; |
my ($domain,$returnhash,$code_order) = @_; |
| my @homeservers; |
my @homeservers; |
| foreach my $tryserver (keys(%libserv)) { |
|
| if ($hostdom{$tryserver} eq $domain) { |
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('autoinstcodedefaults:'.$domain,$server); |
| |
next if ($response =~ /(con_lost|error|no_such_host|refused)/); |
| |
|
| |
foreach my $pair (split(/\&/,$response)) { |
| |
my ($name,$value)=split(/\=/,$pair); |
| |
if ($name eq 'code_order') { |
| |
@{$code_order} = split(/\&/,&unescape($value)); |
| |
} else { |
| |
$returnhash->{&unescape($name)}=&unescape($value); |
| |
} |
| |
} |
| |
return 'ok'; |
| |
} |
| |
|
| |
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)) { |
if (!grep(/^\Q$tryserver\E$/,@homeservers)) { |
| push(@homeservers,$tryserver); |
push(@homeservers,$tryserver); |
| } |
} |
| } |
} |
| } |
} |
| my $ok_response = 0; |
|
| my $response; |
my $response; |
| while (@homeservers > 0 && $ok_response == 0) { |
foreach my $server (@homeservers) { |
| my $server = shift(@homeservers); |
$response=&reply('autopossibleinstcodes:'.$domain,$server); |
| $response=&reply('autoinstcodedefaults:'.$domain,$server); |
next if ($response =~ /(con_lost|error|no_such_host|refused)/); |
| if ($response !~ /(con_lost|error|no_such_host|refused)/) { |
my ($codetitlestr,$codeorderstr,$cat_title,$cat_order) = |
| foreach my $pair (split(/\&/,$response)) { |
split(':',$response); |
| my ($name,$value)=split(/\=/,$pair); |
@{$codetitles} = map { &unescape($_); } (split('&',$codetitlestr)); |
| if ($name eq 'code_order') { |
@{$code_order} = map { &unescape($_); } (split('&',$codeorderstr)); |
| @{$code_order} = split(/\&/,&unescape($value)); |
foreach my $item (split('&',$cat_title)) { |
| } else { |
my ($name,$value)=split('=',$item); |
| $returnhash->{&unescape($name)}=&unescape($value); |
$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); |
| } |
} |
| $ok_response = 1; |
|
| } |
} |
| } |
} |
| if ($ok_response) { |
return %validations; |
| return 'ok'; |
} |
| } else { |
|
| return $response; |
sub auto_courserequest_validation { |
| |
my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist,$custominfo) = @_; |
| |
my ($homeserver,$response); |
| |
if ($dom =~ /^$match_domain$/) { |
| |
$homeserver = &domain($dom,'primary'); |
| |
} |
| |
unless ($homeserver eq 'no_host') { |
| |
my $customdata; |
| |
if (ref($custominfo) eq 'HASH') { |
| |
$customdata = &freeze_escape($custominfo); |
| |
} |
| |
$response=&unescape(&reply('autocrsreqvalidation:'.$dom.':'.&escape($owner). |
| |
':'.&escape($crstype).':'.&escape($inststatuslist). |
| |
':'.&escape($instcode).':'.&escape($instseclist).':'. |
| |
$customdata,$homeserver)); |
| } |
} |
| } |
return $response; |
| |
} |
| |
|
| sub auto_validate_class_sec { |
sub auto_validate_class_sec { |
| my ($cdom,$cnum,$owner,$inst_class) = @_; |
my ($cdom,$cnum,$owners,$inst_class) = @_; |
| my $homeserver = &homeserver($cnum,$cdom); |
my $homeserver = &homeserver($cnum,$cdom); |
| |
my $ownerlist; |
| |
if (ref($owners) eq 'ARRAY') { |
| |
$ownerlist = join(',',@{$owners}); |
| |
} else { |
| |
$ownerlist = $owners; |
| |
} |
| my $response=&reply('autovalidateclass_sec:'.$inst_class.':'. |
my $response=&reply('autovalidateclass_sec:'.$inst_class.':'. |
| &escape($owner).':'.$cdom,$homeserver); |
&escape($ownerlist).':'.$cdom,$homeserver); |
| return $response; |
return $response; |
| } |
} |
| |
|
| |
sub auto_validate_instclasses { |
| |
my ($cdom,$cnum,$owners,$classesref) = @_; |
| |
my ($homeserver,%validations); |
| |
$homeserver = &homeserver($cnum,$cdom); |
| |
unless ($homeserver eq 'no_host') { |
| |
my $ownerlist; |
| |
if (ref($owners) eq 'ARRAY') { |
| |
$ownerlist = join(',',@{$owners}); |
| |
} else { |
| |
$ownerlist = $owners; |
| |
} |
| |
if (ref($classesref) eq 'HASH') { |
| |
my $classes = &freeze_escape($classesref); |
| |
my $response=&reply('autovalidateinstclasses:'.&escape($ownerlist). |
| |
':'.$cdom.':'.$classes,$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_crsreq_update { |
| |
my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title, |
| |
$code,$accessstart,$accessend,$inbound) = @_; |
| |
my ($homeserver,%crsreqresponse); |
| |
if ($cdom =~ /^$match_domain$/) { |
| |
$homeserver = &domain($cdom,'primary'); |
| |
} |
| |
unless (($homeserver eq 'no_host') || ($homeserver eq '')) { |
| |
my $info; |
| |
if (ref($inbound) eq 'HASH') { |
| |
$info = &freeze_escape($inbound); |
| |
} |
| |
my $response=&reply('autocrsrequpdate:'.$cdom.':'.$cnum.':'.&escape($crstype). |
| |
':'.&escape($action).':'.&escape($ownername).':'. |
| |
&escape($ownerdomain).':'.&escape($fullname).':'. |
| |
&escape($title).':'.&escape($code).':'. |
| |
&escape($accessstart).':'.&escape($accessend).':'.$info, |
| |
$homeserver); |
| |
unless ($response =~ /(con_lost|error|no_such_host|refused)/) { |
| |
my @items = split(/&/,$response); |
| |
foreach my $item (@items) { |
| |
my ($key,$value) = split('=',$item); |
| |
$crsreqresponse{&unescape($key)} = &thaw_unescape($value); |
| |
} |
| |
} |
| |
} |
| |
return \%crsreqresponse; |
| |
} |
| |
|
| |
sub auto_export_grades { |
| |
my ($cdom,$cnum,$inforef,$gradesref) = @_; |
| |
my ($homeserver,%exportresponse); |
| |
if ($cdom =~ /^$match_domain$/) { |
| |
$homeserver = &domain($cdom,'primary'); |
| |
} |
| |
unless (($homeserver eq 'no_host') || ($homeserver eq '')) { |
| |
my $info; |
| |
if (ref($inforef) eq 'HASH') { |
| |
$info = &freeze_escape($inforef); |
| |
} |
| |
if (ref($gradesref) eq 'HASH') { |
| |
my $grades = &freeze_escape($gradesref); |
| |
my $response=&reply('encrypt:autoexportgrades:'.$cdom.':'.$cnum.':'. |
| |
$info.':'.$grades,$homeserver); |
| |
unless ($response =~ /(con_lost|error|no_such_host|refused|unknown_command)/) { |
| |
my @items = split(/&/,$response); |
| |
foreach my $item (@items) { |
| |
my ($key,$value) = split('=',$item); |
| |
$exportresponse{&unescape($key)} = &thaw_unescape($value); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return \%exportresponse; |
| |
} |
| |
|
| |
sub check_instcode_cloning { |
| |
my ($codedefaults,$code_order,$cloner,$clonefromcode,$clonetocode) = @_; |
| |
unless ((ref($codedefaults) eq 'HASH') && (ref($code_order) eq 'ARRAY')) { |
| |
return; |
| |
} |
| |
my $canclone; |
| |
if (@{$code_order} > 0) { |
| |
my $instcoderegexp ='^'; |
| |
my @clonecodes = split(/\&/,$cloner); |
| |
foreach my $item (@{$code_order}) { |
| |
if (grep(/^\Q$item\E=/,@clonecodes)) { |
| |
foreach my $pair (@clonecodes) { |
| |
my ($key,$val) = split(/\=/,$pair,2); |
| |
$val = &unescape($val); |
| |
if ($key eq $item) { |
| |
$instcoderegexp .= '('.$val.')'; |
| |
last; |
| |
} |
| |
} |
| |
} else { |
| |
$instcoderegexp .= $codedefaults->{$item}; |
| |
} |
| |
} |
| |
$instcoderegexp .= '$'; |
| |
my (@from,@to); |
| |
eval { |
| |
(@from) = ($clonefromcode =~ /$instcoderegexp/); |
| |
(@to) = ($clonetocode =~ /$instcoderegexp/); |
| |
}; |
| |
if ((@from > 0) && (@to > 0)) { |
| |
my @diffs = &Apache::loncommon::compare_arrays(\@from,\@to); |
| |
if (!@diffs) { |
| |
$canclone = 1; |
| |
} |
| |
} |
| |
} |
| |
return $canclone; |
| |
} |
| |
|
| |
sub default_instcode_cloning { |
| |
my ($clonedom,$domdefclone,$clonefromcode,$clonetocode,$codedefaultsref,$codeorderref) = @_; |
| |
my (%codedefaults,@code_order,$canclone); |
| |
if ((ref($codedefaultsref) eq 'HASH') && (ref($codeorderref) eq 'ARRAY')) { |
| |
%codedefaults = %{$codedefaultsref}; |
| |
@code_order = @{$codeorderref}; |
| |
} elsif ($clonedom) { |
| |
&auto_instcode_defaults($clonedom,\%codedefaults,\@code_order); |
| |
} |
| |
if (($domdefclone) && (@code_order)) { |
| |
my @clonecodes = split(/\+/,$domdefclone); |
| |
my $instcoderegexp ='^'; |
| |
foreach my $item (@code_order) { |
| |
if (grep(/^\Q$item\E$/,@clonecodes)) { |
| |
$instcoderegexp .= '('.$codedefaults{$item}.')'; |
| |
} else { |
| |
$instcoderegexp .= $codedefaults{$item}; |
| |
} |
| |
} |
| |
$instcoderegexp .= '$'; |
| |
my (@from,@to); |
| |
eval { |
| |
(@from) = ($clonefromcode =~ /$instcoderegexp/); |
| |
(@to) = ($clonetocode =~ /$instcoderegexp/); |
| |
}; |
| |
if ((@from > 0) && (@to > 0)) { |
| |
my @diffs = &Apache::loncommon::compare_arrays(\@from,\@to); |
| |
if (!@diffs) { |
| |
$canclone = 1; |
| |
} |
| |
} |
| |
} |
| |
return $canclone; |
| |
} |
| |
|
| # ------------------------------------------------------- Course Group routines |
# ------------------------------------------------------- Course Group routines |
| |
|
| sub get_coursegroups { |
sub get_coursegroups { |
|
Line 4556 sub toggle_coursegroup_status {
|
Line 9944 sub toggle_coursegroup_status {
|
| } |
} |
| |
|
| sub modify_group_roles { |
sub modify_group_roles { |
| my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_; |
my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs,$selfenroll,$context) = @_; |
| my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id; |
my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id; |
| my $role = 'gr/'.&escape($userprivs); |
my $role = 'gr/'.&escape($userprivs); |
| my ($uname,$udom) = split(/:/,$user); |
my ($uname,$udom) = split(/:/,$user); |
| my $result = &assignrole($udom,$uname,$url,$role,$end,$start); |
my $result = &assignrole($udom,$uname,$url,$role,$end,$start,'',$selfenroll,$context); |
| if ($result eq 'ok') { |
if ($result eq 'ok') { |
| &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum); |
&devalidate_getgroups_cache($udom,$uname,$cdom,$cnum); |
| } |
} |
|
Line 4649 sub devalidate_getgroups_cache {
|
Line 10037 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', |
| |
Placement => 'std', |
| ); |
); |
| 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 |
| |
|
| sub assignrole { |
sub assignrole { |
| my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_; |
my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll, |
| |
$context)=@_; |
| my $mrole; |
my $mrole; |
| if ($role =~ /^cr\//) { |
if ($role =~ /^cr\//) { |
| 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 4701 sub assignrole {
|
Line 10118 sub assignrole {
|
| } else { |
} else { |
| my $cwosec=$url; |
my $cwosec=$url; |
| $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/; |
$cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/; |
| unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) { |
if (!(&allowed('c'.$role,$cwosec)) && !(&allowed('c'.$role,$udom))) { |
| &logthis('Refused assignrole: '. |
my $refused; |
| $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. |
if (($env{'request.course.sec'} ne '') && ($role eq 'st')) { |
| $env{'user.name'}.' at '.$env{'user.domain'}); |
if (!(&allowed('c'.$role,$url))) { |
| return 'refused'; |
$refused = 1; |
| |
} |
| |
} else { |
| |
$refused = 1; |
| |
} |
| |
if ($refused) { |
| |
my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$}); |
| |
if (!$selfenroll && (($context eq 'course') || ($context eq 'ltienroll' && $env{'request.lti.login'}))) { |
| |
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) && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { |
| |
if ($role eq 'st') { |
| |
$refused = ''; |
| |
} elsif (($context eq 'ltienroll') && ($env{'request.lti.login'})) { |
| |
$refused = ''; |
| |
} |
| |
} 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 = ''; |
| |
} |
| |
} |
| |
} |
| |
} elsif ($context eq 'requestauthor') { |
| |
if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && |
| |
($url eq '/'.$udom.'/') && ($role eq 'au')) { |
| |
if ($env{'environment.requestauthor'} eq 'automatic') { |
| |
$refused = ''; |
| |
} else { |
| |
my %domdefaults = &get_domain_defaults($udom); |
| |
if (ref($domdefaults{'requestauthor'}) eq 'HASH') { |
| |
my $checkbystatus; |
| |
if ($env{'user.adv'}) { |
| |
my $disposition = $domdefaults{'requestauthor'}{'_LC_adv'}; |
| |
if ($disposition eq 'automatic') { |
| |
$refused = ''; |
| |
} elsif ($disposition eq '') { |
| |
$checkbystatus = 1; |
| |
} |
| |
} else { |
| |
$checkbystatus = 1; |
| |
} |
| |
if ($checkbystatus) { |
| |
if ($env{'environment.inststatus'}) { |
| |
my @inststatuses = split(/,/,$env{'environment.inststatus'}); |
| |
foreach my $type (@inststatuses) { |
| |
if (($type ne '') && |
| |
($domdefaults{'requestauthor'}{$type} eq 'automatic')) { |
| |
$refused = ''; |
| |
} |
| |
} |
| |
} elsif ($domdefaults{'requestauthor'}{'default'} eq 'automatic') { |
| |
$refused = ''; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if ($refused) { |
| |
&logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url. |
| |
' '.$role.' '.$end.' '.$start.' by '. |
| |
$env{'user.name'}.' at '.$env{'user.domain'}); |
| |
return 'refused'; |
| |
} |
| |
} |
| |
} elsif ($role eq 'au') { |
| |
if ($url ne '/'.$udom.'/') { |
| |
&logthis('Attempt by '.$env{'user.name'}.':'.$env{'user.domain'}. |
| |
' to assign author role for '.$uname.':'.$udom. |
| |
' in domain: '.$url.' refused (wrong domain).'); |
| |
return 'refused'; |
| |
} |
| } |
} |
| $mrole=$role; |
$mrole=$role; |
| } |
} |
|
Line 4721 sub assignrole {
|
Line 10237 sub assignrole {
|
| } |
} |
| my $origstart = $start; |
my $origstart = $start; |
| my $origend = $end; |
my $origend = $end; |
| |
my $delflag; |
| # actually delete |
# actually delete |
| if ($deleteflag) { |
if ($deleteflag) { |
| if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) { |
if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) { |
|
Line 4731 sub assignrole {
|
Line 10248 sub assignrole {
|
| # set start and finish to negative values for userrolelog |
# set start and finish to negative values for userrolelog |
| $start=-1; |
$start=-1; |
| $end=-1; |
$end=-1; |
| |
$delflag = 1; |
| } |
} |
| } |
} |
| # send command |
# send command |
|
Line 4738 sub assignrole {
|
Line 10256 sub assignrole {
|
| # log new user role if status is ok |
# log new user role if status is ok |
| if ($answer eq 'ok') { |
if ($answer eq 'ok') { |
| &userrolelog($role,$uname,$udom,$url,$start,$end); |
&userrolelog($role,$uname,$udom,$url,$start,$end); |
| |
if (($role eq 'cc') || ($role eq 'in') || |
| |
($role eq 'ep') || ($role eq 'ad') || |
| |
($role eq 'ta') || ($role eq 'st') || |
| |
($role=~/^cr/) || ($role eq 'gr') || |
| |
($role eq 'co')) { |
| # for course roles, perform group memberships changes triggered by role change. |
# for course roles, perform group memberships changes triggered by role change. |
| unless ($role =~ /^gr/) { |
unless ($role =~ /^gr/) { |
| &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend, |
&Apache::longroup::group_changes($udom,$uname,$url,$role,$origend, |
| $origstart); |
$origstart,$selfenroll,$context); |
| |
} |
| |
&courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, |
| |
$selfenroll,$context); |
| |
} elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') || |
| |
($role eq 'au') || ($role eq 'dc') || ($role eq 'dh') || |
| |
($role eq 'da')) { |
| |
&domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, |
| |
$context); |
| |
} elsif (($role eq 'ca') || ($role eq 'aa')) { |
| |
&coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, |
| |
$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'}; |
| |
my $xlists = $coursehash{'internal.crosslistings'}; |
| |
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); |
| |
unless ($result eq 'valid') { |
| |
if ($xlists ne '') { |
| |
foreach my $xlist (split(',',$xlists)) { |
| |
my ($inst_crosslist,$lcsec) = split(':',$xlist); |
| |
$result = |
| |
&auto_validate_inst_crosslist($cnum,$cdom,$instcode, |
| |
$inst_crosslist,$uname.':'.$udom); |
| |
last if ($result eq 'valid'); |
| |
} |
| |
} |
| |
} |
| |
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); |
| |
} |
| |
} elsif ($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 |
| |
|
| sub modifyuserauth { |
sub modifyuserauth { |
| my ($udom,$uname,$umode,$upass)=@_; |
my ($udom,$uname,$umode,$upass)=@_; |
| my $uhome=&homeserver($uname,$udom); |
my $uhome=&homeserver($uname,$udom); |
| unless (&allowed('mau',$udom)) { return 'refused'; } |
my $allowed; |
| |
if (&allowed('mau',$udom)) { |
| |
$allowed = 1; |
| |
} elsif (($umode eq 'internal') && ($udom eq $env{'user.domain'}) && |
| |
($env{'request.course.id'}) && (&allowed('mip',$env{'request.course.id'})) && |
| |
(!$env{'course.'.$env{'request.course.id'}.'.internal.nopasswdchg'})) { |
| |
my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; |
| |
my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; |
| |
if (($cdom ne '') && ($cnum ne '')) { |
| |
my $is_owner = &is_course_owner($cdom,$cnum); |
| |
if ($is_owner) { |
| |
$allowed = 1; |
| |
} |
| |
} |
| |
} |
| |
unless ($allowed) { return 'refused'; } |
| &logthis('Call to modify user authentication '.$udom.', '.$uname.', '. |
&logthis('Call to modify user authentication '.$udom.', '.$uname.', '. |
| $umode.' by '.$env{'user.name'}.' at '.$env{'user.domain'}. |
$umode.' by '.$env{'user.name'}.' at '.$env{'user.domain'}. |
| ' in domain '.$env{'request.role.domain'}); |
' in domain '.$env{'request.role.domain'}); |
| my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'. |
my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'. |
| &escape($upass),$uhome); |
&escape($upass),$uhome); |
| |
my $ip = &get_requestor_ip(); |
| &log($env{'user.domain'},$env{'user.name'},$env{'user.home'}, |
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'}, |
| 'Authentication changed for '.$udom.', '.$uname.', '.$umode. |
'Authentication changed for '.$udom.', '.$uname.', '.$umode. |
| '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply); |
'(Remote '.$ip.'): '.$reply); |
| &log($udom,,$uname,$uhome, |
&log($udom,,$uname,$uhome, |
| 'Authentication changed by '.$env{'user.domain'}.', '. |
'Authentication changed by '.$env{'user.domain'}.', '. |
| $env{'user.name'}.', '.$umode. |
$env{'user.name'}.', '.$umode. |
| '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply); |
'(Remote '.$ip.'): '.$reply); |
| unless ($reply eq 'ok') { |
unless ($reply eq 'ok') { |
| &logthis('Authentication mode error: '.$reply); |
&logthis('Authentication mode error: '.$reply); |
| return 'error: '.$reply; |
return 'error: '.$reply; |
|
Line 4779 sub modifyuser {
|
Line 10426 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)=@_; |
$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; |
| |
unless (($umode && ($upass ne '')) || ($umode eq 'localauth') || |
| |
($umode eq 'lti')) { |
| |
return 'error: more information needed to create new user'; |
| |
} |
| |
} |
| # ----------------------------------------------------------------- Create User |
# ----------------------------------------------------------------- Create User |
| if (($uhome eq 'no_host') && |
if (($uhome eq 'no_host') && |
| (($umode && $upass) || ($umode eq 'localauth'))) { |
(($umode && $upass) || ($umode eq 'localauth') || ($umode eq 'lti'))) { |
| my $unhome=''; |
my $unhome=''; |
| if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { |
if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) { |
| $unhome = $desiredhome; |
$unhome = $desiredhome; |
| } elsif($env{'course.'.$env{'request.course.id'}.'.domain'} eq $udom) { |
} elsif($env{'course.'.$env{'request.course.id'}.'.domain'} eq $udom) { |
| $unhome=$env{'course.'.$env{'request.course.id'}.'.home'}; |
$unhome=$env{'course.'.$env{'request.course.id'}.'.home'}; |
| } else { # load balancing routine for determining $unhome |
} else { # load balancing routine for determining $unhome |
| my $tryserver; |
|
| my $loadm=10000000; |
my $loadm=10000000; |
| foreach $tryserver (keys %libserv) { |
my %servers = &get_servers($udom,'library'); |
| if ($hostdom{$tryserver} eq $udom) { |
foreach my $tryserver (keys(%servers)) { |
| my $answer=reply('load',$tryserver); |
my $answer=reply('load',$tryserver); |
| if (($answer=~/\d+/) && ($answer<$loadm)) { |
if (($answer=~/\d+/) && ($answer<$loadm)) { |
| $loadm=$answer; |
$loadm=$answer; |
| $unhome=$tryserver; |
$unhome=$tryserver; |
| } |
} |
| } |
|
| } |
} |
| } |
} |
| if (($unhome eq '') || ($unhome eq 'no_host')) { |
if (($unhome eq '') || ($unhome eq 'no_host')) { |
|
Line 4836 sub modifyuser {
|
Line 10495 sub modifyuser {
|
| 'current user id "'.$uidhash{$uname}.'".'; |
'current user id "'.$uidhash{$uname}.'".'; |
| } |
} |
| } else { |
} else { |
| &idput($udom,($uname => $uid)); |
&idput($udom,{$uname => $uid},$uhome,'ids'); |
| } |
} |
| } |
} |
| # -------------------------------------------------------------- Add names, etc |
# -------------------------------------------------------------- Add names, etc |
| my @tmp=&get('environment', |
my @tmp=&get('environment', |
| ['firstname','middlename','lastname','generation'], |
['firstname','middlename','lastname','generation','id', |
| |
'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; } |
| if (defined($gene)) { $names{'generation'} = $gene; } |
if (defined($gene)) { $names{'generation'} = $gene; } |
| if ($email) { |
if ($email) { |
| $email=~s/[^\w\@\.\-\,]//gs; |
$email=~s/[^\w\@\.\-\,]//gs; |
| if ($email=~/\@/) { $names{'notification'} = $email; |
if ($email=~/\@/) { $names{'permanentemail'} = $email; } |
| $names{'critnotification'} = $email; |
} |
| $names{'permanentemail'} = $email; } |
if ($uid) { $names{'id'} = $uid; } |
| |
if (defined($inststatus)) { |
| |
$names{'inststatus'} = ''; |
| |
my ($usertypes,$typesorder) = &retrieve_inst_usertypes($udom); |
| |
if (ref($usertypes) eq 'HASH') { |
| |
my @okstatuses; |
| |
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.', '. |
| |
$last.', '.$gene.', '.$email.', '.$inststatus; |
| |
if ($env{'user.name'} ne '' && $env{'user.domain'}) { |
| |
$logmsg .= ' by '.$env{'user.name'}.' at '.$env{'user.domain'}; |
| |
} else { |
| |
$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); |
my $reply = &put('environment', \%names, $udom,$uname); |
| if ($reply ne 'ok') { return 'error: '.$reply; } |
if ($reply ne 'ok') { |
| |
return 'error: '.$reply; |
| |
} |
| |
if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) { |
| |
&Apache::lonnet::devalidate_cache_new('emailscache',$uname.':'.$udom); |
| |
} |
| |
my $sqlresult = &update_allusers_table($uname,$udom,\%names); |
| &devalidate_cache_new('namescache',$uname.':'.$udom); |
&devalidate_cache_new('namescache',$uname.':'.$udom); |
| &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '. |
$logmsg = 'Success modifying user '.$logmsg; |
| $umode.', '.$first.', '.$middle.', '. |
&logthis($logmsg); |
| $last.', '.$gene.' by '. |
|
| $env{'user.name'}.' at '.$env{'user.domain'}); |
|
| return 'ok'; |
return 'ok'; |
| } |
} |
| |
|
|
Line 4877 sub modifyuser {
|
Line 10604 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,$inststatus,$credits,$instsec)=@_; |
| 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 4886 sub modifystudent {
|
Line 10614 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 |
# student's environment |
| $uid = undef if (!$forceid); |
$uid = undef if (!$forceid); |
| $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last, |
$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last, |
| $gene,$usec,$end,$start,$type,$locktype,$cid); |
$gene,$usec,$end,$start,$type,$locktype, |
| |
$cid,$selfenroll,$context,$credits,$instsec); |
| return $reply; |
return $reply; |
| } |
} |
| |
|
| sub modify_student_enrollment { |
sub modify_student_enrollment { |
| my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_; |
my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type, |
| |
$locktype,$cid,$selfenroll,$context,$credits,$instsec) = @_; |
| my ($cdom,$cnum,$chome); |
my ($cdom,$cnum,$chome); |
| if (!$cid) { |
if (!$cid) { |
| unless ($cid=$env{'request.course.id'}) { |
unless ($cid=$env{'request.course.id'}) { |
|
Line 4940 sub modify_student_enrollment {
|
Line 10670 sub modify_student_enrollment {
|
| $uid = $tmp{'id'} if (!defined($uid) || $uid eq ''); |
$uid = $tmp{'id'} if (!defined($uid) || $uid eq ''); |
| } |
} |
| my $fullname = &format_name($first,$middle,$last,$gene,'lastname'); |
my $fullname = &format_name($first,$middle,$last,$gene,'lastname'); |
| |
my $user = "$uname:$udom"; |
| |
my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum); |
| my $reply=cput('classlist', |
my $reply=cput('classlist', |
| {"$uname:$udom" => |
{$user => |
| join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) }, |
join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits,$instsec) }, |
| $cdom,$cnum); |
$cdom,$cnum); |
| unless (($reply eq 'ok') || ($reply eq 'delayed')) { |
if (($reply eq 'ok') || ($reply eq 'delayed')) { |
| |
&devalidate_getsection_cache($udom,$uname,$cid); |
| |
} else { |
| return 'error: '.$reply; |
return 'error: '.$reply; |
| } else { |
|
| &devalidate_getsection_cache($udom,$uname,$cid); |
|
| } |
} |
| # Add student role to user |
# Add student role to user |
| my $uurl='/'.$cid; |
my $uurl='/'.$cid; |
|
Line 4955 sub modify_student_enrollment {
|
Line 10687 sub modify_student_enrollment {
|
| if ($usec) { |
if ($usec) { |
| $uurl.='/'.$usec; |
$uurl.='/'.$usec; |
| } |
} |
| return &assignrole($udom,$uname,$uurl,'st',$end,$start); |
my $result = &assignrole($udom,$uname,$uurl,'st',$end,$start,undef, |
| |
$selfenroll,$context); |
| |
if ($result ne 'ok') { |
| |
if ($old_entry{$user} ne '') { |
| |
$reply = &cput('classlist',\%old_entry,$cdom,$cnum); |
| |
} else { |
| |
$reply = &del('classlist',[$user],$cdom,$cnum); |
| |
} |
| |
} |
| |
return $result; |
| } |
} |
| |
|
| sub format_name { |
sub format_name { |
|
Line 5000 sub writecoursepref {
|
Line 10741 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,$callercontext)=@_; |
| $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) { |
| |
my $reload; |
| |
if (($callercontext eq 'auto') && |
| |
($ownerdom eq $env{'user.domain'}) && ($ownername eq $env{'user.name'})) { |
| |
$reload = 'reload'; |
| |
} |
| |
if (&usertools_access($ownername,$ownerdom,$category,$reload, |
| |
$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 (! exists($libserv{$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 |
| &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description). |
my $now = time; |
| ':'.&escape($inst_code).':'.&escape($course_owner).':'. |
my $newcourse = { |
| &escape($crstype),$uhome); |
$udom.'_'.$uname => { |
| &flushcourselogs(); |
description => $description, |
| |
inst_code => $inst_code, |
| |
owner => $course_owner, |
| |
type => $crstype, |
| |
creator => $env{'user.name'}.':'. |
| |
$env{'user.domain'}, |
| |
created => $now, |
| |
context => $context, |
| |
}, |
| |
}; |
| |
&courseidput($udom,$newcourse,$uhome,'notime'); |
| # set toplevel url |
# set toplevel url |
| my $topurl=$url; |
my $topurl=$url; |
| unless ($nonstandard) { |
unless ($nonstandard) { |
|
Line 5061 ENDINITMAP
|
Line 10854 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) = scalar(@_) == 1 ? |
| my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef, |
($_[0] =~ /^($match_domain)_($match_courseid)$/) : @_; |
| undef,'.'); |
|
| if (exists($courses{$cdom.'_'.$cnum})) { |
return unless (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)); |
| return 1; |
my $uhome=&homeserver($cnum,$cdom); |
| |
my $iscourse; |
| |
if (grep { $_ eq $uhome } current_machine_ids()) { |
| |
$iscourse = &LONCAPA::Lond::is_course($cdom,$cnum); |
| |
} else { |
| |
my $hashid = $cdom.':'.$cnum; |
| |
($iscourse,my $cached) = &is_cached_new('iscourse',$hashid); |
| |
unless (defined($cached)) { |
| |
my %courses = &courseiddump($cdom, '.', 1, '.', '.', |
| |
$cnum,undef,undef,'.'); |
| |
$iscourse = 0; |
| |
if (exists($courses{$cdom.'_'.$cnum})) { |
| |
$iscourse = 1; |
| |
} |
| |
&do_cache_new('iscourse',$hashid,$iscourse,3600); |
| |
} |
| } |
} |
| return 0; |
return unless ($iscourse); |
| |
return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum; |
| |
} |
| |
|
| |
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'} = &get_requestor_ip(); |
| |
$storehash->{'host'} = $perlvar{'lonHostID'}; |
| |
|
| |
my $namevalue=''; |
| |
foreach my $key (keys(%{$storehash})) { |
| |
$namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&'; |
| |
} |
| |
$namevalue=~s/\&$//; |
| |
unless ($namespace eq 'courserequests') { |
| |
$datakey = &escape($datakey); |
| |
} |
| |
$result = &reply("store:$udom:$uname:$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 { |
| my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag)=@_; |
my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag,$selfenroll,$context)=@_; |
| return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename, |
return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename, |
| $end,$start,$deleteflag); |
$end,$start,$deleteflag,$selfenroll,$context); |
| } |
} |
| |
|
| # ----------------------------------------------------------------- Revoke Role |
# ----------------------------------------------------------------- Revoke Role |
| |
|
| sub revokerole { |
sub revokerole { |
| my ($udom,$uname,$url,$role,$deleteflag)=@_; |
my ($udom,$uname,$url,$role,$deleteflag,$selfenroll,$context)=@_; |
| my $now=time; |
my $now=time; |
| return &assignrole($udom,$uname,$url,$role,$now,$deleteflag); |
return &assignrole($udom,$uname,$url,$role,$now,undef,$deleteflag,$selfenroll,$context); |
| } |
} |
| |
|
| # ---------------------------------------------------------- Revoke Custom Role |
# ---------------------------------------------------------- Revoke Custom Role |
| |
|
| sub revokecustomrole { |
sub revokecustomrole { |
| my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag)=@_; |
my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag,$selfenroll,$context)=@_; |
| my $now=time; |
my $now=time; |
| return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now, |
return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now, |
| $deleteflag); |
$deleteflag,$selfenroll,$context); |
| } |
} |
| |
|
| # ------------------------------------------------------------ Disk usage |
# ------------------------------------------------------------ Disk usage |
| sub diskusage { |
sub diskusage { |
| my ($udom,$uname,$directoryRoot)=@_; |
my ($udom,$uname,$directorypath,$getpropath)=@_; |
| $directoryRoot =~ s/\/$//; |
$directorypath =~ s/\/$//; |
| my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom)); |
my $listing=&reply('du2:'.&escape($directorypath).':' |
| |
.&escape($getpropath).':'.&escape($uname).':' |
| |
.&escape($udom),homeserver($uname,$udom)); |
| |
if ($listing eq 'unknown_cmd') { |
| |
if ($getpropath) { |
| |
$directorypath = &propath($udom,$uname).'/'.$directorypath; |
| |
} |
| |
$listing = &reply('du:'.$directorypath,homeserver($uname,$udom)); |
| |
} |
| return $listing; |
return $listing; |
| } |
} |
| |
|
| sub is_locked { |
sub is_locked { |
| my ($file_name, $domain, $user) = @_; |
my ($file_name, $domain, $user, $which) = @_; |
| my @check; |
my @check; |
| my $is_locked; |
my $is_locked; |
| push @check, $file_name; |
push (@check,$file_name); |
| my %locked = &get('file_permissions',\@check, |
my %locked = &get('file_permissions',\@check, |
| $env{'user.domain'},$env{'user.name'}); |
$env{'user.domain'},$env{'user.name'}); |
| my ($tmp)=keys(%locked); |
my ($tmp)=keys(%locked); |
|
Line 5122 sub is_locked {
|
Line 11015 sub is_locked {
|
| if (ref($locked{$file_name}) eq 'ARRAY') { |
if (ref($locked{$file_name}) eq 'ARRAY') { |
| $is_locked = 'false'; |
$is_locked = 'false'; |
| foreach my $entry (@{$locked{$file_name}}) { |
foreach my $entry (@{$locked{$file_name}}) { |
| if (ref($entry) eq 'ARRAY') { |
if (ref($entry) eq 'ARRAY') { |
| $is_locked = 'true'; |
$is_locked = 'true'; |
| last; |
if (ref($which) eq 'ARRAY') { |
| |
push(@{$which},$entry); |
| |
} else { |
| |
last; |
| |
} |
| } |
} |
| } |
} |
| } else { |
} else { |
| $is_locked = 'false'; |
$is_locked = 'false'; |
| } |
} |
| |
return $is_locked; |
| } |
} |
| |
|
| sub declutter_portfile { |
sub declutter_portfile { |
|
Line 5159 sub save_selected_files {
|
Line 11057 sub save_selected_files {
|
| my ($user, $path, @files) = @_; |
my ($user, $path, @files) = @_; |
| my $filename = $user."savedfiles"; |
my $filename = $user."savedfiles"; |
| my @other_files = &files_not_in_path($user, $path); |
my @other_files = &files_not_in_path($user, $path); |
| open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); |
open (OUT,'>',LONCAPA::tempdir().$filename); |
| foreach my $file (@files) { |
foreach my $file (@files) { |
| print (OUT $env{'form.currentpath'}.$file."\n"); |
print (OUT $env{'form.currentpath'}.$file."\n"); |
| } |
} |
|
Line 5173 sub save_selected_files {
|
Line 11071 sub save_selected_files {
|
| sub clear_selected_files { |
sub clear_selected_files { |
| my ($user) = @_; |
my ($user) = @_; |
| my $filename = $user."savedfiles"; |
my $filename = $user."savedfiles"; |
| open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); |
open (OUT,'>',LONCAPA::tempdir().$filename); |
| print (OUT undef); |
print (OUT undef); |
| close (OUT); |
close (OUT); |
| return ("ok"); |
return ("ok"); |
|
Line 5183 sub files_in_path {
|
Line 11081 sub files_in_path {
|
| my ($user, $path) = @_; |
my ($user, $path) = @_; |
| my $filename = $user."savedfiles"; |
my $filename = $user."savedfiles"; |
| my %return_files; |
my %return_files; |
| open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); |
open (IN,'<',LONCAPA::tempdir().$filename); |
| while (my $line_in = <IN>) { |
while (my $line_in = <IN>) { |
| chomp ($line_in); |
chomp ($line_in); |
| my @paths_and_file = split (m!/!, $line_in); |
my @paths_and_file = split (m!/!, $line_in); |
|
Line 5205 sub files_not_in_path {
|
Line 11103 sub files_not_in_path {
|
| my $filename = $user."savedfiles"; |
my $filename = $user."savedfiles"; |
| my @return_files; |
my @return_files; |
| my $path_part; |
my $path_part; |
| open(IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); |
open(IN, '<',LONCAPA::tempdir().$filename); |
| while (my $line = <IN>) { |
while (my $line = <IN>) { |
| #ok, I know it's clunky, but I want it to work |
#ok, I know it's clunky, but I want it to work |
| my @paths_and_file = split(m|/|, $line); |
my @paths_and_file = split(m|/|, $line); |
|
Line 5222 sub files_not_in_path {
|
Line 11120 sub files_not_in_path {
|
| return (@return_files); |
return (@return_files); |
| } |
} |
| |
|
| |
#------------------------------Submitted/Handedback Portfolio Files Versioning |
| |
|
| |
sub portfiles_versioning { |
| |
my ($symb,$domain,$stu_name,$portfiles,$versioned_portfiles) = @_; |
| |
my $portfolio_root = '/userfiles/portfolio'; |
| |
return unless ((ref($portfiles) eq 'ARRAY') && (ref($versioned_portfiles) eq 'ARRAY')); |
| |
foreach my $file (@{$portfiles}) { |
| |
&unmark_as_readonly($domain,$stu_name,[$symb,$env{'request.course.id'}],$file); |
| |
my ($directory,$answer_file) =($file =~ /^(.*?)([^\/]*)$/); |
| |
my ($answer_name,$answer_ver,$answer_ext) = &file_name_version_ext($answer_file); |
| |
my $getpropath = 1; |
| |
my ($dir_list,$listerror) = &dirlist($portfolio_root.$directory,$domain, |
| |
$stu_name,$getpropath); |
| |
my $version = &get_next_version($answer_name,$answer_ext,$dir_list); |
| |
my $new_answer = |
| |
&version_selected_portfile($domain,$stu_name,$directory,$answer_file,$version); |
| |
if ($new_answer ne 'problem getting file') { |
| |
push(@{$versioned_portfiles}, $directory.$new_answer); |
| |
&mark_as_readonly($domain,$stu_name,[$directory.$new_answer], |
| |
[$symb,$env{'request.course.id'},'graded']); |
| |
} |
| |
} |
| |
} |
| |
|
| |
sub get_next_version { |
| |
my ($answer_name, $answer_ext, $dir_list) = @_; |
| |
my $version; |
| |
if (ref($dir_list) eq 'ARRAY') { |
| |
foreach my $row (@{$dir_list}) { |
| |
my ($file) = split(/\&/,$row,2); |
| |
my ($file_name,$file_version,$file_ext) = |
| |
&file_name_version_ext($file); |
| |
if (($file_name eq $answer_name) && |
| |
($file_ext eq $answer_ext)) { |
| |
# gets here if filename and extension match, |
| |
# regardless of version |
| |
if ($file_version ne '') { |
| |
# a versioned file is found so save it for later |
| |
if ($file_version > $version) { |
| |
$version = $file_version; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
$version ++; |
| |
return($version); |
| |
} |
| |
|
| |
sub version_selected_portfile { |
| |
my ($domain,$stu_name,$directory,$file_name,$version) = @_; |
| |
my ($answer_name,$answer_ver,$answer_ext) = |
| |
&file_name_version_ext($file_name); |
| |
my $new_answer; |
| |
$env{'form.copy'} = |
| |
&getfile("/uploaded/$domain/$stu_name/portfolio$directory$file_name"); |
| |
if($env{'form.copy'} eq '-1') { |
| |
$new_answer = 'problem getting file'; |
| |
} else { |
| |
$new_answer = $answer_name.'.'.$version.'.'.$answer_ext; |
| |
my $copy_result = |
| |
&finishuserfileupload($stu_name,$domain,'copy', |
| |
'/portfolio'.$directory.$new_answer); |
| |
} |
| |
undef($env{'form.copy'}); |
| |
return ($new_answer); |
| |
} |
| |
|
| |
sub file_name_version_ext { |
| |
my ($file)=@_; |
| |
my @file_parts = split(/\./, $file); |
| |
my ($name,$version,$ext); |
| |
if (@file_parts > 1) { |
| |
$ext=pop(@file_parts); |
| |
if (@file_parts > 1 && $file_parts[-1] =~ /^\d+$/) { |
| |
$version=pop(@file_parts); |
| |
} |
| |
$name=join('.',@file_parts); |
| |
} else { |
| |
$name=join('.',@file_parts); |
| |
} |
| |
return($name,$version,$ext); |
| |
} |
| |
|
| #----------------------------------------------Get portfolio file permissions |
#----------------------------------------------Get portfolio file permissions |
| |
|
| sub get_portfile_permissions { |
sub get_portfile_permissions { |
|
Line 5318 sub modify_access_controls {
|
Line 11300 sub modify_access_controls {
|
| my $tries = 0; |
my $tries = 0; |
| my $gotlock = &newput('file_permissions',$lockhash,$domain,$user); |
my $gotlock = &newput('file_permissions',$lockhash,$domain,$user); |
| |
|
| while (($gotlock ne 'ok') && $tries <3) { |
while (($gotlock ne 'ok') && $tries < 10) { |
| $tries ++; |
$tries ++; |
| sleep 1; |
sleep(0.1); |
| $gotlock = &newput('file_permissions',$lockhash,$domain,$user); |
$gotlock = &newput('file_permissions',$lockhash,$domain,$user); |
| } |
} |
| if ($gotlock eq 'ok') { |
if ($gotlock eq 'ok') { |
|
Line 5346 sub modify_access_controls {
|
Line 11328 sub modify_access_controls {
|
| } |
} |
| } |
} |
| } |
} |
| |
my ($group); |
| |
if (&is_course($domain,$user)) { |
| |
($group,my $file) = split(/\//,$file_name,2); |
| |
} |
| $deloutcome = &del('file_permissions',\@deletions,$domain,$user); |
$deloutcome = &del('file_permissions',\@deletions,$domain,$user); |
| $new_values{$file_name."\0".'accesscontrol'} = \%new_control; |
$new_values{$file_name."\0".'accesscontrol'} = \%new_control; |
| $outcome = &put('file_permissions',\%new_values,$domain,$user); |
$outcome = &put('file_permissions',\%new_values,$domain,$user); |
| # remove lock |
# remove lock |
| my @del_lock = ($file_name."\0".'locked_access_records'); |
my @del_lock = ($file_name."\0".'locked_access_records'); |
| my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user); |
my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user); |
| my ($file,$group); |
|
| if (&is_course($domain,$user)) { |
|
| ($group,$file) = split(/\//,$file_name,2); |
|
| } else { |
|
| $file = $file_name; |
|
| } |
|
| my $sqlresult = |
my $sqlresult = |
| &update_portfolio_table($user,$domain,$file,'portfolio_access', |
&update_portfolio_table($user,$domain,$file_name,'portfolio_access', |
| $group); |
$group); |
| } else { |
} else { |
| $outcome = "error: could not obtain lockfile\n"; |
$outcome = "error: could not obtain lockfile\n"; |
|
Line 5368 sub modify_access_controls {
|
Line 11348 sub modify_access_controls {
|
| } |
} |
| |
|
| sub make_public_indefinitely { |
sub make_public_indefinitely { |
| my ($requrl) = @_; |
my (@requrl) = @_; |
| |
return &automated_portfile_access('public',\@requrl); |
| |
} |
| |
|
| |
sub automated_portfile_access { |
| |
my ($accesstype,$addsref,$delsref,$info) = @_; |
| |
unless (($accesstype eq 'public') || ($accesstype eq 'ip')) { |
| |
return 'invalid'; |
| |
} |
| |
my %urls; |
| |
if (ref($addsref) eq 'ARRAY') { |
| |
foreach my $requrl (@{$addsref}) { |
| |
if (&is_portfolio_url($requrl)) { |
| |
unless (exists($urls{$requrl})) { |
| |
$urls{$requrl} = 'add'; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if (ref($delsref) eq 'ARRAY') { |
| |
foreach my $requrl (@{$delsref}) { |
| |
if (&is_portfolio_url($requrl)) { |
| |
unless (exists($urls{$requrl})) { |
| |
$urls{$requrl} = 'delete'; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
unless (keys(%urls)) { |
| |
return 'invalid'; |
| |
} |
| |
my $ip; |
| |
if ($accesstype eq 'ip') { |
| |
if (ref($info) eq 'HASH') { |
| |
if ($info->{'ip'} ne '') { |
| |
$ip = $info->{'ip'}; |
| |
} |
| |
} |
| |
if ($ip eq '') { |
| |
return 'invalid'; |
| |
} |
| |
} |
| |
my $errors; |
| my $now = time; |
my $now = time; |
| my $action = 'activate'; |
my %current_perms; |
| my $aclnum = 0; |
foreach my $requrl (sort(keys(%urls))) { |
| if (&is_portfolio_url($requrl)) { |
my $action; |
| |
if ($urls{$requrl} eq 'add') { |
| |
$action = 'activate'; |
| |
} else { |
| |
$action = 'none'; |
| |
} |
| |
my $aclnum = 0; |
| my (undef,$udom,$unum,$file_name,$group) = |
my (undef,$udom,$unum,$file_name,$group) = |
| &parse_portfolio_url($requrl); |
&parse_portfolio_url($requrl); |
| my $current_perms = &get_portfile_permissions($udom,$unum); |
unless (exists($current_perms{$unum.':'.$udom})) { |
| my %access_controls = &get_access_controls($current_perms, |
$current_perms{$unum.':'.$udom} = &get_portfile_permissions($udom,$unum); |
| |
} |
| |
my %access_controls = &get_access_controls($current_perms{$unum.':'.$udom}, |
| $group,$file_name); |
$group,$file_name); |
| foreach my $key (keys(%{$access_controls{$file_name}})) { |
foreach my $key (keys(%{$access_controls{$file_name}})) { |
| my ($num,$scope,$end,$start) = |
my ($num,$scope,$end,$start) = |
| ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/); |
($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/); |
| if ($scope eq 'public') { |
if ($scope eq $accesstype) { |
| if ($start <= $now && $end == 0) { |
if (($start <= $now) && ($end == 0)) { |
| $action = 'none'; |
if ($accesstype eq 'ip') { |
| } else { |
if (ref($access_controls{$file_name}{$key}) eq 'HASH') { |
| |
if (ref($access_controls{$file_name}{$key}{'ip'}) eq 'ARRAY') { |
| |
if (grep(/^\Q$ip\E$/,@{$access_controls{$file_name}{$key}{'ip'}})) { |
| |
if ($urls{$requrl} eq 'add') { |
| |
$action = 'none'; |
| |
last; |
| |
} else { |
| |
$action = 'delete'; |
| |
$aclnum = $num; |
| |
last; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} elsif ($accesstype eq 'public') { |
| |
if ($urls{$requrl} eq 'add') { |
| |
$action = 'none'; |
| |
last; |
| |
} else { |
| |
$action = 'delete'; |
| |
$aclnum = $num; |
| |
last; |
| |
} |
| |
} |
| |
} elsif ($accesstype eq 'public') { |
| $action = 'update'; |
$action = 'update'; |
| $aclnum = $num; |
$aclnum = $num; |
| |
last; |
| } |
} |
| last; |
|
| } |
} |
| } |
} |
| if ($action eq 'none') { |
if ($action eq 'none') { |
| return 'ok'; |
next; |
| } else { |
} else { |
| my %changes; |
my %changes; |
| my $newend = 0; |
my $newend = 0; |
| my $newstart = $now; |
my $newstart = $now; |
| my $newkey = $aclnum.':public_'.$newend.'_'.$newstart; |
my $newkey = $aclnum.':'.$accesstype.'_'.$newend.'_'.$newstart; |
| $changes{$action}{$newkey} = { |
$changes{$action}{$newkey} = { |
| type => 'public', |
type => $accesstype, |
| time => { |
time => { |
| start => $newstart, |
start => $newstart, |
| end => $newend, |
end => $newend, |
| }, |
}, |
| }; |
}; |
| |
if ($accesstype eq 'ip') { |
| |
$changes{$action}{$newkey}{'ip'} = [$ip]; |
| |
} |
| my ($outcome,$deloutcome,$new_values,$translation) = |
my ($outcome,$deloutcome,$new_values,$translation) = |
| &modify_access_controls($file_name,\%changes,$udom,$unum); |
&modify_access_controls($file_name,\%changes,$udom,$unum); |
| return $outcome; |
unless ($outcome eq 'ok') { |
| |
$errors .= $outcome.' '; |
| |
} |
| } |
} |
| |
} |
| |
if ($errors) { |
| |
$errors =~ s/\s$//; |
| |
return $errors; |
| } else { |
} else { |
| return 'invalid'; |
return 'ok'; |
| } |
} |
| } |
} |
| |
|
|
Line 5522 sub unmark_as_readonly {
|
Line 11585 sub unmark_as_readonly {
|
| # ------------------------------------------------------------ Directory lister |
# ------------------------------------------------------------ Directory lister |
| |
|
| sub dirlist { |
sub dirlist { |
| my ($uri,$userdomain,$username,$alternateDirectoryRoot)=@_; |
my ($uri,$userdomain,$username,$getpropath,$getuserdir,$alternateRoot)=@_; |
| |
|
| $uri=~s/^\///; |
$uri=~s/^\///; |
| $uri=~s/\/$//; |
$uri=~s/\/$//; |
| my ($udom, $uname); |
my ($udom, $uname); |
| (undef,$udom,$uname)=split(/\//,$uri); |
if ($getuserdir) { |
| if(defined($userdomain)) { |
|
| $udom = $userdomain; |
$udom = $userdomain; |
| } |
|
| if(defined($username)) { |
|
| $uname = $username; |
$uname = $username; |
| |
} else { |
| |
(undef,$udom,$uname)=split(/\//,$uri); |
| |
if(defined($userdomain)) { |
| |
$udom = $userdomain; |
| |
} |
| |
if(defined($username)) { |
| |
$uname = $username; |
| |
} |
| } |
} |
| |
my ($dirRoot,$listing,@listing_results); |
| |
|
| my $dirRoot = $perlvar{'lonDocRoot'}; |
$dirRoot = $perlvar{'lonDocRoot'}; |
| if(defined($alternateDirectoryRoot)) { |
if (defined($getpropath)) { |
| $dirRoot = $alternateDirectoryRoot; |
$dirRoot = &propath($udom,$uname); |
| $dirRoot =~ s/\/$//; |
$dirRoot =~ s/\/$//; |
| |
} elsif (defined($getuserdir)) { |
| |
my $subdir=$uname.'__'; |
| |
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; |
| |
$dirRoot = $Apache::lonnet::perlvar{'lonUsersDir'} |
| |
."/$udom/$subdir/$uname"; |
| |
} elsif (defined($alternateRoot)) { |
| |
$dirRoot = $alternateRoot; |
| } |
} |
| |
|
| if($udom) { |
if($udom) { |
| if($uname) { |
if($uname) { |
| my $listing = &reply('ls2:'.$dirRoot.'/'.$uri, |
my $uhome = &homeserver($uname,$udom); |
| &homeserver($uname,$udom)); |
if ($uhome eq 'no_host') { |
| my @listing_results; |
return ([],'no_host'); |
| |
} |
| |
$listing = &reply('ls3:'.&escape('/'.$uri).':'.$getpropath.':' |
| |
.$getuserdir.':'.&escape($dirRoot) |
| |
.':'.&escape($uname).':'.&escape($udom),$uhome); |
| |
if ($listing eq 'unknown_cmd') { |
| |
$listing = &reply('ls2:'.$dirRoot.'/'.$uri,$uhome); |
| |
} else { |
| |
@listing_results = map { &unescape($_); } split(/:/,$listing); |
| |
} |
| if ($listing eq 'unknown_cmd') { |
if ($listing eq 'unknown_cmd') { |
| $listing = &reply('ls:'.$dirRoot.'/'.$uri, |
$listing = &reply('ls:'.$dirRoot.'/'.$uri,$uhome); |
| &homeserver($uname,$udom)); |
|
| @listing_results = split(/:/,$listing); |
@listing_results = split(/:/,$listing); |
| } else { |
} else { |
| @listing_results = map { &unescape($_); } split(/:/,$listing); |
@listing_results = map { &unescape($_); } split(/:/,$listing); |
| } |
} |
| return @listing_results; |
if (($listing eq 'no_such_host') || ($listing eq 'con_lost') || |
| } elsif(!defined($alternateDirectoryRoot)) { |
($listing eq 'rejected') || ($listing eq 'refused') || |
| my %allusers; |
($listing eq 'no_such_dir') || ($listing eq 'empty')) { |
| foreach my $tryserver (keys(%libserv)) { |
return ([],$listing); |
| if($hostdom{$tryserver} eq $udom) { |
} else { |
| my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'. |
return (\@listing_results); |
| $udom, $tryserver); |
} |
| my @listing_results; |
} elsif(!$alternateRoot) { |
| if ($listing eq 'unknown_cmd') { |
my (%allusers,%listerror); |
| $listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. |
my %servers = &get_servers($udom,'library'); |
| $udom, $tryserver); |
foreach my $tryserver (keys(%servers)) { |
| @listing_results = split(/:/,$listing); |
$listing = &reply('ls3:'.&escape("/res/$udom").':::::'. |
| } else { |
&escape($udom),$tryserver); |
| @listing_results = |
if ($listing eq 'unknown_cmd') { |
| map { &unescape($_); } split(/:/,$listing); |
$listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'. |
| } |
$udom, $tryserver); |
| if ($listing_results[0] ne 'no_such_dir' && |
} else { |
| $listing_results[0] ne 'empty' && |
@listing_results = map { &unescape($_); } split(/:/,$listing); |
| $listing_results[0] ne 'con_lost') { |
|
| foreach my $line (@listing_results) { |
|
| my ($entry) = split(/&/,$line,2); |
|
| $allusers{$entry} = 1; |
|
| } |
|
| } |
|
| } |
} |
| |
if ($listing eq 'unknown_cmd') { |
| |
$listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. |
| |
$udom, $tryserver); |
| |
@listing_results = split(/:/,$listing); |
| |
} else { |
| |
@listing_results = |
| |
map { &unescape($_); } split(/:/,$listing); |
| |
} |
| |
if (($listing eq 'no_such_host') || ($listing eq 'con_lost') || |
| |
($listing eq 'rejected') || ($listing eq 'refused') || |
| |
($listing eq 'no_such_dir') || ($listing eq 'empty')) { |
| |
$listerror{$tryserver} = $listing; |
| |
} else { |
| |
foreach my $line (@listing_results) { |
| |
my ($entry) = split(/&/,$line,2); |
| |
$allusers{$entry} = 1; |
| |
} |
| |
} |
| } |
} |
| my $alluserstr=''; |
my @alluserslist=(); |
| foreach my $user (sort(keys(%allusers))) { |
foreach my $user (sort(keys(%allusers))) { |
| $alluserstr.=$user.'&user:'; |
push(@alluserslist,$user.'&user'); |
| |
} |
| |
|
| |
if (!%listerror) { |
| |
# no errors |
| |
return (\@alluserslist); |
| |
} elsif (scalar(keys(%servers)) == 1) { |
| |
# one library server, one error |
| |
my ($key) = keys(%listerror); |
| |
return (\@alluserslist, $listerror{$key}); |
| |
} elsif ( grep { $_ eq 'con_lost' } values(%listerror) ) { |
| |
# con_lost indicates that we might miss data from at least one |
| |
# library server |
| |
return (\@alluserslist, 'con_lost'); |
| |
} else { |
| |
# multiple library servers and no con_lost -> data should be |
| |
# complete. |
| |
return (\@alluserslist); |
| } |
} |
| $alluserstr=~s/:$//; |
|
| return split(/:/,$alluserstr); |
|
| } else { |
} else { |
| return ('missing user name'); |
return ([],'missing username'); |
| } |
|
| } elsif(!defined($alternateDirectoryRoot)) { |
|
| my $tryserver; |
|
| my %alldom=(); |
|
| foreach $tryserver (keys(%libserv)) { |
|
| $alldom{$hostdom{$tryserver}}=1; |
|
| } |
} |
| my $alldomstr=''; |
} elsif(!defined($getpropath)) { |
| foreach my $domain (sort(keys(%alldom))) { |
my $path = $perlvar{'lonDocRoot'}.'/res/'; |
| $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain:'; |
my @all_domains = map { $path.$_.'/&domain'; } (sort(&all_domains())); |
| } |
return (\@all_domains); |
| $alldomstr=~s/:$//; |
|
| return split(/:/,$alldomstr); |
|
| } else { |
} else { |
| return ('missing domain'); |
return ([],'missing domain'); |
| } |
} |
| } |
} |
| |
|
|
Line 5610 sub dirlist {
|
Line 11713 sub dirlist {
|
| # when it was last modified. It will also return an error of -1 |
# when it was last modified. It will also return an error of -1 |
| # if an error occurs |
# if an error occurs |
| |
|
| ## |
|
| ## FIXME: This subroutine assumes its caller knows something about the |
|
| ## directory structure of the home server for the student ($root). |
|
| ## Not a good assumption to make. Since this is for looking up files |
|
| ## in user directories, the full path should be constructed by lond, not |
|
| ## whatever machine we request data from. |
|
| ## |
|
| sub GetFileTimestamp { |
sub GetFileTimestamp { |
| my ($studentDomain,$studentName,$filename,$root)=@_; |
my ($studentDomain,$studentName,$filename,$getuserdir)=@_; |
| $studentDomain = &LONCAPA::clean_domain($studentDomain); |
$studentDomain = &LONCAPA::clean_domain($studentDomain); |
| $studentName = &LONCAPA::clean_username($studentName); |
$studentName = &LONCAPA::clean_username($studentName); |
| my $subdir=$studentName.'__'; |
my ($fileref,$error) = &dirlist($filename,$studentDomain,$studentName, |
| $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; |
undef,$getuserdir); |
| my $proname="$studentDomain/$subdir/$studentName"; |
if (($error eq 'empty') || ($error eq 'no_such_dir')) { |
| $proname .= '/'.$filename; |
return -1; |
| my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain, |
} |
| $studentName, $root); |
if (ref($fileref) eq 'ARRAY') { |
| my @stats = split('&', $fileStat); |
my @stats = split('&',$fileref->[0]); |
| if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { |
|
| # @stats contains first the filename, then the stat output |
# @stats contains first the filename, then the stat output |
| return $stats[10]; # so this is 10 instead of 9. |
return $stats[10]; # so this is 10 instead of 9. |
| } else { |
} else { |
|
Line 5640 sub stat_file {
|
Line 11735 sub stat_file {
|
| my ($uri) = @_; |
my ($uri) = @_; |
| $uri = &clutter_with_no_wrapper($uri); |
$uri = &clutter_with_no_wrapper($uri); |
| |
|
| my ($udom,$uname,$file,$dir); |
my ($udom,$uname,$file); |
| if ($uri =~ m-^/(uploaded|editupload)/-) { |
if ($uri =~ m-^/(uploaded|editupload)/-) { |
| ($udom,$uname,$file) = |
($udom,$uname,$file) = |
| ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-); |
($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-); |
| $file = 'userfiles/'.$file; |
$file = 'userfiles/'.$file; |
| $dir = &propath($udom,$uname); |
|
| } |
} |
| if ($uri =~ m-^/res/-) { |
if ($uri =~ m-^/res/-) { |
| ($udom,$uname) = |
($udom,$uname) = |
|
Line 5657 sub stat_file {
|
Line 11751 sub stat_file {
|
| # unable to handle the uri |
# unable to handle the uri |
| return (); |
return (); |
| } |
} |
| |
my $getpropath; |
| my ($result) = &dirlist($file,$udom,$uname,$dir); |
if ($file =~ /^userfiles\//) { |
| my @stats = split('&', $result); |
$getpropath = 1; |
| |
} |
| if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { |
my ($listref,$error) = &dirlist($file,$udom,$uname,$getpropath); |
| shift(@stats); #filename is first |
if (($error eq 'empty') || ($error eq 'no_such_dir')) { |
| return @stats; |
return (); |
| |
} else { |
| |
if (ref($listref) eq 'ARRAY') { |
| |
my @stats = split('&',$listref->[0]); |
| |
shift(@stats); #filename is first |
| |
return @stats; |
| |
} |
| } |
} |
| return (); |
return (); |
| } |
} |
| |
|
| |
# --------------------------------------------------------- recursedirs |
| |
# Recursive function to traverse either a specific user's Authoring Space |
| |
# or corresponding Published Resource Space, and populate the hash ref: |
| |
# $dirhashref with URLs of all directories, and if $filehashref hash |
| |
# ref arg is provided, the URLs of any files, excluding versioned, .meta, |
| |
# or .rights files in resource space, and .meta, .save, .log, and .bak |
| |
# files in Authoring Space. |
| |
# |
| |
# Inputs: |
| |
# |
| |
# $is_home - true if current server is home server for user's space |
| |
# $context - either: priv, or res respectively for Authoring or Resource Space. |
| |
# $docroot - Document root (i.e., /home/httpd/html |
| |
# $toppath - Top level directory (i.e., /res/$dom/$uname or /priv/$dom/$uname |
| |
# $relpath - Current path (relative to top level). |
| |
# $dirhashref - reference to hash to populate with URLs of directories (Required) |
| |
# $filehashref - reference to hash to populate with URLs of files (Optional) |
| |
# |
| |
# Returns: nothing |
| |
# |
| |
# Side Effects: populates $dirhashref, and $filehashref (if provided). |
| |
# |
| |
# Currently used by interface/londocs.pm to create linked select boxes for |
| |
# directory and filename to import a Course "Author" resource into a course, and |
| |
# also to create linked select boxes for Authoring Space and Directory to choose |
| |
# save location for creation of a new "standard" problem from the Course Editor. |
| |
# |
| |
|
| |
sub recursedirs { |
| |
my ($is_home,$context,$docroot,$toppath,$relpath,$dirhashref,$filehashref) = @_; |
| |
return unless (ref($dirhashref) eq 'HASH'); |
| |
my $currpath = $docroot.$toppath; |
| |
if ($relpath) { |
| |
$currpath .= "/$relpath"; |
| |
} |
| |
my $savefile; |
| |
if (ref($filehashref)) { |
| |
$savefile = 1; |
| |
} |
| |
if ($is_home) { |
| |
if (opendir(my $dirh,$currpath)) { |
| |
foreach my $item (sort { lc($a) cmp lc($b) } grep(!/^\.+$/,readdir($dirh))) { |
| |
next if ($item eq ''); |
| |
if (-d "$currpath/$item") { |
| |
my $newpath; |
| |
if ($relpath) { |
| |
$newpath = "$relpath/$item"; |
| |
} else { |
| |
$newpath = $item; |
| |
} |
| |
$dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1; |
| |
&recursedirs($is_home,$context,$docroot,$toppath,$newpath,$dirhashref,$filehashref); |
| |
} elsif ($savefile) { |
| |
if ($context eq 'priv') { |
| |
unless ($item =~ /\.(meta|save|log|bak|DS_Store)$/) { |
| |
$filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1; |
| |
} |
| |
} else { |
| |
unless (($item =~ /\.meta$/) || ($item =~ /\.\d+\.\w+$/) || ($item =~ /\.rights$/)) { |
| |
$filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
closedir($dirh); |
| |
} |
| |
} else { |
| |
my ($dirlistref,$listerror) = |
| |
&dirlist($toppath.$relpath); |
| |
my @dir_lines; |
| |
my $dirptr=16384; |
| |
if (ref($dirlistref) eq 'ARRAY') { |
| |
foreach my $dir_line (sort |
| |
{ |
| |
my ($afile)=split('&',$a,2); |
| |
my ($bfile)=split('&',$b,2); |
| |
return (lc($afile) cmp lc($bfile)); |
| |
} (@{$dirlistref})) { |
| |
my ($item,$dom,undef,$testdir,undef,undef,undef,undef,$size,undef,$mtime,undef,undef,undef,$obs,undef) = |
| |
split(/\&/,$dir_line,16); |
| |
$item =~ s/\s+$//; |
| |
next if (($item =~ /^\.\.?$/) || ($obs)); |
| |
if ($dirptr&$testdir) { |
| |
my $newpath; |
| |
if ($relpath) { |
| |
$newpath = "$relpath/$item"; |
| |
} else { |
| |
$relpath = '/'; |
| |
$newpath = $item; |
| |
} |
| |
$dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1; |
| |
&recursedirs($is_home,$context,$docroot,$toppath,$newpath,$dirhashref,$filehashref); |
| |
} elsif ($savefile) { |
| |
if ($context eq 'priv') { |
| |
unless ($item =~ /\.(meta|save|log|bak|DS_Store)$/) { |
| |
$filehashref->{$relpath}{$item} = 1; |
| |
} |
| |
} else { |
| |
unless (($item =~ /\.meta$/) || ($item =~ /\.\d+\.\w+$/)) { |
| |
$filehashref->{$relpath}{$item} = 1; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| # -------------------------------------------------------- Value of a Condition |
# -------------------------------------------------------- Value of a Condition |
| |
|
| # gets the value of a specific preevaluated condition |
# gets the value of a specific preevaluated condition |
|
Line 5691 sub directcondval {
|
Line 11900 sub directcondval {
|
| untie(%bighash); |
untie(%bighash); |
| } |
} |
| my $value = &docondval($sub_condition); |
my $value = &docondval($sub_condition); |
| &appenv('user.state.'.$env{'request.course.id'}.".$number" => $value); |
&appenv({'user.state.'.$env{'request.course.id'}.".$number" => $value}); |
| return $value; |
return $value; |
| } |
} |
| if ($env{'user.state.'.$env{'request.course.id'}}) { |
if ($env{'user.state.'.$env{'request.course.id'}}) { |
|
Line 5758 sub devalidatecourseresdata {
|
Line 11967 sub devalidatecourseresdata {
|
| |
|
| |
|
| # --------------------------------------------------- Course Resourcedata Query |
# --------------------------------------------------- Course Resourcedata Query |
| |
# |
| |
# Parameters: |
| |
# $coursenum - Number of the course. |
| |
# $coursedomain - Domain at which the course was created. |
| |
# Returns: |
| |
# A hash of the course parameters along (I think) with timestamps |
| |
# and version info. |
| |
|
| sub get_courseresdata { |
sub get_courseresdata { |
| my ($coursenum,$coursedomain)=@_; |
my ($coursenum,$coursedomain)=@_; |
|
Line 5805 sub get_userresdata {
|
Line 12021 sub get_userresdata {
|
| } |
} |
| #error 2 occurs when the .db doesn't exist |
#error 2 occurs when the .db doesn't exist |
| if ($tmp!~/error: 2 /) { |
if ($tmp!~/error: 2 /) { |
| &logthis("<font color=\"blue\">WARNING:". |
if ((!defined($cached)) || ($tmp ne 'con_lost')) { |
| " Trying to get resource data for ". |
&logthis("<font color=\"blue\">WARNING:". |
| $uname." at ".$udom.": ". |
" Trying to get resource data for ". |
| $tmp."</font>"); |
$uname." at ".$udom.": ". |
| |
$tmp."</font>"); |
| |
} |
| } elsif ($tmp=~/error: 2 /) { |
} elsif ($tmp=~/error: 2 /) { |
| #&EXT_cache_set($udom,$uname); |
#&EXT_cache_set($udom,$uname); |
| &do_cache_new('userres',$hashid,undef,600); |
&do_cache_new('userres',$hashid,undef,600); |
|
Line 5816 sub get_userresdata {
|
Line 12034 sub get_userresdata {
|
| } |
} |
| return $tmp; |
return $tmp; |
| } |
} |
| |
#----------------------------------------------- resdata - return resource data |
| |
# Purpose: |
| |
# Return resource data for either users or for a course. |
| |
# Parameters: |
| |
# $name - Course/user name. |
| |
# $domain - Name of the domain the user/course is registered on. |
| |
# $type - Type of thing $name is (must be 'course' or 'user') |
| |
# $mapp - decluttered URL of enclosing map |
| |
# $recursed - Ref to scalar -- set to 1, if nested maps have been recursed. |
| |
# $recurseup - Ref to array of map URLs, starting with map containing |
| |
# $mapp up through hierarchy of nested maps to top level map. |
| |
# $courseid - CourseID (first part of param identifier). |
| |
# $modifier - Middle part of param identifier. |
| |
# $what - Last part of param identifier. |
| |
# @which - Array of names of resources desired. |
| |
# Returns: |
| |
# The value of the first reasource in @which that is found in the |
| |
# resource hash. |
| |
# Exceptional Conditions: |
| |
# If the $type passed in is not valid (not the string 'course' or |
| |
# 'user', an undefined reference is returned. |
| |
# If none of the resources are found, an undef is returned |
| sub resdata { |
sub resdata { |
| my ($name,$domain,$type,@which)=@_; |
my ($name,$domain,$type,$mapp,$recursed,$recurseup,$courseid, |
| |
$modifier,$what,@which)=@_; |
| my $result; |
my $result; |
| if ($type eq 'course') { |
if ($type eq 'course') { |
| $result=&get_courseresdata($name,$domain); |
$result=&get_courseresdata($name,$domain); |
|
Line 5827 sub resdata {
|
Line 12067 sub resdata {
|
| } |
} |
| if (!ref($result)) { return $result; } |
if (!ref($result)) { return $result; } |
| foreach my $item (@which) { |
foreach my $item (@which) { |
| if (defined($result->{$item})) { |
if ($item->[1] eq 'course') { |
| return $result->{$item}; |
if ((ref($recurseup) eq 'ARRAY') && (ref($recursed) eq 'SCALAR')) { |
| |
unless ($$recursed) { |
| |
@{$recurseup} = &get_map_hierarchy($mapp,$courseid); |
| |
$$recursed = 1; |
| |
} |
| |
foreach my $item (@${recurseup}) { |
| |
my $norecursechk=$courseid.$modifier.$item.'___(all).'.$what; |
| |
last if (defined($result->{$norecursechk})); |
| |
my $recursechk=$courseid.$modifier.$item.'___(rec).'.$what; |
| |
if (defined($result->{$recursechk})) { return [$result->{$recursechk},'map']; } |
| |
} |
| |
} |
| |
} |
| |
if (defined($result->{$item->[0]})) { |
| |
return [$result->{$item->[0]},$item->[1]]; |
| } |
} |
| } |
} |
| return undef; |
return undef; |
| } |
} |
| |
|
| |
sub get_domain_lti { |
| |
my ($cdom,$context) = @_; |
| |
my ($name,%lti); |
| |
if ($context eq 'consumer') { |
| |
$name = 'ltitools'; |
| |
} elsif ($context eq 'provider') { |
| |
$name = 'lti'; |
| |
} else { |
| |
return %lti; |
| |
} |
| |
my ($result,$cached)=&is_cached_new($name,$cdom); |
| |
if (defined($cached)) { |
| |
if (ref($result) eq 'HASH') { |
| |
%lti = %{$result}; |
| |
} |
| |
} else { |
| |
my %domconfig = &get_dom('configuration',[$name],$cdom); |
| |
if (ref($domconfig{$name}) eq 'HASH') { |
| |
%lti = %{$domconfig{$name}}; |
| |
my %encdomconfig = &get_dom('encconfig',[$name],$cdom); |
| |
if (ref($encdomconfig{$name}) eq 'HASH') { |
| |
foreach my $id (keys(%lti)) { |
| |
if (ref($encdomconfig{$name}{$id}) eq 'HASH') { |
| |
foreach my $item ('key','secret') { |
| |
$lti{$id}{$item} = $encdomconfig{$name}{$id}{$item}; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
my $cachetime = 24*60*60; |
| |
&do_cache_new($name,$cdom,\%lti,$cachetime); |
| |
} |
| |
return %lti; |
| |
} |
| |
|
| |
sub get_numsuppfiles { |
| |
my ($cnum,$cdom,$ignorecache)=@_; |
| |
my $hashid=$cnum.':'.$cdom; |
| |
my ($suppcount,$cached); |
| |
unless ($ignorecache) { |
| |
($suppcount,$cached) = &is_cached_new('suppcount',$hashid); |
| |
} |
| |
unless (defined($cached)) { |
| |
my $chome=&homeserver($cnum,$cdom); |
| |
unless ($chome eq 'no_host') { |
| |
($suppcount,my $supptools,my $errors) = (0,0,0); |
| |
my $suppmap = 'supplemental.sequence'; |
| |
($suppcount,$supptools,$errors) = |
| |
&Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount, |
| |
$supptools,$errors); |
| |
} |
| |
&do_cache_new('suppcount',$hashid,$suppcount,600); |
| |
} |
| |
return $suppcount; |
| |
} |
| |
|
| # |
# |
| # EXT resource caching routines |
# EXT resource caching routines |
| # |
# |
| |
|
| |
{ |
| |
# Cache (5 seconds) of map hierarchy for speedup of navmaps display |
| |
# |
| |
# The course for which we cache |
| |
my $cachedmapkey=''; |
| |
# The cached recursive maps for this course |
| |
my %cachedmaps=(); |
| |
# When this was last done |
| |
my $cachedmaptime=''; |
| |
|
| sub clear_EXT_cache_status { |
sub clear_EXT_cache_status { |
| &delenv('cache.EXT.'); |
&delenv('cache.EXT.'); |
| } |
} |
|
Line 5856 sub EXT_cache_status {
|
Line 12177 sub EXT_cache_status {
|
| sub EXT_cache_set { |
sub EXT_cache_set { |
| my ($target_domain,$target_user) = @_; |
my ($target_domain,$target_user) = @_; |
| my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; |
my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; |
| #&appenv($cachename => time); |
#&appenv({$cachename => time}); |
| } |
} |
| |
|
| # --------------------------------------------------------- Value of a Variable |
# --------------------------------------------------------- Value of a Variable |
| sub EXT { |
sub EXT { |
| |
|
| my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_; |
my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid)=@_; |
| unless ($varname) { return ''; } |
unless ($varname) { return ''; } |
| #get real user name/domain, courseid and symb |
#get real user name/domain, courseid and symb |
| my $courseid; |
my $courseid; |
|
Line 5963 sub EXT {
|
Line 12284 sub EXT {
|
| } elsif ($realm eq 'request') { |
} elsif ($realm eq 'request') { |
| # ------------------------------------------------------------- request.browser |
# ------------------------------------------------------------- request.browser |
| if ($space eq 'browser') { |
if ($space eq 'browser') { |
| if ($qualifier eq 'textremote') { |
return $env{'browser.'.$qualifier}; |
| if (&Apache::lonlocal::mt('textual_remote_display') eq 'on') { |
|
| return 1; |
|
| } else { |
|
| return 0; |
|
| } |
|
| } else { |
|
| return $env{'browser.'.$qualifier}; |
|
| } |
|
| # ------------------------------------------------------------ request.filename |
# ------------------------------------------------------------ request.filename |
| } else { |
} else { |
| return $env{'request.'.$spacequalifierrest}; |
return $env{'request.'.$spacequalifierrest}; |
|
Line 5985 sub EXT {
|
Line 12298 sub EXT {
|
| if (!$symbparm) { $symbparm=&symbread(); } |
if (!$symbparm) { $symbparm=&symbread(); } |
| } |
} |
| |
|
| if ($space eq 'title') { |
if ($qualifier eq '') { |
| if (!$symbparm) { $symbparm = $env{'request.filename'}; } |
if ($space eq 'title') { |
| return &gettitle($symbparm); |
if (!$symbparm) { $symbparm = $env{'request.filename'}; } |
| } |
return &gettitle($symbparm); |
| |
} |
| |
|
| if ($space eq 'map') { |
if ($space eq 'map') { |
| my ($map) = &decode_symb($symbparm); |
my ($map) = &decode_symb($symbparm); |
| return &symbread($map); |
return &symbread($map); |
| } |
} |
| |
if ($space eq 'maptitle') { |
| |
my ($map) = &decode_symb($symbparm); |
| |
return &gettitle($map); |
| |
} |
| |
if ($space eq 'filename') { |
| |
if ($symbparm) { |
| |
return &clutter((&decode_symb($symbparm))[2]); |
| |
} |
| |
return &hreflocation('',$env{'request.filename'}); |
| |
} |
| |
|
| my ($section, $group, @groups); |
if ((defined($courseid)) && ($courseid eq $env{'request.course.id'}) && $symbparm) { |
| my ($courselevelm,$courselevel); |
if ($space eq 'visibleparts') { |
| if ($symbparm && defined($courseid) && |
my $navmap = Apache::lonnavmaps::navmap->new(); |
| $courseid eq $env{'request.course.id'}) { |
my $item; |
| |
if (ref($navmap)) { |
| |
my $res = $navmap->getBySymb($symbparm); |
| |
my $parts = $res->parts(); |
| |
if (ref($parts) eq 'ARRAY') { |
| |
$item = join(',',@{$parts}); |
| |
} |
| |
undef($navmap); |
| |
} |
| |
return $item; |
| |
} |
| |
} |
| |
} |
| |
|
| |
my ($section, $group, @groups, @recurseup, $recursed); |
| |
my ($courselevelm,$courseleveli,$courselevel,$mapp); |
| |
if (($courseid eq '') && ($cid)) { |
| |
$courseid = $cid; |
| |
} |
| |
if (($symbparm && $courseid) && |
| |
(($courseid eq $env{'request.course.id'}) || ($courseid eq $cid))) { |
| |
|
| #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest; |
#print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest; |
| |
|
| # ----------------------------------------------------- Cascading lookup scheme |
# ----------------------------------------------------- Cascading lookup scheme |
| my $symbp=$symbparm; |
my $symbp=$symbparm; |
| my $mapp=&deversion((&decode_symb($symbp))[0]); |
$mapp=&deversion((&decode_symb($symbp))[0]); |
| |
|
| my $symbparm=$symbp.'.'.$spacequalifierrest; |
my $symbparm=$symbp.'.'.$spacequalifierrest; |
| |
my $recurseparm=$mapp.'___(rec).'.$spacequalifierrest; |
| my $mapparm=$mapp.'___(all).'.$spacequalifierrest; |
my $mapparm=$mapp.'___(all).'.$spacequalifierrest; |
| |
|
| if (($env{'user.name'} eq $uname) && |
if (($env{'user.name'} eq $uname) && |
| ($env{'user.domain'} eq $udom)) { |
($env{'user.domain'} eq $udom)) { |
| $section=$env{'request.course.sec'}; |
$section=$env{'request.course.sec'}; |
|
Line 6025 sub EXT {
|
Line 12368 sub EXT {
|
| |
|
| my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; |
my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; |
| my $seclevelr=$courseid.'.['.$section.'].'.$symbparm; |
my $seclevelr=$courseid.'.['.$section.'].'.$symbparm; |
| |
my $secleveli=$courseid.'.['.$section.'].'.$recurseparm; |
| my $seclevelm=$courseid.'.['.$section.'].'.$mapparm; |
my $seclevelm=$courseid.'.['.$section.'].'.$mapparm; |
| |
|
| $courselevel=$courseid.'.'.$spacequalifierrest; |
$courselevel=$courseid.'.'.$spacequalifierrest; |
| my $courselevelr=$courseid.'.'.$symbparm; |
my $courselevelr=$courseid.'.'.$symbparm; |
| |
$courseleveli=$courseid.'.'.$recurseparm; |
| $courselevelm=$courseid.'.'.$mapparm; |
$courselevelm=$courseid.'.'.$mapparm; |
| |
|
| # ----------------------------------------------------------- first, check user |
# ----------------------------------------------------------- first, check user |
| |
|
| my $userreply=&resdata($uname,$udom,'user', |
my $userreply=&resdata($uname,$udom,'user',$mapp,\$recursed, |
| ($courselevelr,$courselevelm, |
\@recurseup,$courseid,'.',$spacequalifierrest, |
| $courselevel)); |
([$courselevelr,'resource'], |
| if (defined($userreply)) { return $userreply; } |
[$courselevelm,'map' ], |
| |
[$courseleveli,'map' ], |
| |
[$courselevel, 'course' ])); |
| |
if (defined($userreply)) { return &get_reply($userreply); } |
| |
|
| # ------------------------------------------------ second, check some of course |
# ------------------------------------------------ second, check some of course |
| my $coursereply; |
my $coursereply; |
| if (@groups > 0) { |
if (@groups > 0) { |
| $coursereply = &check_group_parms($courseid,\@groups,$symbparm, |
$coursereply = &check_group_parms($courseid,\@groups,$symbparm, |
| $mapparm,$spacequalifierrest); |
$recurseparm,$mapparm,$spacequalifierrest, |
| if (defined($coursereply)) { return $coursereply; } |
$mapp,\$recursed,\@recurseup); |
| |
if (defined($coursereply)) { return &get_reply($coursereply); } |
| } |
} |
| |
|
| $coursereply=&resdata($env{'course.'.$courseid.'.num'}, |
$coursereply=&resdata($env{'course.'.$courseid.'.num'}, |
| $env{'course.'.$courseid.'.domain'}, |
$env{'course.'.$courseid.'.domain'}, |
| 'course', |
'course',$mapp,\$recursed,\@recurseup, |
| ($seclevelr,$seclevelm,$seclevel, |
$courseid,'.['.$section.'].',$spacequalifierrest, |
| $courselevelr)); |
([$seclevelr, 'resource'], |
| if (defined($coursereply)) { return $coursereply; } |
[$seclevelm, 'map' ], |
| |
[$secleveli, 'map' ], |
| |
[$seclevel, 'course' ], |
| |
[$courselevelr,'resource'])); |
| |
if (defined($coursereply)) { return &get_reply($coursereply); } |
| |
|
| # ------------------------------------------------------ third, check map parms |
# ------------------------------------------------------ third, check map parms |
| my %parmhash=(); |
my %parmhash=(); |
|
Line 6062 sub EXT {
|
Line 12415 sub EXT {
|
| $thisparm=$parmhash{$symbparm}; |
$thisparm=$parmhash{$symbparm}; |
| untie(%parmhash); |
untie(%parmhash); |
| } |
} |
| if ($thisparm) { return $thisparm; } |
if ($thisparm) { return &get_reply([$thisparm,'resource']); } |
| } |
} |
| # ------------------------------------------ fourth, look in resource metadata |
# ------------------------------------------ fourth, look in resource metadata |
| |
|
| $spacequalifierrest=~s/\./\_/; |
my $what = $spacequalifierrest; |
| |
$what=~s/\./\_/; |
| my $filename; |
my $filename; |
| if (!$symbparm) { $symbparm=&symbread(); } |
if (!$symbparm) { $symbparm=&symbread(); } |
| if ($symbparm) { |
if ($symbparm) { |
|
Line 6074 sub EXT {
|
Line 12428 sub EXT {
|
| } else { |
} else { |
| $filename=$env{'request.filename'}; |
$filename=$env{'request.filename'}; |
| } |
} |
| my $metadata=&metadata($filename,$spacequalifierrest); |
my $toolsymb; |
| if (defined($metadata)) { return $metadata; } |
if (($filename =~ /ext\.tool$/) && ($what ne '0_gradable')) { |
| $metadata=&metadata($filename,'parameter_'.$spacequalifierrest); |
$toolsymb = $symbparm; |
| if (defined($metadata)) { return $metadata; } |
} |
| |
my $metadata=&metadata($filename,$what,$toolsymb); |
| |
if (defined($metadata)) { return &get_reply([$metadata,'resource']); } |
| |
$metadata=&metadata($filename,'parameter_'.$what,$toolsymb); |
| |
if (defined($metadata)) { return &get_reply([$metadata,'resource']); } |
| |
|
| # ---------------------------------------------- fourth, look in rest pf course |
# ----------------------------------------------- fifth, look in rest of course |
| if ($symbparm && defined($courseid) && |
if ($symbparm && defined($courseid) && |
| $courseid eq $env{'request.course.id'}) { |
$courseid eq $env{'request.course.id'}) { |
| my $coursereply=&resdata($env{'course.'.$courseid.'.num'}, |
my $coursereply=&resdata($env{'course.'.$courseid.'.num'}, |
| $env{'course.'.$courseid.'.domain'}, |
$env{'course.'.$courseid.'.domain'}, |
| 'course', |
'course',$mapp,\$recursed,\@recurseup, |
| ($courselevelm,$courselevel)); |
$courseid,'.',$spacequalifierrest, |
| if (defined($coursereply)) { return $coursereply; } |
([$courselevelm,'map' ], |
| |
[$courseleveli,'map' ], |
| |
[$courselevel, 'course'])); |
| |
if (defined($coursereply)) { return &get_reply($coursereply); } |
| } |
} |
| # ------------------------------------------------------------------ Cascade up |
# ------------------------------------------------------------------ Cascade up |
| unless ($space eq '0') { |
unless ($space eq '0') { |
|
Line 6094 sub EXT {
|
Line 12455 sub EXT {
|
| my $id=pop(@parts); |
my $id=pop(@parts); |
| my $part=join('_',@parts); |
my $part=join('_',@parts); |
| if ($part eq '') { $part='0'; } |
if ($part eq '') { $part='0'; } |
| my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, |
my @partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, |
| $symbparm,$udom,$uname,$section,1); |
$symbparm,$udom,$uname,$section,1); |
| if (defined($partgeneral)) { return $partgeneral; } |
if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); } |
| } |
} |
| if ($recurse) { return undef; } |
if ($recurse) { return undef; } |
| my $pack_def=&packages_tab_default($filename,$varname); |
my $pack_def=&packages_tab_default($filename,$varname,$toolsymb); |
| if (defined($pack_def)) { return $pack_def; } |
if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); } |
| |
|
| # ---------------------------------------------------- Any other user namespace |
# ---------------------------------------------------- Any other user namespace |
| } elsif ($realm eq 'environment') { |
} elsif ($realm eq 'environment') { |
| # ----------------------------------------------------------------- environment |
# ----------------------------------------------------------------- environment |
|
Line 6125 sub EXT {
|
Line 12485 sub EXT {
|
| if ($space eq 'name') { |
if ($space eq 'name') { |
| return $ENV{'SERVER_NAME'}; |
return $ENV{'SERVER_NAME'}; |
| } |
} |
| |
} elsif ($realm eq 'client') { |
| |
if ($space eq 'remote_addr') { |
| |
return &get_requestor_ip(); |
| |
} |
| } |
} |
| return ''; |
return ''; |
| } |
} |
| |
|
| |
sub get_reply { |
| |
my ($reply_value) = @_; |
| |
if (ref($reply_value) eq 'ARRAY') { |
| |
if (wantarray) { |
| |
return @$reply_value; |
| |
} |
| |
return $reply_value->[0]; |
| |
} else { |
| |
return $reply_value; |
| |
} |
| |
} |
| |
|
| sub check_group_parms { |
sub check_group_parms { |
| my ($courseid,$groups,$symbparm,$mapparm,$what) = @_; |
my ($courseid,$groups,$symbparm,$recurseparm,$mapparm,$what,$mapp, |
| my @groupitems = (); |
$recursed,$recurseupref) = @_; |
| my $resultitem; |
my @levels = ([$symbparm,'resource'],[$mapparm,'map'],[$recurseparm,'map'], |
| my @levels = ($symbparm,$mapparm,$what); |
[$what,'course']); |
| |
my $coursereply; |
| foreach my $group (@{$groups}) { |
foreach my $group (@{$groups}) { |
| |
my @groupitems = (); |
| foreach my $level (@levels) { |
foreach my $level (@levels) { |
| my $item = $courseid.'.['.$group.'].'.$level; |
my $item = $courseid.'.['.$group.'].'.$level->[0]; |
| push(@groupitems,$item); |
push(@groupitems,[$item,$level->[1]]); |
| } |
} |
| |
my $coursereply = &resdata($env{'course.'.$courseid.'.num'}, |
| |
$env{'course.'.$courseid.'.domain'}, |
| |
'course',$mapp,$recursed,$recurseupref, |
| |
$courseid,'.['.$group.'].',$what, |
| |
@groupitems); |
| |
last if (defined($coursereply)); |
| } |
} |
| my $coursereply = &resdata($env{'course.'.$courseid.'.num'}, |
|
| $env{'course.'.$courseid.'.domain'}, |
|
| 'course',@groupitems); |
|
| return $coursereply; |
return $coursereply; |
| } |
} |
| |
|
| |
sub get_map_hierarchy { |
| |
my ($mapname,$courseid) = @_; |
| |
my @recurseup = (); |
| |
if ($mapname) { |
| |
if (($cachedmapkey eq $courseid) && |
| |
(abs($cachedmaptime-time)<5)) { |
| |
if (ref($cachedmaps{$mapname}) eq 'ARRAY') { |
| |
return @{$cachedmaps{$mapname}}; |
| |
} |
| |
} |
| |
my $navmap = Apache::lonnavmaps::navmap->new(); |
| |
if (ref($navmap)) { |
| |
@recurseup = $navmap->recurseup_maps($mapname); |
| |
undef($navmap); |
| |
$cachedmaps{$mapname} = \@recurseup; |
| |
$cachedmaptime=time; |
| |
$cachedmapkey=$courseid; |
| |
} |
| |
} |
| |
return @recurseup; |
| |
} |
| |
|
| |
} |
| |
|
| sub sort_course_groups { # Sort groups based on defined rankings. Default is sort(). |
sub sort_course_groups { # Sort groups based on defined rankings. Default is sort(). |
| my ($courseid,@groups) = @_; |
my ($courseid,@groups) = @_; |
| @groups = sort(@groups); |
@groups = sort(@groups); |
|
Line 6153 sub sort_course_groups { # Sort groups b
|
Line 12558 sub sort_course_groups { # Sort groups b
|
| } |
} |
| |
|
| sub packages_tab_default { |
sub packages_tab_default { |
| my ($uri,$varname)=@_; |
my ($uri,$varname,$toolsymb)=@_; |
| my (undef,$part,$name)=split(/\./,$varname); |
my (undef,$part,$name)=split(/\./,$varname); |
| |
|
| my (@extension,@specifics,$do_default); |
my (@extension,@specifics,$do_default); |
| foreach my $package (split(/,/,&metadata($uri,'packages'))) { |
foreach my $package (split(/,/,&metadata($uri,'packages',$toolsymb))) { |
| my ($pack_type,$pack_part)=split(/_/,$package,2); |
my ($pack_type,$pack_part)=split(/_/,$package,2); |
| if ($pack_type eq 'default') { |
if ($pack_type eq 'default') { |
| $do_default=1; |
$do_default=1; |
| } elsif ($pack_type eq 'extension') { |
} elsif ($pack_type eq 'extension') { |
| push(@extension,[$package,$pack_type,$pack_part]); |
push(@extension,[$package,$pack_type,$pack_part]); |
| } else { |
} elsif ($pack_part eq $part || $pack_type eq 'part') { |
| |
# only look at packages defaults for packages that this id is |
| push(@specifics,[$package,$pack_type,$pack_part]); |
push(@specifics,[$package,$pack_type,$pack_part]); |
| } |
} |
| } |
} |
|
Line 6222 sub add_prefix_and_part {
|
Line 12628 sub add_prefix_and_part {
|
| # ---------------------------------------------------------------- Get metadata |
# ---------------------------------------------------------------- Get metadata |
| |
|
| my %metaentry; |
my %metaentry; |
| |
my %importedpartids; |
| |
my %importedrespids; |
| sub metadata { |
sub metadata { |
| my ($uri,$what,$liburi,$prefix,$depthcount)=@_; |
my ($uri,$what,$toolsymb,$liburi,$prefix,$depthcount)=@_; |
| $uri=&declutter($uri); |
$uri=&declutter($uri); |
| # if it is a non metadata possible uri return quickly |
# if it is a non metadata possible uri return quickly |
| if (($uri eq '') || |
if (($uri eq '') || |
| (($uri =~ m|^/*adm/|) && |
(($uri =~ m|^/*adm/|) && |
| ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) || |
($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard|ext\.tool)$})) || |
| ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) || |
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) { |
| ($uri =~ m|home/$match_username/public_html/|)) { |
return undef; |
| |
} |
| |
if (($uri =~ /^priv/ || $uri=~m{^home/httpd/html/priv}) |
| |
&& &Apache::lonxml::get_state('target') =~ /^(|meta)$/) { |
| return undef; |
return undef; |
| } |
} |
| my $filename=$uri; |
my $filename=$uri; |
|
Line 6244 sub metadata {
|
Line 12655 sub metadata {
|
| my ($result,$cached)=&is_cached_new('meta',$uri); |
my ($result,$cached)=&is_cached_new('meta',$uri); |
| if (defined($cached)) { return $result->{':'.$what}; } |
if (defined($cached)) { return $result->{':'.$what}; } |
| } |
} |
| |
|
| |
# |
| |
# If the uri is for an external tool the file from |
| |
# which metadata should be retrieved depends on whether |
| |
# the tool had been configured to be gradable (set in the Course |
| |
# Editor or Resource Editor). |
| |
# |
| |
# If a valid symb has been included as the third arg in the call |
| |
# to &metadata() that can be used to retrieve the value of |
| |
# parameter_0_gradable set for the resource, and included in the |
| |
# uploaded map containing the tool. The value is retrieved via |
| |
# &EXT(), if a valid symb is available. Otherwise the value of |
| |
# gradable in the exttool_$marker.db file for the tool instance |
| |
# is retrieved via &get(). |
| |
# |
| |
# When lonuserstate::traceroute() calls lonnet::EXT() for |
| |
# hiddenresource and encrypturl (during course initialization) |
| |
# the map-level parameter for resource.0.gradable included in the |
| |
# uploaded map containing the tool will not yet have been stored |
| |
# in the user_course_parms.db file for the user's session, so in |
| |
# this case fall back to retrieving gradable status from the |
| |
# exttool_$marker.db file. |
| |
# |
| |
# In order to avoid an infinite loop, &metadata() will return |
| |
# before a call to &EXT(), if the uri is for an external tool |
| |
# and the $what for which metadata is being requested is |
| |
# parameter_0_gradable or 0_gradable. |
| |
# |
| |
|
| |
if ($uri =~ /ext\.tool$/) { |
| |
if (($what eq 'parameter_0_gradable') || ($what eq '0_gradable')) { |
| |
return; |
| |
} else { |
| |
my ($checked,$use_passback); |
| |
if ($toolsymb ne '') { |
| |
(undef,undef,my $tooluri) = &decode_symb($toolsymb); |
| |
if (($tooluri eq $uri) && (&EXT('resource.0.gradable',$toolsymb))) { |
| |
$checked = 1; |
| |
if (&EXT('resource.0.gradable',$toolsymb) =~ /^yes$/i) { |
| |
$use_passback = 1; |
| |
} |
| |
} |
| |
} |
| |
unless ($checked) { |
| |
my ($ignore,$cdom,$cnum,$marker) = split(m{/},$uri); |
| |
$marker=~s/\D//g; |
| |
if ($marker) { |
| |
my %toolsettings=&get('exttool_'.$marker,['gradable'],$cdom,$cnum); |
| |
$use_passback = $toolsettings{'gradable'}; |
| |
} |
| |
} |
| |
if ($use_passback) { |
| |
$filename = '/home/httpd/html/res/lib/templates/LTIpassback.tool'; |
| |
} else { |
| |
$filename = '/home/httpd/html/res/lib/templates/LTIstandard.tool'; |
| |
} |
| |
} |
| |
} |
| |
|
| { |
{ |
| |
# Imported parts would go here |
| |
my @origfiletagids=(); |
| |
my $importedparts=0; |
| |
|
| |
# Imported responseids would go here |
| |
my $importedresponses=0; |
| # |
# |
| # Is this a recursive call for a library? |
# Is this a recursive call for a library? |
| # |
# |
| # if (! exists($metacache{$uri})) { |
# if (! exists($metacache{$uri})) { |
| # $metacache{$uri}={}; |
# $metacache{$uri}={}; |
| # } |
# } |
| |
my $cachetime = 60*60; |
| if ($liburi) { |
if ($liburi) { |
| $liburi=&declutter($liburi); |
$liburi=&declutter($liburi); |
| $filename=$liburi; |
$filename=$liburi; |
|
Line 6261 sub metadata {
|
Line 12738 sub metadata {
|
| my %metathesekeys=(); |
my %metathesekeys=(); |
| unless ($filename=~/\.meta$/) { $filename.='.meta'; } |
unless ($filename=~/\.meta$/) { $filename.='.meta'; } |
| my $metastring; |
my $metastring; |
| if ($uri !~ m -^(editupload)/-) { |
if ($uri =~ /^priv/ || $uri=~/home\/httpd\/html\/priv/) { |
| |
my $which = &hreflocation('','/'.($liburi || $uri)); |
| |
$metastring = |
| |
&Apache::lonnet::ssi_body($which, |
| |
('grade_target' => 'meta')); |
| |
$cachetime = 1; # only want this cached in the child not long term |
| |
} elsif (($uri !~ m -^(editupload)/-) && |
| |
($uri !~ m{^/*uploaded/$match_domain/$match_courseid/docs/})) { |
| my $file=&filelocation('',&clutter($filename)); |
my $file=&filelocation('',&clutter($filename)); |
| #push(@{$metaentry{$uri.'.file'}},$file); |
#push(@{$metaentry{$uri.'.file'}},$file); |
| $metastring=&getfile($file); |
$metastring=&getfile($file); |
|
Line 6321 sub metadata {
|
Line 12805 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 $importid=$token->[2]->{'id'}; |
| |
my $importmode=$token->[2]->{'importmode'}; |
| |
# |
| |
# Check metadata for imported file to |
| |
# see if it contained response items |
| |
# |
| |
my ($origfile,@libfilekeys); |
| |
my %currmetaentry = %metaentry; |
| |
@libfilekeys = split(/,/,&metadata($location,'keys',undef,undef,undef, |
| |
$depthcount+1)); |
| |
if (grep(/^responseorder$/,@libfilekeys)) { |
| |
my $libresponseorder = &metadata($location,'responseorder',undef,undef, |
| |
undef,$depthcount+1); |
| |
if ($libresponseorder ne '') { |
| |
if ($#origfiletagids<0) { |
| |
undef(%importedrespids); |
| |
undef(%importedpartids); |
| |
} |
| |
my @respids = split(/\s*,\s*/,$libresponseorder); |
| |
if (@respids) { |
| |
$importedrespids{$importid} = join(',',map { $importid.'_'.$_ } @respids); |
| |
} |
| |
if ($importedrespids{$importid} ne '') { |
| |
$importedresponses = 1; |
| |
# We need to get the original file and the imported file to get the response order correct |
| |
# Load and inspect original file |
| |
if ($#origfiletagids<0) { |
| |
my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri); |
| |
$origfile=&getfile($origfilelocation); |
| |
@origfiletagids=($origfile=~/<((?:\w+)response|import|part)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
# Do not overwrite contents of %metaentry hash for resource itself with |
| |
# hash populated for imported library file |
| |
%metaentry = %currmetaentry; |
| |
undef(%currmetaentry); |
| |
if ($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 we didn't do that already |
| |
if ($#origfiletagids<0) { |
| |
undef(%importedrespids); |
| |
undef(%importedpartids); |
| |
if ($origfile eq '') { |
| |
my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri); |
| |
$origfile=&getfile($origfilelocation); |
| |
@origfiletagids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); |
| |
} |
| |
} |
| |
my @impfilepartids; |
| |
# If <partorder> tag is included in metadata for the imported file |
| |
# get the parts in the imported file from that. |
| |
if (grep(/^partorder$/,@libfilekeys)) { |
| |
%currmetaentry = %metaentry; |
| |
my $libpartorder = &metadata($location,'partorder',undef,undef,undef, |
| |
$depthcount+1); |
| |
%metaentry = %currmetaentry; |
| |
undef(%currmetaentry); |
| |
if ($libpartorder ne '') { |
| |
@impfilepartids=split(/\s*,\s*/,$libpartorder); |
| |
} |
| |
} else { |
| |
# If no <partorder> tag available, load and inspect imported file |
| |
my $impfile=&getfile($location); |
| |
@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 { |
| |
# Import as problem or as normal import |
| |
$unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); |
| |
unless ($importmode eq 'problem') { |
| |
# Normal import |
| |
if (defined($token->[2]->{'id'})) { |
| |
$unikey.='_'.$token->[2]->{'id'}; |
| |
} |
| |
} |
| |
# Check metadata for imported file to |
| |
# see if it contained parts |
| |
if (grep(/^partorder$/,@libfilekeys)) { |
| |
%currmetaentry = %metaentry; |
| |
my $libpartorder = &metadata($location,'partorder',undef,undef,undef, |
| |
$depthcount+1); |
| |
%metaentry = %currmetaentry; |
| |
undef(%currmetaentry); |
| |
if ($libpartorder ne '') { |
| |
$importedparts = 1; |
| |
$importedpartids{$token->[2]->{'id'}}=$libpartorder; |
| |
} |
| |
} |
| |
} |
| 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',$toolsymb,$location,$unikey, |
| $depthcount+1); |
$depthcount+1); |
| foreach my $meta (split(',',$metadata)) { |
foreach my $meta (split(',',$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 6366 sub metadata {
|
Line 12949 sub metadata {
|
| # only ws inside the tag, and not in default, so use default |
# only ws inside the tag, and not in default, so use default |
| # as value |
# as value |
| $metaentry{':'.$unikey}=$default; |
$metaentry{':'.$unikey}=$default; |
| } else { |
} elsif ( $internaltext =~ /\S/ ) { |
| # either something interesting inside the tag or default |
# something interesting inside the tag |
| # uninteresting |
|
| $metaentry{':'.$unikey}=$internaltext; |
$metaentry{':'.$unikey}=$internaltext; |
| |
} else { |
| |
# no interesting values, don't set a default |
| } |
} |
| # end of not-a-package not-a-library import |
# end of not-a-package not-a-library import |
| } |
} |
|
Line 6379 sub metadata {
|
Line 12963 sub metadata {
|
| } |
} |
| } |
} |
| my ($extension) = ($uri =~ /\.(\w+)$/); |
my ($extension) = ($uri =~ /\.(\w+)$/); |
| |
$extension = lc($extension); |
| |
if ($extension eq 'htm') { $extension='html'; } |
| |
|
| foreach my $key (keys(%packagetab)) { |
foreach my $key (keys(%packagetab)) { |
| #no specific packages #how's our extension |
#no specific packages #how's our extension |
| if ($key!~/^extension_\Q$extension\E&/) { next; } |
if ($key!~/^extension_\Q$extension\E&/) { next; } |
| &metadata_create_package_def($uri,$key,'extension_'.$extension, |
&metadata_create_package_def($uri,$key,'extension_'.$extension, |
| \%metathesekeys); |
\%metathesekeys); |
| } |
} |
| if (!exists($metaentry{':packages'})) { |
|
| |
if (!exists($metaentry{':packages'}) |
| |
|| $packagetab{"import_defaults&extension_$extension"}) { |
| foreach my $key (keys(%packagetab)) { |
foreach my $key (keys(%packagetab)) { |
| #no specific packages well let's get default then |
#no specific packages well let's get default then |
| if ($key!~/^default&/) { next; } |
if ($key!~/^default&/) { next; } |
|
Line 6405 sub metadata {
|
Line 12994 sub metadata {
|
| $dir=~s|[^/]*$||; |
$dir=~s|[^/]*$||; |
| $location=&filelocation($dir,$location); |
$location=&filelocation($dir,$location); |
| my $rights_metadata = |
my $rights_metadata = |
| &metadata($uri,'keys',$location,'_rights', |
&metadata($uri,'keys',$toolsymb,$location,'_rights', |
| $depthcount+1); |
$depthcount+1); |
| foreach my $rights (split(',',$rights_metadata)) { |
foreach my $rights (split(',',$rights_metadata)) { |
| #$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights}; |
#$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights}; |
|
Line 6419 sub metadata {
|
Line 13008 sub metadata {
|
| grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'})); |
grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'})); |
| $metaentry{':packages'} = join(',',@uniq_packages); |
$metaentry{':packages'} = join(',',@uniq_packages); |
| |
|
| |
if (($importedresponses) || ($importedparts)) { |
| |
if ($importedparts) { |
| |
# We had imported parts and need to rebuild partorder |
| |
$metaentry{':partorder'}=''; |
| |
$metathesekeys{'partorder'}=1; |
| |
} |
| |
if ($importedresponses) { |
| |
# We had imported responses and need to rebuil responseorder |
| |
$metaentry{':responseorder'}=''; |
| |
$metathesekeys{'responseorder'}=1; |
| |
} |
| |
for (my $index=0;$index<$#origfiletagids;$index+=2) { |
| |
my $origid = $origfiletagids[$index+1]; |
| |
if ($origfiletagids[$index] eq 'part') { |
| |
# Original part, part of the problem |
| |
if ($importedparts) { |
| |
$metaentry{':partorder'}.=','.$origid; |
| |
} |
| |
} elsif ($origfiletagids[$index] eq 'import') { |
| |
if ($importedparts) { |
| |
# We have imported parts at this position |
| |
if ($importedpartids{$origid} ne '') { |
| |
$metaentry{':partorder'}.=','.$importedpartids{$origid}; |
| |
} |
| |
} |
| |
if ($importedresponses) { |
| |
# We have imported responses at this position |
| |
if ($importedrespids{$origid} ne '') { |
| |
$metaentry{':responseorder'}.=','.$importedrespids{$origid}; |
| |
} |
| |
} |
| |
} else { |
| |
# Original response item, part of the problem |
| |
if ($importedresponses) { |
| |
$metaentry{':responseorder'}.=','.$origid; |
| |
} |
| |
} |
| |
} |
| |
if ($importedparts) { |
| |
$metaentry{':partorder'}=~s/^\,//; |
| |
} |
| |
if ($importedresponses) { |
| |
$metaentry{':responseorder'}=~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)); |
| &do_cache_new('meta',$uri,\%metaentry,60*60); |
unless ($liburi) { |
| |
&do_cache_new('meta',$uri,\%metaentry,$cachetime); |
| |
} |
| # this is the end of "was not already recently cached |
# this is the end of "was not already recently cached |
| } |
} |
| return $metaentry{':'.$what}; |
return $metaentry{':'.$what}; |
|
Line 6491 sub devalidate_title_cache {
|
Line 13127 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 6504 sub gettitle {
|
Line 13145 sub gettitle {
|
| } |
} |
| my ($map,$resid,$url)=&decode_symb($symb); |
my ($map,$resid,$url)=&decode_symb($symb); |
| my $title=''; |
my $title=''; |
| my %bighash; |
if (!$map && $resid == 0 && $url =~/default\.sequence$/) { |
| if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db', |
$title = $env{'course.'.$env{'request.course.id'}.'.description'}; |
| &GDBM_READER(),0640)) { |
} else { |
| my $mapid=$bighash{'map_pc_'.&clutter($map)}; |
if (tie(my %bighash,'GDBM_File',$env{'request.course.fn'}.'.db', |
| $title=$bighash{'title_'.$mapid.'.'.$resid}; |
&GDBM_READER(),0640)) { |
| untie %bighash; |
my $mapid=$bighash{'map_pc_'.&clutter($map)}; |
| |
$title=$bighash{'title_'.$mapid.'.'.$resid}; |
| |
untie(%bighash); |
| |
} |
| } |
} |
| $title=~s/\&colon\;/\:/gs; |
$title=~s/\&colon\;/\:/gs; |
| if ($title) { |
if ($title) { |
| |
# Remember both $symb and $title for dynamic metadata |
| |
$accesshash{$symb.'___crstitle'}=$title; |
| |
$accesshash{&declutter($map).'___'.&declutter($url).'___usage'}=time; |
| |
# Cache this title and then return it |
| return &do_cache_new('title',$key,$title,600); |
return &do_cache_new('title',$key,$title,600); |
| } |
} |
| $urlsymb=$url; |
$urlsymb=$url; |
|
Line 6545 sub get_slot {
|
Line 13193 sub get_slot {
|
| } |
} |
| return $slotinfo{$which}; |
return $slotinfo{$which}; |
| } |
} |
| |
|
| |
sub get_reservable_slots { |
| |
my ($cnum,$cdom,$uname,$udom) = @_; |
| |
my $now = time; |
| |
my $reservable_info; |
| |
my $key=join("\0",'reservableslots',$cdom,$cnum,$uname,$udom); |
| |
if (exists($remembered{$key})) { |
| |
$reservable_info = $remembered{$key}; |
| |
} else { |
| |
my %resv; |
| |
($resv{'now_order'},$resv{'now'},$resv{'future_order'},$resv{'future'}) = |
| |
&Apache::loncommon::get_future_slots($cnum,$cdom,$now); |
| |
$reservable_info = \%resv; |
| |
$remembered{$key} = $reservable_info; |
| |
} |
| |
return $reservable_info; |
| |
} |
| |
|
| |
sub get_course_slots { |
| |
my ($cnum,$cdom) = @_; |
| |
my $hashid=$cnum.':'.$cdom; |
| |
my ($result,$cached) = &Apache::lonnet::is_cached_new('allslots',$hashid); |
| |
if (defined($cached)) { |
| |
if (ref($result) eq 'HASH') { |
| |
return %{$result}; |
| |
} |
| |
} else { |
| |
my %slots=&Apache::lonnet::dump('slots',$cdom,$cnum); |
| |
my ($tmp) = keys(%slots); |
| |
if ($tmp !~ /^(con_lost|error|no_such_host)/i) { |
| |
&do_cache_new('allslots',$hashid,\%slots,600); |
| |
return %slots; |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| |
sub devalidate_slots_cache { |
| |
my ($cnum,$cdom)=@_; |
| |
my $hashid=$cnum.':'.$cdom; |
| |
&devalidate_cache_new('allslots',$hashid); |
| |
} |
| |
|
| |
sub get_coursechange { |
| |
my ($cdom,$cnum) = @_; |
| |
if ($cdom eq '' || $cnum eq '') { |
| |
return unless ($env{'request.course.id'}); |
| |
$cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; |
| |
$cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; |
| |
} |
| |
my $hashid=$cdom.'_'.$cnum; |
| |
my ($change,$cached)=&is_cached_new('crschange',$hashid); |
| |
if ((defined($cached)) && ($change ne '')) { |
| |
return $change; |
| |
} else { |
| |
my %crshash; |
| |
%crshash = &get('environment',['internal.contentchange'],$cdom,$cnum); |
| |
if ($crshash{'internal.contentchange'} eq '') { |
| |
$change = $env{'course.'.$cdom.'_'.$cnum.'.internal.created'}; |
| |
if ($change eq '') { |
| |
%crshash = &get('environment',['internal.created'],$cdom,$cnum); |
| |
$change = $crshash{'internal.created'}; |
| |
} |
| |
} else { |
| |
$change = $crshash{'internal.contentchange'}; |
| |
} |
| |
my $cachetime = 600; |
| |
&do_cache_new('crschange',$hashid,$change,$cachetime); |
| |
} |
| |
return $change; |
| |
} |
| |
|
| |
sub devalidate_coursechange_cache { |
| |
my ($cnum,$cdom)=@_; |
| |
my $hashid=$cnum.':'.$cdom; |
| |
&devalidate_cache_new('crschange',$hashid); |
| |
} |
| |
|
| # ------------------------------------------------- Update symbolic store links |
# ------------------------------------------------- Update symbolic store links |
| |
|
| sub symblist { |
sub symblist { |
|
Line 6554 sub symblist {
|
Line 13280 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 6572 sub symblist {
|
Line 13298 sub symblist {
|
| # --------------------------------------------------------------- Verify a symb |
# --------------------------------------------------------------- Verify a symb |
| |
|
| sub symbverify { |
sub symbverify { |
| my ($symb,$thisurl)=@_; |
my ($symb,$thisurl,$encstate)=@_; |
| my $thisfn=$thisurl; |
my $thisfn=$thisurl; |
| $thisfn=&declutter($thisfn); |
$thisfn=&declutter($thisfn); |
| # direct jump to resource in page or to a sequence - will construct own symbs |
# direct jump to resource in page or to a sequence - will construct own symbs |
|
Line 6591 sub symbverify {
|
Line 13317 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)) { |
| my $ids=$bighash{'ids_'.&clutter($thisurl)}; |
if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) { |
| unless ($ids) { |
$thisurl =~ s/\?.+$//; |
| $ids=$bighash{'ids_/'.$thisurl}; |
if ($map =~ m{^uploaded/.+\.page$}) { |
| |
$thisurl =~ s{^(/adm/wrapper|)/ext/}{http://}; |
| |
$thisurl =~ s{^\Qhttp://https://\E}{https://}; |
| |
} |
| |
} |
| |
my $ids; |
| |
if ($map =~ m{^uploaded/.+\.page$}) { |
| |
$ids=$bighash{'ids_'.&clutter_with_no_wrapper($thisurl)}; |
| |
} else { |
| |
$ids=$bighash{'ids_'.&clutter($thisurl)}; |
| |
} |
| |
unless ($ids) { |
| |
my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl; |
| |
$ids=$bighash{$idkey}; |
| } |
} |
| if ($ids) { |
if ($ids) { |
| # ------------------------------------------------------------------- Has ID(s) |
# ------------------------------------------------------------------- Has ID(s) |
| |
if ($thisfn =~ m{^/adm/wrapper/ext/}) { |
| |
$symb =~ s/\?.+$//; |
| |
} |
| foreach my $id (split(/\,/,$ids)) { |
foreach my $id (split(/\,/,$ids)) { |
| my ($mapid,$resid)=split(/\./,$id); |
my ($mapid,$resid)=split(/\./,$id); |
| if ( |
if ( |
| &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) |
&symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) |
| eq $symb) { |
eq $symb) { |
| |
if (ref($encstate)) { |
| |
$$encstate = $bighash{'encrypted_'.$id}; |
| |
} |
| if (($env{'request.role.adv'}) || |
if (($env{'request.role.adv'}) || |
| $bighash{'encrypted_'.$id} eq $env{'request.enc'}) { |
($bighash{'encrypted_'.$id} eq $env{'request.enc'}) || |
| $okay=1; |
($thisurl eq '/adm/navmaps')) { |
| |
$okay=1; |
| |
last; |
| } |
} |
| } |
} |
| } |
} |
|
Line 6679 sub deversion {
|
Line 13426 sub deversion {
|
| # ------------------------------------------------------ Return symb list entry |
# ------------------------------------------------------ Return symb list entry |
| |
|
| sub symbread { |
sub symbread { |
| my ($thisfn,$donotrecurse)=@_; |
my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles, |
| |
$ignoresymbdb,$noenccheck)=@_; |
| my $cache_str='request.symbread.cached.'.$thisfn; |
my $cache_str='request.symbread.cached.'.$thisfn; |
| if (defined($env{$cache_str})) { return $env{$cache_str}; } |
if (defined($env{$cache_str})) { |
| |
unless (ref($possibles) eq 'HASH') { |
| |
if ($ignorecachednull) { |
| |
return $env{$cache_str} unless ($env{$cache_str} eq ''); |
| |
} else { |
| |
return $env{$cache_str}; |
| |
} |
| |
} |
| |
} |
| # no filename provided? try from environment |
# no filename provided? try from environment |
| unless ($thisfn) { |
unless ($thisfn) { |
| if ($env{'request.symb'}) { |
if ($env{'request.symb'}) { |
| return $env{$cache_str}=&symbclean($env{'request.symb'}); |
return $env{$cache_str}=&symbclean($env{'request.symb'}); |
| } |
} |
| $thisfn=$env{'request.filename'}; |
$thisfn=$env{'request.filename'}; |
| } |
} |
|
Line 6708 sub symbread {
|
Line 13464 sub symbread {
|
| if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) { |
if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) { |
| $targetfn=$1; |
$targetfn=$1; |
| } |
} |
| if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db', |
unless ($ignoresymbdb) { |
| &GDBM_READER(),0640)) { |
if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db', |
| $syval=$hash{$targetfn}; |
&GDBM_READER(),0640)) { |
| untie(%hash); |
$syval=$hash{$targetfn}; |
| |
untie(%hash); |
| |
} |
| |
if ($syval && $checkforblock) { |
| |
my @blockers = &has_comm_blocking('bre',$syval,$thisfn,$ignoresymbdb,$noenccheck); |
| |
if (@blockers) { |
| |
$syval=''; |
| |
} |
| |
} |
| } |
} |
| # ---------------------------------------------------------- There was an entry |
# ---------------------------------------------------------- There was an entry |
| if ($syval) { |
if ($syval) { |
| #unless ($syval=~/\_\d+$/) { |
#unless ($syval=~/\_\d+$/) { |
| #unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) { |
#unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) { |
| #&appenv('request.ambiguous' => $thisfn); |
#&appenv({'request.ambiguous' => $thisfn}); |
| #return $env{$cache_str}=''; |
#return $env{$cache_str}=''; |
| #} |
#} |
| #$syval.=$1; |
#$syval.=$1; |
|
Line 6743 sub symbread {
|
Line 13507 sub symbread {
|
| my ($mapid,$resid)=split(/\./,$ids); |
my ($mapid,$resid)=split(/\./,$ids); |
| $syval=&encode_symb($bighash{'map_id_'.$mapid}, |
$syval=&encode_symb($bighash{'map_id_'.$mapid}, |
| $resid,$thisfn); |
$resid,$thisfn); |
| } elsif (!$donotrecurse) { |
if (ref($possibles) eq 'HASH') { |
| |
unless ($bighash{'randomout_'.$ids} || $env{'request.role.adv'}) { |
| |
$possibles->{$syval} = 1; |
| |
} |
| |
} |
| |
if ($checkforblock) { |
| |
unless ($bighash{'randomout_'.$ids} || $env{'request.role.adv'}) { |
| |
my @blockers = &has_comm_blocking('bre',$syval,$bighash{'src_'.$ids},'',$noenccheck); |
| |
if (@blockers) { |
| |
$syval = ''; |
| |
untie(%bighash); |
| |
return $env{$cache_str}=''; |
| |
} |
| |
} |
| |
} |
| |
} elsif ((!$donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) { |
| # ------------------------------------------ There is more than one possibility |
# ------------------------------------------ There is more than one possibility |
| my $realpossible=0; |
my $realpossible=0; |
| foreach my $id (@possibilities) { |
foreach my $id (@possibilities) { |
| my $file=$bighash{'src_'.$id}; |
my $file=$bighash{'src_'.$id}; |
| if (&allowed('bre',$file)) { |
my $canaccess; |
| my ($mapid,$resid)=split(/\./,$id); |
if (($donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) { |
| if ($bighash{'map_type_'.$mapid} ne 'page') { |
$canaccess = 1; |
| $realpossible++; |
} else { |
| $syval=&encode_symb($bighash{'map_id_'.$mapid}, |
$canaccess = &allowed('bre',$file); |
| $resid,$thisfn); |
} |
| } |
if ($canaccess) { |
| |
my ($mapid,$resid)=split(/\./,$id); |
| |
if ($bighash{'map_type_'.$mapid} ne 'page') { |
| |
my $poss_syval=&encode_symb($bighash{'map_id_'.$mapid}, |
| |
$resid,$thisfn); |
| |
next if ($bighash{'randomout_'.$id} && !$env{'request.role.adv'}); |
| |
next unless (($noenccheck) || ($bighash{'encrypted_'.$id} eq $env{'request.enc'})); |
| |
if ($checkforblock) { |
| |
my @blockers = &has_comm_blocking('bre',$poss_syval,$file,'',$noenccheck); |
| |
if (@blockers > 0) { |
| |
$syval = ''; |
| |
} else { |
| |
$syval = $poss_syval; |
| |
$realpossible++; |
| |
} |
| |
} else { |
| |
$syval = $poss_syval; |
| |
$realpossible++; |
| |
} |
| |
if ($syval) { |
| |
if (ref($possibles) eq 'HASH') { |
| |
$possibles->{$syval} = 1; |
| |
} |
| |
} |
| |
} |
| } |
} |
| } |
} |
| if ($realpossible!=1) { $syval=''; } |
if ($realpossible!=1) { $syval=''; } |
|
Line 6762 sub symbread {
|
Line 13565 sub symbread {
|
| $syval=''; |
$syval=''; |
| } |
} |
| } |
} |
| untie(%bighash) |
untie(%bighash); |
| } |
} |
| } |
} |
| if ($syval) { |
if ($syval) { |
| return $env{$cache_str}=$syval; |
return $env{$cache_str}=$syval; |
| } |
} |
| } |
} |
| &appenv('request.ambiguous' => $thisfn); |
&appenv({'request.ambiguous' => $thisfn}); |
| return $env{$cache_str}=''; |
return $env{$cache_str}=''; |
| } |
} |
| |
|
|
Line 6878 sub getCODE {
|
Line 13681 sub getCODE {
|
| } |
} |
| return undef; |
return undef; |
| } |
} |
| |
# |
| |
# Determines the random seed for a specific context: |
| |
# |
| |
# parameters: |
| |
# symb - in course context the symb for the seed. |
| |
# course_id - The course id of the form domain_coursenum. |
| |
# domain - Domain for the user. |
| |
# course - Course for the user. |
| |
# cenv - environment of the course. |
| |
# |
| |
# NOTE: |
| |
# All parameters are picked out of the environment if missing |
| |
# or not defined. |
| |
# If a symb cannot be determined the current time is used instead. |
| |
# |
| |
# For a given well defined symb, courside, domain, username, |
| |
# and course environment, the seed is reproducible. |
| |
# |
| sub rndseed { |
sub rndseed { |
| my ($symb,$courseid,$domain,$username)=@_; |
my ($symb,$courseid,$domain,$username, $cenv)=@_; |
| |
|
| my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser(); |
my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser(); |
| if (!$symb) { |
if (!defined($symb)) { |
| unless ($symb=$wsymb) { return time; } |
unless ($symb=$wsymb) { return time; } |
| } |
} |
| if (!$courseid) { $courseid=$wcourseid; } |
if (!defined $courseid) { |
| if (!$domain) { $domain=$wdomain; } |
$courseid=$wcourseid; |
| if (!$username) { $username=$wusername } |
} |
| my $which=&get_rand_alg(); |
if (!defined $domain) { $domain=$wdomain; } |
| |
if (!defined $username) { $username=$wusername } |
| |
|
| |
my $which; |
| |
if (defined($cenv->{'rndseed'})) { |
| |
$which = $cenv->{'rndseed'}; |
| |
} else { |
| |
$which =&get_rand_alg($courseid); |
| |
} |
| if (defined(&getCODE())) { |
if (defined(&getCODE())) { |
| |
|
| if ($which eq '64bit5') { |
if ($which eq '64bit5') { |
| return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username); |
return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username); |
| } elsif ($which eq '64bit4') { |
} elsif ($which eq '64bit4') { |
|
Line 7077 sub rndseed_CODE_64bit5 {
|
Line 13904 sub rndseed_CODE_64bit5 {
|
| sub setup_random_from_rndseed { |
sub setup_random_from_rndseed { |
| my ($rndseed)=@_; |
my ($rndseed)=@_; |
| if ($rndseed =~/([,:])/) { |
if ($rndseed =~/([,:])/) { |
| my ($num1,$num2)=split(/[,:]/,$rndseed); |
my ($num1,$num2) = map { abs($_); } (split(/[,:]/,$rndseed)); |
| &Math::Random::random_set_seed(abs($num1),abs($num2)); |
if ((!$num1) || (!$num2) || ($num1 > 2147483562) || ($num2 > 2147483398)) { |
| |
&Math::Random::random_set_seed_from_phrase($rndseed); |
| |
} else { |
| |
&Math::Random::random_set_seed($num1,$num2); |
| |
} |
| } else { |
} else { |
| &Math::Random::random_set_seed_from_phrase($rndseed); |
&Math::Random::random_set_seed_from_phrase($rndseed); |
| } |
} |
| } |
} |
| |
|
| sub latest_receipt_algorithm_id { |
sub latest_receipt_algorithm_id { |
| return 'receipt2'; |
return 'receipt3'; |
| } |
} |
| |
|
| sub recunique { |
sub recunique { |
| my $fucourseid=shift; |
my $fucourseid=shift; |
| my $unique; |
my $unique; |
| if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') { |
if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' || |
| |
$env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) { |
| $unique=$env{"course.$fucourseid.internal.encseed"}; |
$unique=$env{"course.$fucourseid.internal.encseed"}; |
| } else { |
} else { |
| $unique=$perlvar{'lonReceipt'}; |
$unique=$perlvar{'lonReceipt'}; |
|
Line 7102 sub recunique {
|
Line 13934 sub recunique {
|
| sub recprefix { |
sub recprefix { |
| my $fucourseid=shift; |
my $fucourseid=shift; |
| my $prefix; |
my $prefix; |
| if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') { |
if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2'|| |
| |
$env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) { |
| $prefix=$env{"course.$fucourseid.internal.encpref"}; |
$prefix=$env{"course.$fucourseid.internal.encpref"}; |
| } else { |
} else { |
| $prefix=$perlvar{'lonHostID'}; |
$prefix=$perlvar{'lonHostID'}; |
|
Line 7112 sub recprefix {
|
Line 13945 sub recprefix {
|
| |
|
| sub ireceipt { |
sub ireceipt { |
| my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_; |
my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_; |
| |
|
| |
my $return =&recprefix($fucourseid).'-'; |
| |
|
| |
if ($env{"course.$fucourseid.receiptalg"} eq 'receipt3' || |
| |
$env{'request.state'} eq 'construct') { |
| |
$return .= (&digest("$funame,$fudom,$fucourseid,$fusymb,$part")%10000); |
| |
return $return; |
| |
} |
| |
|
| my $cuname=unpack("%32C*",$funame); |
my $cuname=unpack("%32C*",$funame); |
| my $cudom=unpack("%32C*",$fudom); |
my $cudom=unpack("%32C*",$fudom); |
| my $cucourseid=unpack("%32C*",$fucourseid); |
my $cucourseid=unpack("%32C*",$fucourseid); |
| my $cusymb=unpack("%32C*",$fusymb); |
my $cusymb=unpack("%32C*",$fusymb); |
| my $cunique=&recunique($fucourseid); |
my $cunique=&recunique($fucourseid); |
| my $cpart=unpack("%32S*",$part); |
my $cpart=unpack("%32S*",$part); |
| my $return =&recprefix($fucourseid).'-'; |
if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') { |
| if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' || |
|
| $env{'request.state'} eq 'construct') { |
|
| #&logthis("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname)." and ".($cpart%$cudom)); |
#&logthis("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname)." and ".($cpart%$cudom)); |
| |
|
| $return.= ($cunique%$cuname+ |
$return.= ($cunique%$cuname+ |
|
Line 7205 sub getfile {
|
Line 14046 sub getfile {
|
| |
|
| sub repcopy_userfile { |
sub repcopy_userfile { |
| my ($file)=@_; |
my ($file)=@_; |
| if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); } |
my $londocroot = $perlvar{'lonDocRoot'}; |
| if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; } |
if ($file =~ m{^/*(uploaded|editupload)/}) { $file=&filelocation("",$file); } |
| |
if ($file =~ m{^\Q/home/httpd/lonUsers/\E}) { return 'ok'; } |
| my ($cdom,$cnum,$filename) = |
my ($cdom,$cnum,$filename) = |
| ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|); |
($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|); |
| my $uri="/uploaded/$cdom/$cnum/$filename"; |
my $uri="/uploaded/$cdom/$cnum/$filename"; |
|
Line 7246 sub repcopy_userfile {
|
Line 14088 sub repcopy_userfile {
|
| } |
} |
| # now the path exists for sure |
# now the path exists for sure |
| # get a user agent |
# get a user agent |
| my $ua=new LWP::UserAgent; |
|
| my $transferfile=$file.'.in.transfer'; |
my $transferfile=$file.'.in.transfer'; |
| # FIXME: this should flock |
# FIXME: this should flock |
| 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 $response=$ua->request($request,$transferfile); |
my $hostname = &hostname($homeserver); |
| |
my $protocol = $protocol{$homeserver}; |
| |
$protocol = 'http' if ($protocol ne 'https'); |
| |
$request=new HTTP::Request('GET',$protocol.'://'.$hostname.'/raw/'.$uri); |
| |
my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,$transferfile,\%perlvar,'',0,1); |
| # did it work? |
# did it work? |
| if ($response->is_error()) { |
if ($response->is_error()) { |
| unlink($transferfile); |
unlink($transferfile); |
|
Line 7267 sub repcopy_userfile {
|
Line 14112 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; |
| my (undef,$udom,$uname,$file)=split('/',$uri,4); |
my (undef,$udom,$uname,$file)=split('/',$uri,4); |
| 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 $hostname = &hostname($homeserver); |
| |
my $protocol = $protocol{$homeserver}; |
| |
$protocol = 'http' if ($protocol ne 'https'); |
| |
return $protocol.'://'.$hostname.'/'.$uri. |
| (($uri=~/\?/)?'&':'?').'token='.$token. |
(($uri=~/\?/)?'&':'?').'token='.$token. |
| '&tokenissued='.$perlvar{'lonHostID'}; |
'&tokenissued='.$perlvar{'lonHostID'}; |
| } else { |
} else { |
|
Line 7290 sub tokenwrapper {
|
Line 14139 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 $ua=new LWP::UserAgent; |
my $hostname = &hostname($homeserver); |
| |
my $protocol = $protocol{$homeserver}; |
| |
$protocol = 'http' if ($protocol ne 'https'); |
| |
$uri = $protocol.'://'.$hostname.'/raw/'.$uri; |
| my $request=new HTTP::Request($reqtype,$uri); |
my $request=new HTTP::Request($reqtype,$uri); |
| my $response=$ua->request($request); |
my $response=&LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,'',0,1); |
| $$rtncode = $response->code; |
$$rtncode = $response->code; |
| if (! $response->is_success()) { |
if (! $response->is_success()) { |
| return 'failed'; |
return 'failed'; |
|
Line 7310 sub readfile {
|
Line 14162 sub readfile {
|
| my $file = shift; |
my $file = shift; |
| if ( (! -e $file ) || ($file eq '') ) { return -1; }; |
if ( (! -e $file ) || ($file eq '') ) { return -1; }; |
| my $fh; |
my $fh; |
| open($fh,"<$file"); |
open($fh,"<",$file); |
| my $a=''; |
my $a=''; |
| while (my $line = <$fh>) { $a .= $line; } |
while (my $line = <$fh>) { $a .= $line; } |
| return $a; |
return $a; |
|
Line 7325 sub filelocation {
|
Line 14177 sub filelocation {
|
| $file=~s-^/adm/wrapper/-/-; |
$file=~s-^/adm/wrapper/-/-; |
| $file=~s-^/adm/coursedocs/showdoc/-/-; |
$file=~s-^/adm/coursedocs/showdoc/-/-; |
| } |
} |
| if ($file=~m:^/~:) { # is a contruction space reference |
|
| $location = $file; |
if ($file =~ m-^\Q$Apache::lonnet::perlvar{'lonTabDir'}\E/-) { |
| $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; |
|
| } elsif ($file=~m{^/home/$match_username/public_html/}) { |
|
| # is a correct contruction space reference |
|
| $location = $file; |
$location = $file; |
| } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file |
} elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file |
| my ($udom,$uname,$filename)= |
my ($udom,$uname,$filename)= |
|
Line 7339 sub filelocation {
|
Line 14188 sub filelocation {
|
| my @ids=¤t_machine_ids(); |
my @ids=¤t_machine_ids(); |
| foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } } |
foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } } |
| if ($is_me) { |
if ($is_me) { |
| $location=&propath($udom,$uname). |
$location=propath($udom,$uname).'/userfiles/'.$filename; |
| '/userfiles/'.$filename; |
|
| } else { |
} else { |
| $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'. |
$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'. |
| $udom.'/'.$uname.'/'.$filename; |
$udom.'/'.$uname.'/'.$filename; |
| } |
} |
| |
} elsif ($file =~ m-^/adm/-) { |
| |
$location = $perlvar{'lonDocRoot'}.'/'.$file; |
| } else { |
} else { |
| $file=~s/^\Q$perlvar{'lonDocRoot'}\E//; |
$file=~s/^\Q$perlvar{'lonDocRoot'}\E//; |
| $file=~s:^/res/:/:; |
$file=~s:^/(res|priv)/:/:; |
| |
my $space=$1; |
| if ( !( $file =~ m:^/:) ) { |
if ( !( $file =~ m:^/:) ) { |
| $location = $dir. '/'.$file; |
$location = $dir. '/'.$file; |
| } else { |
} else { |
| $location = '/home/httpd/html/res'.$file; |
$location = $perlvar{'lonDocRoot'}.'/'.$space.$file; |
| } |
} |
| } |
} |
| $location=~s://+:/:g; # remove duplicate / |
$location=~s://+:/:g; # remove duplicate / |
| while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/.. |
while ($location=~m{/\.\./}) { |
| |
if ($location =~ m{/[^/]+/\.\./}) { |
| |
$location=~ s{/[^/]+/\.\./}{/}g; |
| |
} else { |
| |
$location=~ s{/\.\./}{/}g; |
| |
} |
| |
} #remove dir/.. |
| while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./ |
while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./ |
| return $location; |
return $location; |
| } |
} |
| |
|
| 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 7370 sub hreflocation {
|
Line 14227 sub hreflocation {
|
| } |
} |
| if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) { |
if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) { |
| $file=~s-^\Q$perlvar{'lonDocRoot'}\E--; |
$file=~s-^\Q$perlvar{'lonDocRoot'}\E--; |
| } elsif ($file=~m-/home/($match_username)/public_html/-) { |
|
| $file=~s-^/home/($match_username)/public_html/-/~$1/-; |
|
| } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) { |
} elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) { |
| $file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/ |
$file=~s{^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/} |
| -/uploaded/$1/$2/-x; |
{/uploaded/$1/$2/}x; |
| |
} |
| |
if ($file=~ m{^/userfiles/}) { |
| |
$file =~ s{^/userfiles/}{/uploaded/}; |
| } |
} |
| return $file; |
return $file; |
| } |
} |
| |
|
| |
|
| |
|
| |
|
| |
|
| sub current_machine_domains { |
sub current_machine_domains { |
| my $hostname=$hostname{$perlvar{'lonHostID'}}; |
return &machine_domains(&hostname($perlvar{'lonHostID'})); |
| |
} |
| |
|
| |
sub machine_domains { |
| |
my ($hostname) = @_; |
| my @domains; |
my @domains; |
| |
my %hostname = &all_hostnames(); |
| while( my($id, $name) = each(%hostname)) { |
while( my($id, $name) = each(%hostname)) { |
| # &logthis("-$id-$name-$hostname-"); |
# &logthis("-$id-$name-$hostname-"); |
| if ($hostname eq $name) { |
if ($hostname eq $name) { |
| push(@domains,$hostdom{$id}); |
push(@domains,&host_domain($id)); |
| } |
} |
| } |
} |
| return @domains; |
return @domains; |
| } |
} |
| |
|
| sub current_machine_ids { |
sub current_machine_ids { |
| my $hostname=$hostname{$perlvar{'lonHostID'}}; |
return &machine_ids(&hostname($perlvar{'lonHostID'})); |
| |
} |
| |
|
| |
sub machine_ids { |
| |
my ($hostname) = @_; |
| |
$hostname ||= &hostname($perlvar{'lonHostID'}); |
| my @ids; |
my @ids; |
| while( my($id, $name) = each(%hostname)) { |
my %name_to_host = &all_names(); |
| # &logthis("-$id-$name-$hostname-"); |
if (ref($name_to_host{$hostname}) eq 'ARRAY') { |
| if ($hostname eq $name) { |
return @{ $name_to_host{$hostname} }; |
| push(@ids,$id); |
|
| } |
|
| } |
} |
| return @ids; |
return; |
| } |
} |
| |
|
| sub additional_machine_domains { |
sub additional_machine_domains { |
| my @domains; |
my @domains; |
| open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab"); |
open(my $fh,"<","$perlvar{'lonTabDir'}/expected_domains.tab"); |
| while( my $line = <$fh>) { |
while( my $line = <$fh>) { |
| $line =~ s/\s//g; |
$line =~ s/\s//g; |
| push(@domains,$line); |
push(@domains,$line); |
|
Line 7426 sub default_login_domain {
|
Line 14296 sub default_login_domain {
|
| return $domain; |
return $domain; |
| } |
} |
| |
|
| |
sub shared_institution { |
| |
my ($dom,$lonhost) = @_; |
| |
if ($lonhost eq '') { |
| |
$lonhost = $perlvar{'lonHostID'}; |
| |
} |
| |
my $same_intdom; |
| |
my $hostintdom = &internet_dom($lonhost); |
| |
if ($hostintdom ne '') { |
| |
my %iphost = &get_iphost(); |
| |
my $primary_id = &domain($dom,'primary'); |
| |
my $primary_ip = &get_host_ip($primary_id); |
| |
if (ref($iphost{$primary_ip}) eq 'ARRAY') { |
| |
foreach my $id (@{$iphost{$primary_ip}}) { |
| |
my $intdom = &internet_dom($id); |
| |
if ($intdom eq $hostintdom) { |
| |
$same_intdom = 1; |
| |
last; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return $same_intdom; |
| |
} |
| |
|
| |
sub uses_sts { |
| |
my ($ignore_cache) = @_; |
| |
my $lonhost = $perlvar{'lonHostID'}; |
| |
my $hostname = &hostname($lonhost); |
| |
my $sts_on; |
| |
if ($protocol{$lonhost} eq 'https') { |
| |
my $cachetime = 12*3600; |
| |
if (!$ignore_cache) { |
| |
($sts_on,my $cached)=&is_cached_new('stspolicy',$lonhost); |
| |
if (defined($cached)) { |
| |
return $sts_on; |
| |
} |
| |
} |
| |
my $url = $protocol{$lonhost}.'://'.$hostname.'/index.html'; |
| |
my $request=new HTTP::Request('HEAD',$url); |
| |
my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,'','','',1); |
| |
if ($response->is_success) { |
| |
my $has_sts = $response->header('Strict-Transport-Security'); |
| |
if ($has_sts eq '') { |
| |
$sts_on = 0; |
| |
} else { |
| |
if ($has_sts =~ /\Qmax-age=\E(\d+)/) { |
| |
my $maxage = $1; |
| |
if ($maxage) { |
| |
$sts_on = 1; |
| |
} else { |
| |
$sts_on = 0; |
| |
} |
| |
} else { |
| |
$sts_on = 0; |
| |
} |
| |
} |
| |
return &do_cache_new('stspolicy',$lonhost,$sts_on,$cachetime); |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| |
sub waf_allssl { |
| |
my ($host_name) = @_; |
| |
my $alias = &get_proxy_alias(); |
| |
if ($host_name eq '') { |
| |
$host_name = $ENV{'SERVER_NAME'}; |
| |
} |
| |
if (($host_name ne '') && ($alias eq $host_name)) { |
| |
my $serverhomedom = &host_domain($perlvar{'lonHostID'}); |
| |
my %defdomdefaults = &get_domain_defaults($serverhomedom); |
| |
if ($defdomdefaults{'waf_sslopt'}) { |
| |
return $defdomdefaults{'waf_sslopt'}; |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| |
sub get_requestor_ip { |
| |
my ($r,$nolookup,$noproxy) = @_; |
| |
my $from_ip; |
| |
if (ref($r)) { |
| |
if ($r->can('useragent_ip')) { |
| |
if ($noproxy && $r->can('client_ip')) { |
| |
$from_ip = $r->client_ip(); |
| |
} else { |
| |
$from_ip = $r->useragent_ip(); |
| |
} |
| |
} elsif ($r->connection->can('remote_ip')) { |
| |
$from_ip = $r->connection->remote_ip(); |
| |
} else { |
| |
$from_ip = $r->get_remote_host($nolookup); |
| |
} |
| |
} else { |
| |
$from_ip = $ENV{'REMOTE_ADDR'}; |
| |
} |
| |
return $from_ip if ($noproxy); |
| |
# Who controls proxy settings for server |
| |
my $dom_in_use = $Apache::lonnet::perlvar{'lonDefDomain'}; |
| |
my $proxyinfo = &get_proxy_settings($dom_in_use); |
| |
if ((ref($proxyinfo) eq 'HASH') && ($from_ip)) { |
| |
if ($proxyinfo->{'vpnint'}) { |
| |
if (&ip_match($from_ip,$proxyinfo->{'vpnint'})) { |
| |
return $from_ip; |
| |
} |
| |
} |
| |
if ($proxyinfo->{'trusted'}) { |
| |
if (&ip_match($from_ip,$proxyinfo->{'trusted'})) { |
| |
my $ipheader = $proxyinfo->{'ipheader'}; |
| |
my ($ip,$xfor); |
| |
if (ref($r)) { |
| |
if ($ipheader) { |
| |
$ip = $r->headers_in->{$ipheader}; |
| |
} |
| |
$xfor = $r->headers_in->{'X-Forwarded-For'}; |
| |
} else { |
| |
if ($ipheader) { |
| |
$ip = $ENV{'HTTP_'.uc($ipheader)}; |
| |
} |
| |
$xfor = $ENV{'HTTP_X_FORWARDED_FOR'}; |
| |
} |
| |
if (($ip eq '') && ($xfor ne '')) { |
| |
foreach my $poss_ip (reverse(split(/\s*,\s*/,$xfor))) { |
| |
unless (&ip_match($poss_ip,$proxyinfo->{'trusted'})) { |
| |
$ip = $poss_ip; |
| |
last; |
| |
} |
| |
} |
| |
} |
| |
if ($ip ne '') { |
| |
return $ip; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
return $from_ip; |
| |
} |
| |
|
| |
sub get_proxy_settings { |
| |
my ($dom_in_use) = @_; |
| |
my %domdefaults = &Apache::lonnet::get_domain_defaults($dom_in_use); |
| |
my $proxyinfo = { |
| |
ipheader => $domdefaults{'waf_ipheader'}, |
| |
trusted => $domdefaults{'waf_trusted'}, |
| |
vpnint => $domdefaults{'waf_vpnint'}, |
| |
vpnext => $domdefaults{'waf_vpnext'}, |
| |
sslopt => $domdefaults{'waf_sslopt'}, |
| |
}; |
| |
return $proxyinfo; |
| |
} |
| |
|
| |
sub ip_match { |
| |
my ($ip,$pattern_str) = @_; |
| |
$ip=Net::CIDR::cidrvalidate($ip); |
| |
if ($ip) { |
| |
return Net::CIDR::cidrlookup($ip,split(/\s*,\s*/,$pattern_str)); |
| |
} |
| |
return; |
| |
} |
| |
|
| |
sub get_proxy_alias { |
| |
my ($lonid) = @_; |
| |
if ($lonid eq '') { |
| |
$lonid = $perlvar{'lonHostID'}; |
| |
} |
| |
if (!defined(&hostname($lonid))) { |
| |
return; |
| |
} |
| |
if ($lonid ne '') { |
| |
my ($alias,$cached) = &is_cached_new('proxyalias',$lonid); |
| |
if ($cached) { |
| |
return $alias; |
| |
} |
| |
my $dom = &Apache::lonnet::host_domain($lonid); |
| |
if ($dom ne '') { |
| |
my $cachetime = 60*60*24; |
| |
my %domconfig = |
| |
&Apache::lonnet::get_dom('configuration',['wafproxy'],$dom); |
| |
my $alias; |
| |
if (ref($domconfig{'wafproxy'}) eq 'HASH') { |
| |
if (ref($domconfig{'wafproxy'}{'alias'}) eq 'HASH') { |
| |
$alias = $domconfig{'wafproxy'}{'alias'}{$lonid}; |
| |
} |
| |
} |
| |
return &do_cache_new('proxyalias',$lonid,$alias,$cachetime); |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| |
sub use_proxy_alias { |
| |
my ($r,$lonid) = @_; |
| |
my $alias = &get_proxy_alias($lonid); |
| |
if ($alias) { |
| |
my $dom = &host_domain($lonid); |
| |
if ($dom ne '') { |
| |
my $proxyinfo = &get_proxy_settings($dom ); |
| |
my ($vpnint,$remote_ip); |
| |
if (ref($proxyinfo) eq 'HASH') { |
| |
$vpnint = $proxyinfo->{'vpnint'}; |
| |
if ($vpnint) { |
| |
$remote_ip = &get_requestor_ip($r,1,1); |
| |
} |
| |
} |
| |
unless ($vpnint && &ip_match($remote_ip,$vpnint)) { |
| |
return $alias; |
| |
} |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| # ------------------------------------------------------------- Declutters URLs |
# ------------------------------------------------------------- Declutters URLs |
| |
|
| sub declutter { |
sub declutter { |
| my $thisfn=shift; |
my $thisfn=shift; |
| if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); } |
if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); } |
| $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//; |
unless ($thisfn=~m{^/home/httpd/html/priv/}) { |
| |
$thisfn=~s{^/home/httpd/html}{}; |
| |
} |
| $thisfn=~s/^\///; |
$thisfn=~s/^\///; |
| $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/\?.+$//; |
$thisfn=~s/^priv\///; |
| |
unless (($thisfn =~ /^ext/) || ($thisfn =~ /\.(page|sequence)___\d+___ext/)) { |
| |
$thisfn=~s/\?.+$//; |
| |
} |
| return $thisfn; |
return $thisfn; |
| } |
} |
| |
|
|
Line 7444 sub declutter {
|
Line 14531 sub declutter {
|
| |
|
| sub clutter { |
sub clutter { |
| my $thisfn='/'.&declutter(shift); |
my $thisfn='/'.&declutter(shift); |
| unless ($thisfn=~/^\/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)\//) { |
if ($thisfn !~ m{^/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)/} |
| |
|| $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 7470 sub clutter {
|
Line 14558 sub clutter {
|
| # &logthis("Got a blank emb style"); |
# &logthis("Got a blank emb style"); |
| } |
} |
| } |
} |
| |
} elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/ext\.tool$}) { |
| |
$thisfn='/adm/wrapper'.$thisfn; |
| } |
} |
| return $thisfn; |
return $thisfn; |
| } |
} |
|
Line 7513 sub correct_line_ends {
|
Line 14603 sub correct_line_ends {
|
| sub goodbye { |
sub goodbye { |
| &logthis("Starting Shut down"); |
&logthis("Starting Shut down"); |
| #not converted to using infrastruture and probably shouldn't be |
#not converted to using infrastruture and probably shouldn't be |
| &logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%badServerCache)))); |
&logthis(sprintf("%-20s is %s",'%badServerCache',length(&nfreeze(\%badServerCache)))); |
| #converted |
#converted |
| # &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); |
# &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); |
| &logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache)))); |
&logthis(sprintf("%-20s is %s",'%homecache',length(&nfreeze(\%homecache)))); |
| # &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache)))); |
# &logthis(sprintf("%-20s is %s",'%titlecache',length(&nfreeze(\%titlecache)))); |
| # &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache)))); |
# &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&nfreeze(\%courseresdatacache)))); |
| #1.1 only |
#1.1 only |
| # &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache)))); |
# &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&nfreeze(\%userresdatacache)))); |
| # &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache)))); |
# &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&nfreeze(\%getsectioncache)))); |
| # &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache)))); |
# &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&nfreeze(\%courseresversioncache)))); |
| # &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%resversioncache)))); |
# &logthis(sprintf("%-20s is %s",'%resversioncache',length(&nfreeze(\%resversioncache)))); |
| &logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered)))); |
&logthis(sprintf("%-20s is %s",'%remembered',length(&nfreeze(\%remembered)))); |
| &logthis(sprintf("%-20s is %s",'kicks',$kicks)); |
&logthis(sprintf("%-20s is %s",'kicks',$kicks)); |
| &logthis(sprintf("%-20s is %s",'hits',$hits)); |
&logthis(sprintf("%-20s is %s",'hits',$hits)); |
| &flushcourselogs(); |
&flushcourselogs(); |
| &logthis("Shutting down"); |
&logthis("Shutting down"); |
| } |
} |
| |
|
| BEGIN { |
sub get_dns { |
| # ----------------------------------- Read loncapa.conf and loncapa_apache.conf |
my ($url,$func,$ignore_cache,$nocache,$hashref) = @_; |
| unless ($readit) { |
if (!$ignore_cache) { |
| { |
my ($content,$cached)= |
| my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf'); |
&Apache::lonnet::is_cached_new('dns',$url); |
| %perlvar = (%perlvar,%{$configvars}); |
if ($cached) { |
| |
&$func($content,$hashref); |
| |
return; |
| |
} |
| |
} |
| |
|
| |
my %alldns; |
| |
if (open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab")) { |
| |
foreach my $dns (<$config>) { |
| |
next if ($dns !~ /^\^(\S*)/x); |
| |
my $line = $1; |
| |
my ($host,$protocol) = split(/:/,$line); |
| |
if ($protocol ne 'https') { |
| |
$protocol = 'http'; |
| |
} |
| |
$alldns{$host} = $protocol; |
| |
} |
| |
close($config); |
| |
} |
| |
while (%alldns) { |
| |
my ($dns) = sort { $b cmp $a } keys(%alldns); |
| |
my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url"); |
| |
my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0); |
| |
delete($alldns{$dns}); |
| |
next if ($response->is_error()); |
| |
if ($url eq '/adm/dns/loncapaCRL') { |
| |
return &$func($response); |
| |
} else { |
| |
my @content = split("\n",$response->content); |
| |
unless ($nocache) { |
| |
&do_cache_new('dns',$url,\@content,30*24*60*60); |
| |
} |
| |
&$func(\@content,$hashref); |
| |
return; |
| |
} |
| |
} |
| |
my $which = (split('/',$url,4))[3]; |
| |
if ($which eq 'loncapaCRL') { |
| |
my $diskfile = "$perlvar{'lonCertificateDirectory'}/$perlvar{'lonnetCertRevocationList'}"; |
| |
if (-e $diskfile) { |
| |
&logthis("unable to contact DNS, on disk file $diskfile not updated"); |
| |
} else { |
| |
&logthis("unable to contact DNS, no on disk file $diskfile available"); |
| |
} |
| |
} else { |
| |
&logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n"); |
| |
if (open(my $config,"<","$perlvar{'lonTabDir'}/dns_$which.tab")) { |
| |
my @content = <$config>; |
| |
close($config); |
| |
&$func(\@content,$hashref); |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| |
# ------------------------------------------------------Get DNS checksums file |
| |
sub parse_dns_checksums_tab { |
| |
my ($lines,$hashref) = @_; |
| |
my $lonhost = $perlvar{'lonHostID'}; |
| |
my $machine_dom = &Apache::lonnet::host_domain($lonhost); |
| |
my $loncaparev = &get_server_loncaparev($machine_dom); |
| |
my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0]; |
| |
my $webconfdir = '/etc/httpd/conf'; |
| |
if ($distro =~ /^(ubuntu|debian)(\d+)$/) { |
| |
$webconfdir = '/etc/apache2'; |
| |
} elsif ($distro =~ /^sles(\d+)$/) { |
| |
if ($1 >= 10) { |
| |
$webconfdir = '/etc/apache2'; |
| |
} |
| |
} elsif ($distro =~ /^suse(\d+\.\d+)$/) { |
| |
if ($1 >= 10.0) { |
| |
$webconfdir = '/etc/apache2'; |
| |
} |
| |
} |
| |
my ($release,$timestamp) = split(/\-/,$loncaparev); |
| |
my (%chksum,%revnum); |
| |
if (ref($lines) eq 'ARRAY') { |
| |
chomp(@{$lines}); |
| |
my $version = shift(@{$lines}); |
| |
if ($version eq $release) { |
| |
foreach my $line (@{$lines}) { |
| |
my ($file,$version,$shasum) = split(/,/,$line); |
| |
if ($file =~ m{^/etc/httpd/conf}) { |
| |
if ($webconfdir eq '/etc/apache2') { |
| |
$file =~ s{^\Q/etc/httpd/conf/\E}{$webconfdir/}; |
| |
} |
| |
} |
| |
$chksum{$file} = $shasum; |
| |
$revnum{$file} = $version; |
| |
} |
| |
if (ref($hashref) eq 'HASH') { |
| |
%{$hashref} = ( |
| |
sums => \%chksum, |
| |
versions => \%revnum, |
| |
); |
| |
} |
| |
} |
| |
} |
| |
return; |
| |
} |
| |
|
| |
sub fetch_dns_checksums { |
| |
my %checksums; |
| |
my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'}); |
| |
my $loncaparev = &get_server_loncaparev($machine_dom,$perlvar{'lonHostID'}); |
| |
my ($release,$timestamp) = split(/\-/,$loncaparev); |
| |
&get_dns("/adm/dns/checksums/$release",\&parse_dns_checksums_tab,1,1, |
| |
\%checksums); |
| |
return \%checksums; |
| |
} |
| |
|
| |
sub fetch_crl_pemfile { |
| |
return &get_dns("/adm/dns/loncapaCRL",\&save_crl_pem,1,1); |
| |
} |
| |
|
| |
sub save_crl_pem { |
| |
my ($response) = @_; |
| |
my ($msg,$hadchanges); |
| |
if (ref($response)) { |
| |
my $now = time; |
| |
my $lonca = $perlvar{'lonCertificateDirectory'}.'/'.$perlvar{'lonnetCertificateAuthority'}; |
| |
my $tmpcrl = $tmpdir.'/'.$perlvar{'lonnetCertRevocationList'}.'_'.$now.'.'.$$.'.tmp'; |
| |
if (open(my $fh,'>',"$tmpcrl")) { |
| |
print $fh $response->content; |
| |
close($fh); |
| |
if (-e $lonca) { |
| |
if (open(PIPE,"openssl crl -in $tmpcrl -inform pem -CAfile $lonca -noout 2>&1 |")) { |
| |
my $check = <PIPE>; |
| |
close(PIPE); |
| |
chomp($check); |
| |
if ($check eq 'verify OK') { |
| |
my $dest = "$perlvar{'lonCertificateDirectory'}/$perlvar{'lonnetCertRevocationList'}"; |
| |
my $backup; |
| |
if (-e $dest) { |
| |
if (&File::Copy::move($dest,"$dest.bak")) { |
| |
$backup = 'ok'; |
| |
} |
| |
} |
| |
if (&File::Copy::move($tmpcrl,$dest)) { |
| |
$msg = 'ok'; |
| |
if ($backup) { |
| |
my (%oldnums,%newnums); |
| |
if (open(PIPE, "openssl crl -inform PEM -text -noout -in $dest.bak |grep 'Serial Number' |")) { |
| |
while (<PIPE>) { |
| |
$oldnums{(split(/:/))[1]} = 1; |
| |
} |
| |
close(PIPE); |
| |
} |
| |
if (open(PIPE, "openssl crl -inform PEM -text -noout -in $dest |grep 'Serial Number' |")) { |
| |
while(<PIPE>) { |
| |
$newnums{(split(/:/))[1]} = 1; |
| |
} |
| |
close(PIPE); |
| |
} |
| |
foreach my $key (sort {$b <=> $a } (keys(%newnums))) { |
| |
unless (exists($oldnums{$key})) { |
| |
$hadchanges = 1; |
| |
last; |
| |
} |
| |
} |
| |
unless ($hadchanges) { |
| |
foreach my $key (sort {$b <=> $a } (keys(%oldnums))) { |
| |
unless (exists($newnums{$key})) { |
| |
$hadchanges = 1; |
| |
last; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} else { |
| |
unlink($tmpcrl); |
| |
} |
| |
} else { |
| |
unlink($tmpcrl); |
| |
} |
| |
} else { |
| |
unlink($tmpcrl); |
| |
} |
| |
} |
| |
} |
| |
return ($msg,$hadchanges); |
| } |
} |
| |
|
| # ------------------------------------------------------------ Read domain file |
# ------------------------------------------------------------ Read domain file |
| { |
{ |
| %domaindescription = (); |
my $loaded; |
| %domain_auth_def = (); |
my %domain; |
| %domain_auth_arg_def = (); |
|
| my $fh; |
sub parse_domain_tab { |
| if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) { |
my ($lines) = @_; |
| while (my $line = <$fh>) { |
foreach my $line (@$lines) { |
| next if ($line =~ /^(\#|\s*$)/); |
next if ($line =~ /^(\#|\s*$ )/x); |
| # next if /^\#/; |
|
| chomp $line; |
chomp($line); |
| my ($domain, $domain_description, $def_auth, $def_auth_arg, |
my ($name,@elements) = split(/:/,$line,9); |
| $def_lang, $city, $longi, $lati, $primary) = split(/:/,$line,9); |
my %this_domain; |
| $domain_auth_def{$domain}=$def_auth; |
foreach my $field ('description', 'auth_def', 'auth_arg_def', |
| $domain_auth_arg_def{$domain}=$def_auth_arg; |
'lang_def', 'city', 'longi', 'lati', |
| $domaindescription{$domain}=$domain_description; |
'primary') { |
| $domain_lang_def{$domain}=$def_lang; |
$this_domain{$field} = shift(@elements); |
| $domain_city{$domain}=$city; |
} |
| $domain_longi{$domain}=$longi; |
$domain{$name} = \%this_domain; |
| $domain_lati{$domain}=$lati; |
} |
| $domain_primary{$domain}=$primary; |
} |
| |
|
| # &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}"); |
sub reset_domain_info { |
| # &logthis("Domain.tab: $domain ".$domaindescription{$domain} ); |
undef($loaded); |
| |
undef(%domain); |
| |
} |
| |
|
| |
sub load_domain_tab { |
| |
my ($ignore_cache,$nocache) = @_; |
| |
&get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache,$nocache); |
| |
my $fh; |
| |
if (open($fh,"<",$perlvar{'lonTabDir'}.'/domain.tab')) { |
| |
my @lines = <$fh>; |
| |
&parse_domain_tab(\@lines); |
| } |
} |
| |
close($fh); |
| |
$loaded = 1; |
| } |
} |
| close ($fh); |
|
| |
sub domain { |
| |
&load_domain_tab() if (!$loaded); |
| |
|
| |
my ($name,$what) = @_; |
| |
return if ( !exists($domain{$name}) ); |
| |
|
| |
if (!$what) { |
| |
return $domain{$name}{'description'}; |
| |
} |
| |
return $domain{$name}{$what}; |
| |
} |
| |
|
| |
sub domain_info { |
| |
&load_domain_tab() if (!$loaded); |
| |
return %domain; |
| |
} |
| |
|
| } |
} |
| |
|
| |
|
| # ------------------------------------------------------------- Read hosts file |
# ------------------------------------------------------------- Read hosts file |
| { |
{ |
| open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); |
my %hostname; |
| |
my %hostdom; |
| |
my %libserv; |
| |
my $loaded; |
| |
my %name_to_host; |
| |
my %internetdom; |
| |
my %LC_dns_serv; |
| |
|
| |
sub parse_hosts_tab { |
| |
my ($file) = @_; |
| |
foreach my $configline (@$file) { |
| |
next if ($configline =~ /^(\#|\s*$ )/x); |
| |
chomp($configline); |
| |
if ($configline =~ /^\^/) { |
| |
if ($configline =~ /^\^([\w.\-]+)/) { |
| |
$LC_dns_serv{$1} = 1; |
| |
} |
| |
next; |
| |
} |
| |
my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline); |
| |
$name=~s/\s//g; |
| |
if ($id && $domain && $role && $name) { |
| |
if ((exists($hostname{$id})) && ($hostname{$id} ne '')) { |
| |
my $curr = $hostname{$id}; |
| |
my $skip; |
| |
if (ref($name_to_host{$curr}) eq 'ARRAY') { |
| |
if (($curr eq $name) && (@{$name_to_host{$curr}} == 1)) { |
| |
$skip = 1; |
| |
} else { |
| |
@{$name_to_host{$curr}} = grep { $_ ne $id } @{$name_to_host{$curr}}; |
| |
} |
| |
} |
| |
unless ($skip) { |
| |
push(@{$name_to_host{$name}},$id); |
| |
} |
| |
} else { |
| |
push(@{$name_to_host{$name}},$id); |
| |
} |
| |
$hostname{$id}=$name; |
| |
$hostdom{$id}=$domain; |
| |
if ($role eq 'library') { $libserv{$id}=$name; } |
| |
if (defined($protocol)) { |
| |
if ($protocol eq 'https') { |
| |
$protocol{$id} = $protocol; |
| |
} else { |
| |
$protocol{$id} = 'http'; |
| |
} |
| |
} else { |
| |
$protocol{$id} = 'http'; |
| |
} |
| |
if (defined($intdom)) { |
| |
$internetdom{$id} = $intdom; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
|
| |
sub reset_hosts_info { |
| |
&purge_remembered(); |
| |
&reset_domain_info(); |
| |
&reset_hosts_ip_info(); |
| |
undef(%internetdom); |
| |
undef(%name_to_host); |
| |
undef(%hostname); |
| |
undef(%hostdom); |
| |
undef(%libserv); |
| |
undef($loaded); |
| |
} |
| |
|
| while (my $configline=<$config>) { |
sub load_hosts_tab { |
| next if ($configline =~ /^(\#|\s*$)/); |
my ($ignore_cache,$nocache) = @_; |
| chomp($configline); |
&get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache,$nocache); |
| my ($id,$domain,$role,$name)=split(/:/,$configline); |
open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab"); |
| $name=~s/\s//g; |
my @config = <$config>; |
| if ($id && $domain && $role && $name) { |
&parse_hosts_tab(\@config); |
| $hostname{$id}=$name; |
close($config); |
| $hostdom{$id}=$domain; |
$loaded=1; |
| if ($role eq 'library') { $libserv{$id}=$name; } |
|
| } |
|
| } |
} |
| close($config); |
|
| # FIXME: dev server don't want this, production servers _do_ want this |
sub hostname { |
| #&get_iphost(); |
&load_hosts_tab() if (!$loaded); |
| |
|
| |
my ($lonid) = @_; |
| |
return $hostname{$lonid}; |
| |
} |
| |
|
| |
sub all_hostnames { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| |
return %hostname; |
| |
} |
| |
|
| |
sub all_names { |
| |
my ($ignore_cache,$nocache) = @_; |
| |
&load_hosts_tab($ignore_cache,$nocache) if (!$loaded); |
| |
|
| |
return %name_to_host; |
| |
} |
| |
|
| |
sub all_host_domain { |
| |
&load_hosts_tab() if (!$loaded); |
| |
return %hostdom; |
| |
} |
| |
|
| |
sub all_host_intdom { |
| |
&load_hosts_tab() if (!$loaded); |
| |
return %internetdom; |
| |
} |
| |
|
| |
sub is_library { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| |
return exists($libserv{$_[0]}); |
| |
} |
| |
|
| |
sub all_library { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| |
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 { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| |
my ($domain,$type) = @_; |
| |
my %possible_hosts = ($type eq 'library') ? %libserv |
| |
: %hostname; |
| |
my %result; |
| |
if (ref($domain) eq 'ARRAY') { |
| |
while ( my ($host,$hostname) = each(%possible_hosts)) { |
| |
if (grep(/^\Q$hostdom{$host}\E$/,@$domain)) { |
| |
$result{$host} = $hostname; |
| |
} |
| |
} |
| |
} else { |
| |
while ( my ($host,$hostname) = each(%possible_hosts)) { |
| |
if ($hostdom{$host} eq $domain) { |
| |
$result{$host} = $hostname; |
| |
} |
| |
} |
| |
} |
| |
return %result; |
| |
} |
| |
|
| |
sub get_unique_servers { |
| |
my %unique = reverse &get_servers(@_); |
| |
return reverse %unique; |
| |
} |
| |
|
| |
sub host_domain { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| |
my ($lonid) = @_; |
| |
return $hostdom{$lonid}; |
| |
} |
| |
|
| |
sub all_domains { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| |
my %seen; |
| |
my @uniq = grep(!$seen{$_}++, values(%hostdom)); |
| |
return @uniq; |
| |
} |
| |
|
| |
sub internet_dom { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| |
my ($lonid) = @_; |
| |
return $internetdom{$lonid}; |
| |
} |
| |
|
| |
sub is_LC_dns { |
| |
&load_hosts_tab() if (!$loaded); |
| |
|
| |
my ($hostname) = @_; |
| |
return exists($LC_dns_serv{$hostname}); |
| |
} |
| |
|
| } |
} |
| |
|
| sub get_iphost { |
{ |
| if (%iphost) { return %iphost; } |
my %iphost; |
| my %name_to_ip; |
my %name_to_ip; |
| foreach my $id (keys(%hostname)) { |
my %lonid_to_ip; |
| my $name=$hostname{$id}; |
|
| my $ip; |
sub get_hosts_from_ip { |
| if (!exists($name_to_ip{$name})) { |
my ($ip) = @_; |
| $ip = gethostbyname($name); |
my %iphosts = &get_iphost(); |
| if (!$ip || length($ip) ne 4) { |
if (ref($iphosts{$ip})) { |
| &logthis("Skipping host $id name $name no IP found"); |
return @{$iphosts{$ip}}; |
| next; |
} |
| |
return; |
| |
} |
| |
|
| |
sub reset_hosts_ip_info { |
| |
undef(%iphost); |
| |
undef(%name_to_ip); |
| |
undef(%lonid_to_ip); |
| |
} |
| |
|
| |
sub get_host_ip { |
| |
my ($lonid) = @_; |
| |
if (exists($lonid_to_ip{$lonid})) { |
| |
return $lonid_to_ip{$lonid}; |
| |
} |
| |
my $name=&hostname($lonid); |
| |
my $ip = gethostbyname($name); |
| |
return if (!$ip || length($ip) ne 4); |
| |
$ip=inet_ntoa($ip); |
| |
$name_to_ip{$name} = $ip; |
| |
$lonid_to_ip{$lonid} = $ip; |
| |
return $ip; |
| |
} |
| |
|
| |
sub get_iphost { |
| |
my ($ignore_cache,$nocache) = @_; |
| |
|
| |
if (!$ignore_cache) { |
| |
if (%iphost) { |
| |
return %iphost; |
| } |
} |
| $ip=inet_ntoa($ip); |
my ($ip_info,$cached)= |
| $name_to_ip{$name} = $ip; |
&Apache::lonnet::is_cached_new('iphost','iphost'); |
| } else { |
if ($cached) { |
| $ip = $name_to_ip{$name}; |
%iphost = %{$ip_info->[0]}; |
| |
%name_to_ip = %{$ip_info->[1]}; |
| |
%lonid_to_ip = %{$ip_info->[2]}; |
| |
return %iphost; |
| |
} |
| |
} |
| |
|
| |
# get yesterday's info for fallback |
| |
my %old_name_to_ip; |
| |
my ($ip_info,$cached)= |
| |
&Apache::lonnet::is_cached_new('iphost','iphost'); |
| |
if ($cached) { |
| |
%old_name_to_ip = %{$ip_info->[1]}; |
| |
} |
| |
|
| |
my %name_to_host = &all_names($ignore_cache,$nocache); |
| |
foreach my $name (keys(%name_to_host)) { |
| |
my $ip; |
| |
if (!exists($name_to_ip{$name})) { |
| |
$ip = gethostbyname($name); |
| |
if (!$ip || length($ip) ne 4) { |
| |
if (defined($old_name_to_ip{$name})) { |
| |
$ip = $old_name_to_ip{$name}; |
| |
&logthis("Can't find $name defaulting to old $ip"); |
| |
} else { |
| |
&logthis("Name $name no IP found"); |
| |
next; |
| |
} |
| |
} else { |
| |
$ip=inet_ntoa($ip); |
| |
} |
| |
$name_to_ip{$name} = $ip; |
| |
} else { |
| |
$ip = $name_to_ip{$name}; |
| |
} |
| |
foreach my $id (@{ $name_to_host{$name} }) { |
| |
$lonid_to_ip{$id} = $ip; |
| |
} |
| |
push(@{$iphost{$ip}},@{$name_to_host{$name}}); |
| } |
} |
| push(@{$iphost{$ip}},$id); |
unless ($nocache) { |
| |
&do_cache_new('iphost','iphost', |
| |
[\%iphost,\%name_to_ip,\%lonid_to_ip], |
| |
48*60*60); |
| |
} |
| |
|
| |
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 &do_cache_new('internetnames',$lonid,\@idns,12*60*60); |
| } |
} |
| return %iphost; |
|
| |
} |
| |
|
| |
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 2.11); |
| } |
} |
| |
|
| |
# ---------------------------------------------------------- Read loncaparev table |
| |
{ |
| |
sub load_loncaparevs { |
| |
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 |
| |
{ |
| |
sub load_serverhomeIDs { |
| |
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); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
|
| |
|
| |
BEGIN { |
| |
|
| |
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf |
| |
unless ($readit) { |
| |
{ |
| |
my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf'); |
| |
%perlvar = (%perlvar,%{$configvars}); |
| |
} |
| |
|
| |
|
| # ------------------------------------------------------ Read spare server file |
# ------------------------------------------------------ Read spare server file |
| { |
{ |
| open(my $config,"<$perlvar{'lonTabDir'}/spare.tab"); |
open(my $config,"<","$perlvar{'lonTabDir'}/spare.tab"); |
| |
|
| while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
| chomp($configline); |
chomp($configline); |
|
Line 7627 sub get_iphost {
|
Line 15269 sub get_iphost {
|
| } |
} |
| # ------------------------------------------------------------ Read permissions |
# ------------------------------------------------------------ Read permissions |
| { |
{ |
| open(my $config,"<$perlvar{'lonTabDir'}/roles.tab"); |
open(my $config,"<","$perlvar{'lonTabDir'}/roles.tab"); |
| |
|
| while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
| chomp($configline); |
chomp($configline); |
|
Line 7641 sub get_iphost {
|
Line 15283 sub get_iphost {
|
| |
|
| # -------------------------------------------- Read plain texts for permissions |
# -------------------------------------------- Read plain texts for permissions |
| { |
{ |
| open(my $config,"<$perlvar{'lonTabDir'}/rolesplain.tab"); |
open(my $config,"<","$perlvar{'lonTabDir'}/rolesplain.tab"); |
| |
|
| while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
| chomp($configline); |
chomp($configline); |
|
Line 7661 sub get_iphost {
|
Line 15303 sub get_iphost {
|
| |
|
| # ---------------------------------------------------------- Read package table |
# ---------------------------------------------------------- Read package table |
| { |
{ |
| open(my $config,"<$perlvar{'lonTabDir'}/packages.tab"); |
open(my $config,"<","$perlvar{'lonTabDir'}/packages.tab"); |
| |
|
| while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
| if ($configline !~ /\S/ || $configline=~/^#/) { next; } |
if ($configline !~ /\S/ || $configline=~/^#/) { next; } |
|
Line 7676 sub get_iphost {
|
Line 15318 sub get_iphost {
|
| close($config); |
close($config); |
| } |
} |
| |
|
| |
# ---------------------------------------------------------- Read loncaparev table |
| |
|
| |
&load_loncaparevs(); |
| |
|
| |
# ---------------------------------------------------------- Read serverhostID table |
| |
|
| |
&load_serverhomeIDs(); |
| |
|
| |
# ---------------------------------------------------------- Read releaseslist XML |
| |
{ |
| |
my $file = $Apache::lonnet::perlvar{'lonTabDir'}.'/releaseslist.xml'; |
| |
if (-e $file) { |
| |
my $parser = HTML::LCParser->new($file); |
| |
while (my $token = $parser->get_token()) { |
| |
if ($token->[0] eq 'S') { |
| |
my $item = $token->[1]; |
| |
my $name = $token->[2]{'name'}; |
| |
my $value = $token->[2]{'value'}; |
| |
my $valuematch = $token->[2]{'valuematch'}; |
| |
my $namematch = $token->[2]{'namematch'}; |
| |
if ($item eq 'parameter') { |
| |
if (($namematch ne '') || (($name ne '') && ($value ne '' || $valuematch ne ''))) { |
| |
my $release = $parser->get_text(); |
| |
$release =~ s/(^\s*|\s*$ )//gx; |
| |
$needsrelease{$item.':'.$name.':'.$value.':'.$valuematch.':'.$namematch} = $release; |
| |
} |
| |
} elsif ($item ne '' && $name ne '') { |
| |
my $release = $parser->get_text(); |
| |
$release =~ s/(^\s*|\s*$ )//gx; |
| |
$needsrelease{$item.':'.$name.':'.$value} = $release; |
| |
} |
| |
} |
| |
} |
| |
} |
| |
} |
| |
|
| |
# ---------------------------------------------------------- Read managers table |
| |
{ |
| |
if (-e "$perlvar{'lonTabDir'}/managers.tab") { |
| |
if (open(my $config,"<","$perlvar{'lonTabDir'}/managers.tab")) { |
| |
while (my $configline=<$config>) { |
| |
chomp($configline); |
| |
next if ($configline =~ /^\#/); |
| |
if (($configline =~ /^[\w\-]+$/) || ($configline =~ /^[\w\-]+\:[\w\-]+$/)) { |
| |
$managerstab{$configline} = 1; |
| |
} |
| |
} |
| |
close($config); |
| |
} |
| |
} |
| |
} |
| |
|
| # ------------- set up temporary directory |
# ------------- set up temporary directory |
| { |
{ |
| $tmpdir = $perlvar{'lonDaemons'}.'/tmp/'; |
$tmpdir = LONCAPA::tempdir(); |
| |
|
| } |
} |
| |
|
| |
# ------------- set default texengine (domain default overrides this) |
| |
{ |
| |
$deftex = LONCAPA::texengine(); |
| |
} |
| |
|
| |
# ------------- set default minimum length for passwords for internal auth users |
| |
{ |
| |
$passwdmin = LONCAPA::passwd_min(); |
| |
} |
| |
|
| $memcache=new Cache::Memcached({'servers' => ['127.0.0.1:11211'], |
$memcache=new Cache::Memcached({'servers' => ['127.0.0.1:11211'], |
| 'compress_threshold'=> 20_000, |
'compress_threshold'=> 20_000, |
| }); |
}); |
| |
|
| $processmarker='_'.time.'_'.$perlvar{'lonHostID'}; |
$processmarker='_'.time.'_'.$perlvar{'lonHostID'}; |
| $dumpcount=0; |
$dumpcount=0; |
| |
$locknum=0; |
| |
|
| &logtouch(); |
&logtouch(); |
| &logthis('<font color="yellow">INFO: Read configuration</font>'); |
&logthis('<font color="yellow">INFO: Read configuration</font>'); |
|
Line 7838 were new keys. I.E. 1:foo will become 1:
|
Line 15543 were new keys. I.E. 1:foo will become 1:
|
| |
|
| Calling convention: |
Calling convention: |
| |
|
| my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname,$home); |
my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname); |
| &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$home); |
&Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$laststore); |
| |
|
| For more detailed information, see lonnet specific documentation. |
For more detailed information, see lonnet specific documentation. |
| |
|
|
Line 7855 when the connection is brought back up
|
Line 15560 when the connection is brought back up
|
| =item * B<con_failed>: unable to contact remote host and unable to save message |
=item * B<con_failed>: unable to contact remote host and unable to save message |
| for later delivery |
for later delivery |
| |
|
| =item * B<error:>: an error a occured, a description of the error follows the : |
=item * B<error:>: an error a occurred, a description of the error follows the : |
| |
|
| =item * B<no_such_host>: unable to fund a host associated with the user/domain |
=item * B<no_such_host>: unable to fund a host associated with the user/domain |
| that was requested |
that was requested |
|
Line 7870 that was requested
|
Line 15575 that was requested
|
| |
|
| =item * |
=item * |
| X<appenv()> |
X<appenv()> |
| B<appenv(%hash)>: the value of %hash is written to |
B<appenv($hashref,$rolesarrayref)>: the value of %{$hashref} is written to |
| the user envirnoment file, and will be restored for each access this |
the user envirnoment file, and will be restored for each access this |
| user makes during this session, also modifies the %env for the current |
user makes during this session, also modifies the %env for the current |
| process |
process. Optional rolesarrayref - if defined contains a reference to an array |
| |
of roles which are exempt from the restriction on modifying user.role entries |
| |
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 7901 authentication scheme
|
Line 15610 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 7913 the answer, and also caches if there is
|
Line 15627 the answer, and also caches if there is
|
| |
|
| =item * |
=item * |
| X<idget()> |
X<idget()> |
| B<idget($udom,@ids)>: find the usernames behind a list of IDs |
B<idget($udom,$idsref,$namespace)>: find the usernames behind either |
| (IDs are a unique resource in a domain, there must be only 1 ID per |
a list of student/employee IDs or clicker IDs |
| username, and only 1 username per ID in a specific domain) (returns |
(student/employee IDs are a unique resource in a domain, there must be |
| hash: id=>name,id=>name) |
only 1 ID per username, and only 1 username per ID in a specific domain). |
| |
clickerIDs are not necessarily unique, as students might share clickers. |
| |
(returns hash: id=>name,id=>name) |
| |
|
| =item * |
=item * |
| X<idrget()> |
X<idrget()> |
|
Line 7925 usernames (returns hash: name=>id,name=>
|
Line 15641 usernames (returns hash: name=>id,name=>
|
| |
|
| =item * |
=item * |
| X<idput()> |
X<idput()> |
| B<idput($udom,%ids)>: store away a list of names and associated IDs |
B<idput($udom,$idsref,$uhome,$namespace)>: store away a list of |
| |
names and associated student/employee IDs or clicker IDs. |
| |
|
| |
=item * |
| |
X<iddel()> |
| |
B<iddel($udom,$idshashref,$uhome,$namespace)>: delete unwanted |
| |
student/employee ID or clicker ID username look-ups from domain. |
| |
The homeserver ($uhome) and namespace ($namespace) are optional. |
| |
If no $uhome is provided, it will be determined usig &homeserver() |
| |
for each user. If no $namespace is provided, the default is ids. |
| |
|
| |
=item * |
| |
X<updateclickers()> |
| |
B<updateclickers($udom,$action,$idshashref,$uhome,$critical)>: update |
| |
clicker ID-to-username look-ups in clickers.db on library server. |
| |
Permitted actions are add or del (i.e., add or delete). The |
| |
clickers.db contains clickerID as keys (escaped), and each corresponding |
| |
value is an escaped comma-separated list of usernames (for whom the |
| |
library server is the homeserver), who registered that particular ID. |
| |
If $critical is true, the update will be sent via &critical, otherwise |
| |
&reply() will be used. |
| |
|
| =item * |
=item * |
| X<rolesinit()> |
X<rolesinit()> |
| B<rolesinit($udom,$username,$authhost)>: get user privileges |
B<rolesinit($udom,$username)>: get user privileges. |
| |
returns user role, first access and timer interval hashes |
| |
|
| |
=item * |
| |
X<privileged()> |
| |
B<privileged($username,$domain)>: returns a true if user has a |
| |
privileged and active role (i.e. su or dc), false otherwise. |
| |
|
| =item * |
=item * |
| X<getsection()> |
X<getsection()> |
|
Line 7942 X<userenvironment()>
|
Line 15684 X<userenvironment()>
|
| B<userenvironment($udom,$uname,@what)>: gets the values of the keys |
B<userenvironment($udom,$uname,@what)>: gets the values of the keys |
| passed in @what from the requested user's environment, returns a hash |
passed in @what from the requested user's environment, returns a hash |
| |
|
| |
=item * |
| |
X<userlog_query()> |
| |
B<userlog_query($uname,$udom,%filters)>: retrieves data from a user's |
| |
activity.log file. %filters defines filters applied when parsing the |
| |
log file. These can be start or end timestamps, or the type of action |
| |
- log to look for Login or Logout events, check for Checkin or |
| |
Checkout, role for role selection. The response is in the form |
| |
timestamp1:hostid1:event1×tamp2:hostid2:event2 where events are |
| |
escaped strings of the action recorded in the activity.log file. |
| |
|
| =back |
=back |
| |
|
| =head2 User Roles |
=head2 User Roles |
|
Line 7950 passed in @what from the requested user'
|
Line 15702 passed in @what from the requested user'
|
| |
|
| =item * |
=item * |
| |
|
| allowed($priv,$uri,$symb,$role) : check for a user privilege; returns codes for allowed actions |
allowed($priv,$uri,$symb,$role,$clientip,$noblockcheck) : check for a user privilege; |
| |
returns codes for allowed actions. |
| |
|
| |
The first argument is required, all others are optional. |
| |
|
| |
$priv is the privilege being checked. |
| |
$uri contains additional information about what is being checked for access (e.g., |
| |
URL, course ID etc.). |
| |
$symb is the unique resource instance identifier in a course; if needed, |
| |
but not provided, it will be retrieved via a call to &symbread(). |
| |
$role is the role for which a priv is being checked (only used if priv is evb). |
| |
$clientip is the user's IP address (only used when checking for access to portfolio |
| |
files). |
| |
$noblockcheck, if true, skips calls to &has_comm_blocking() for the bre priv. This |
| |
prevents recursive calls to &allowed. |
| |
|
| F: full access |
F: full access |
| U,I,K: authentication modes (cxx only) |
U,I,K: authentication modes (cxx only) |
| '': forbidden |
'': forbidden |
| 1: user needs to choose course |
1: user needs to choose course |
| 2: browse allowed |
2: browse allowed |
| A: passphrase authentication needed |
A: passphrase authentication needed |
| |
B: access temporarily blocked because of a blocking event in a course. |
| |
D: access blocked because access is required via session initiated via deep-link |
| |
|
| |
=item * |
| |
|
| |
constructaccess($url,$setpriv) : check for access to construction space URL |
| |
|
| |
See if the owner domain and name in the URL match those in the |
| |
expected environment. If so, return three element list |
| |
($ownername,$ownerdomain,$ownerhome). |
| |
|
| |
Otherwise return the null string. |
| |
|
| |
If second argument 'setpriv' is true, it assigns the privileges, |
| |
and returns the same three element list, unless the owner has |
| |
blocked "ad hoc" Domain Coordinator access to the Author Space, |
| |
in which case the null string is returned. |
| |
|
| |
=item * |
| |
|
| |
definerole($rolename,$sysrole,$domrole,$courole,$uname,$udom) : define role; |
| |
define a custom role rolename set privileges in format of lonTabs/roles.tab |
| |
for system, domain, and course level. $uname and $udom are optional (current |
| |
user's username and domain will be used when either of $uname or $udom are absent. |
| |
|
| |
=item * |
| |
|
| |
plaintext($short,$type,$cid,$forcedefault) : return value in %prp hash |
| |
(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 * |
| |
|
| |
get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec,$hidepriv) : |
| |
All arguments are optional. Returns a hash of a roles, either for |
| |
co-author/assistant author roles for a user's Construction Space |
| |
(default), or if $context is 'userroles', roles for the user himself, |
| |
In the hash, keys are set to colon-separated $uname,$udom,$role, and |
| |
(optionally) if $withsec is true, a fourth colon-separated item - $section. |
| |
For each key, value is set to colon-separated start and end times for |
| |
the role. If no username and domain are specified, will default to |
| |
current user/domain. Types, roles, and roledoms are references to arrays |
| |
of role statuses (active, future or previous), roles |
| |
(e.g., cc,in, st etc.) and domains of the roles which can be used |
| |
to restrict the list of roles reported. If no array ref is |
| |
provided for types, will default to return only active roles. |
| |
|
| =item * |
=item * |
| |
|
| definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom |
in_course($udom,$uname,$cdom,$cnum,$type,$hideprivileged) : determine if |
| role rolename set privileges in format of lonTabs/roles.tab for system, domain, |
user: $uname:$udom has a role in the course: $cdom_$cnum. |
| and course level |
|
| |
Additional optional arguments are: $type (if role checking is to be restricted |
| |
to certain user status types -- previous (expired roles), active (currently |
| |
available roles) or future (roles available in the future), and |
| |
$hideprivileged -- if true will not report course roles for users who |
| |
have active Domain Coordinator role in course's domain or in additional |
| |
domains (specified in 'Domains to check for privileged users' in course |
| |
environment -- set via: Course Settings -> Classlists and staff listing). |
| |
|
| =item * |
=item * |
| |
|
| plaintext($short) : return value in %prp hash (rolesplain.tab); plain text |
privileged($username,$domain,$possdomains,$possroles) : returns 1 if user |
| explanation of a user role term |
$username:$domain is a privileged user (e.g., Domain Coordinator or Super User) |
| |
$possdomains and $possroles are optional array refs -- to domains to check and |
| |
roles to check. If $possdomains is not specified, a dump will be done of the |
| |
users' roles.db to check for a dc or su role in any domain. This can be |
| |
time consuming if &privileged is called repeatedly (e.g., when displaying a |
| |
classlist), so in such cases, supplying a $possdomains array is preferred, as |
| |
this then allows &privileged_by_domain() to be used, which caches the identity |
| |
of privileged users, eliminating the need for repeated calls to &dump(). |
| |
|
| =item * |
=item * |
| |
|
| get_my_roles($uname,$udom,$types,$roles,$roledoms) : All arguments are optional. Returns a hash of a user's roles, with keys set to colon-sparated $uname,$udom,and $role, and value set to colon-separated start and end times for the role. If no username and domain are specified, will default to current user/domain. Types, roles, and roledoms are references to arrays, of role statuses (active, future or previous), roles (e.g., cc,in, st etc.) and domains of the roles which can be used to restrict the list if roles reported. If no array ref is provided for types, will default to return only active roles. |
privileged_by_domain($possdomains,$roles) : returns a hash of a hash of a hash, |
| |
where the outer hash keys are domains specified in the $possdomains array ref, |
| |
next inner hash keys are privileged roles specified in the $roles array ref, |
| |
and the innermost hash contains key = value pairs for username:domain = end:start |
| |
for active or future "privileged" users with that role in that domain. To avoid |
| |
repeated dumps of domain roles -- via &get_domain_roles() -- contents of the |
| |
innerhash are cached using priv_$role and $dom as the identifiers. |
| |
|
| =back |
=back |
| |
|
| =head2 User Modification |
=head2 User Modification |
|
Line 7980 get_my_roles($uname,$udom,$types,$roles,
|
Line 15818 get_my_roles($uname,$udom,$types,$roles,
|
| |
|
| =item * |
=item * |
| |
|
| assignrole($udom,$uname,$url,$role,$end,$start) : assign role; give a role to a |
assignrole($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,$context) : assign role; give a role to a |
| user for the level given by URL. Optional start and end dates (leave empty |
user for the level given by URL. Optional start and end dates (leave empty |
| string or zero for "no date") |
string or zero for "no date") |
| |
|
|
Line 7997 modifyuserauth($udom,$uname,$umode,$upas
|
Line 15835 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, |
| modify user |
$forceid,$desiredhome,$email,$inststatus,$candelete) : |
| |
|
| |
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 * |
| |
|
| modifystudent |
modifystudent |
| |
|
| modify a students enrollment and identification information. |
modify a student's enrollment and identification information. |
| The course id is resolved based on the current users environment. |
The course id is resolved based on the current user's environment. |
| This means the envoking user must be a course coordinator or otherwise |
This means the invoking user must be a course coordinator or otherwise |
| associated with a course. |
associated with a course. |
| |
|
| This call is essentially a wrapper for lonnet::modifyuser and |
This call is essentially a wrapper for lonnet::modifyuser and |
|
Line 8016 Inputs:
|
Line 15862 Inputs:
|
| |
|
| =over 4 |
=over 4 |
| |
|
| =item B<$udom> Students loncapa domain |
=item B<$udom> Student's loncapa domain |
| |
|
| =item B<$uname> Students loncapa login name |
=item B<$uname> Student's loncapa login name |
| |
|
| =item B<$uid> Students id/student number |
=item B<$uid> Student/Employee ID |
| |
|
| =item B<$umode> Students authentication mode |
=item B<$umode> Student's authentication mode |
| |
|
| =item B<$upass> Students password |
=item B<$upass> Student's password |
| |
|
| =item B<$first> Students first name |
=item B<$first> Student's first name |
| |
|
| =item B<$middle> Students middle name |
=item B<$middle> Student's middle name |
| |
|
| =item B<$last> Students last name |
=item B<$last> Student's last name |
| |
|
| =item B<$gene> Students generation |
=item B<$gene> Student's generation |
| |
|
| =item B<$usec> Students section in course |
=item B<$usec> Student's section in course |
| |
|
| =item B<$end> Unix time of the roles expiration |
=item B<$end> Unix time of the roles expiration |
| |
|
|
Line 8044 Inputs:
|
Line 15890 Inputs:
|
| |
|
| =item B<$desiredhome> server to use as home server for student |
=item B<$desiredhome> server to use as home server for student |
| |
|
| |
=item B<$email> Student's permanent e-mail address |
| |
|
| |
=item B<$type> Type of enrollment (auto or manual) |
| |
|
| |
=item B<$locktype> boolean - enrollment type locked to prevent Autoenroll.pl changing manual to auto |
| |
|
| |
=item B<$cid> courseID - needed if a course role is assigned by a user whose current role is DC |
| |
|
| |
=item B<$selfenroll> boolean - 1 if user role change occurred via self-enrollment |
| |
|
| |
=item B<$context> role change context (shown in User Management Logs display in a course) |
| |
|
| |
=item B<$inststatus> institutional status of user - : separated string of escaped status types |
| |
|
| |
=item B<$credits> Number of credits student will earn from this class - only needs to be supplied if value needs to be different from default credits for class. |
| |
|
| =back |
=back |
| |
|
| =item * |
=item * |
| |
|
| modify_student_enrollment |
modify_student_enrollment |
| |
|
| Change a students enrollment status in a class. The environment variable |
Change a student's enrollment status in a class. The environment variable |
| 'role.request.course' must be defined for this function to proceed. |
'role.request.course' must be defined for this function to proceed. |
| |
|
| Inputs: |
Inputs: |
| |
|
| =over 4 |
=over 4 |
| |
|
| =item $udom, students domain |
=item $udom, student's domain |
| |
|
| =item $uname, students name |
=item $uname, student's name |
| |
|
| =item $uid, students user id |
=item $uid, student's user id |
| |
|
| =item $first, students first name |
=item $first, student's first name |
| |
|
| =item $middle |
=item $middle |
| |
|
|
Line 8077 Inputs:
|
Line 15939 Inputs:
|
| |
|
| =item $start |
=item $start |
| |
|
| |
=item $type |
| |
|
| |
=item $locktype |
| |
|
| |
=item $cid |
| |
|
| |
=item $selfenroll |
| |
|
| |
=item $context |
| |
|
| |
=item $credits, number of credits student will earn from this class |
| |
|
| |
=item $instsec, institutional course section code for student |
| |
|
| =back |
=back |
| |
|
| |
|
|
Line 8102 revokecustomrole($udom,$uname,$url,$role
|
Line 15978 revokecustomrole($udom,$uname,$url,$role
|
| |
|
| =item * |
=item * |
| |
|
| coursedescription($courseid) : returns a hash of information about the |
coursedescription($courseid,$options) : returns a hash of information about the |
| specified course id, including all environment settings for the |
specified course id, including all environment settings for the |
| course, the description of the course will be in the hash under the |
course, the description of the course will be in the hash under the |
| key 'description' |
key 'description' |
| |
|
| |
$options is an optional parameter that if supplied is a hash reference that controls |
| |
what how this function works. It has the following key/values: |
| |
|
| |
=over 4 |
| |
|
| |
=item freshen_cache |
| |
|
| |
If defined, and the environment cache for the course is valid, it is |
| |
returned in the returned hash. |
| |
|
| |
=item one_time |
| |
|
| |
If defined, the last cache time is set to _now_ |
| |
|
| |
=item user |
| |
|
| |
If defined, the supplied username is used instead of the current user. |
| |
|
| |
|
| |
=back |
| |
|
| =item * |
=item * |
| |
|
| resdata($name,$domain,$type,@which) : request for current parameter |
resdata($name,$domain,$type,@which) : request for current parameter |
| setting for a specific $type, where $type is either 'course' or 'user', |
setting for a specific $type, where $type is either 'course' or 'user', |
| @what should be a list of parameters to ask about. This routine caches |
@what should be a list of parameters to ask about. This routine caches |
| answers for 5 minutes. |
answers for 10 minutes. |
| |
|
| |
=item * |
| |
|
| |
get_courseresdata($courseid, $domain) : dump the entire course resource |
| |
data base, returning a hash that is keyed by the resource name and has |
| |
values that are the resource value. I believe that the timestamps and |
| |
versions are also returned. |
| |
|
| |
get_numsuppfiles($cnum,$cdom) : retrieve number of files in a course's |
| |
supplemental content area. This routine caches the number of files for |
| |
10 minutes. |
| |
|
| =back |
=back |
| |
|
|
Line 8127 database) for a course
|
Line 16035 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). |
| |
|
| |
=item * |
| |
|
| |
is_course($courseid), is_course($cdom, $cnum) |
| |
|
| |
Accepts either a combined $courseid (in the form of domain_courseid) or the |
| |
two component version $cdom, $cnum. It checks if the specified course exists. |
| |
|
| |
Returns: |
| |
undef if the course doesn't exist, otherwise |
| |
in scalar context the combined courseid. |
| |
in list context the two components of the course identifier, domain and |
| |
courseid. |
| |
|
| |
=back |
| |
|
| |
=head2 Bubblesheet Configuration |
| |
|
| |
=over 4 |
| |
|
| |
=item * |
| |
|
| |
get_scantron_config($which) |
| |
|
| |
$which - the name of the configuration to parse from the file. |
| |
|
| |
Parses and returns the bubblesheet configuration line selected as a |
| |
hash of configuration file fields. |
| |
|
| |
|
| |
Returns: |
| |
If the named configuration is not in the file, an empty |
| |
hash is returned. |
| |
|
| |
a hash with the fields |
| |
name - internal name for the this configuration setup |
| |
description - text to display to operator that describes this config |
| |
CODElocation - if 0 or the string 'none' |
| |
- no CODE exists for this config |
| |
if -1 || the string 'letter' |
| |
- a CODE exists for this config and is |
| |
a string of letters |
| |
Unsupported value (but planned for future support) |
| |
if a positive integer |
| |
- The CODE exists as the first n items from |
| |
the question section of the form |
| |
if the string 'number' |
| |
- The CODE exists for this config and is |
| |
a string of numbers |
| |
CODEstart - (only matter if a CODE exists) column in the line where |
| |
the CODE starts |
| |
CODElength - length of the CODE |
| |
IDstart - column where the student/employee ID starts |
| |
IDlength - length of the student/employee ID info |
| |
Qstart - column where the information from the bubbled |
| |
'questions' start |
| |
Qlength - number of columns comprising a single bubble line from |
| |
the sheet. (usually either 1 or 10) |
| |
Qon - either a single character representing the character used |
| |
to signal a bubble was chosen in the positional setup, or |
| |
the string 'letter' if the letter of the chosen bubble is |
| |
in the final, or 'number' if a number representing the |
| |
chosen bubble is in the file (1->A 0->J) |
| |
Qoff - the character used to represent that a bubble was |
| |
left blank |
| |
PaperID - if the scanning process generates a unique number for each |
| |
sheet scanned the column that this ID number starts in |
| |
PaperIDlength - number of columns that comprise the unique ID number |
| |
for the sheet of paper |
| |
FirstName - column that the first name starts in |
| |
FirstNameLength - number of columns that the first name spans |
| |
LastName - column that the last name starts in |
| |
LastNameLength - number of columns that the last name spans |
| |
BubblesPerRow - number of bubbles available in each row used to |
| |
bubble an answer. (If not specified, 10 assumed). |
| |
|
| |
|
| |
=item * |
| |
|
| |
get_scantronformat_file($cdom) |
| |
|
| |
$cdom - the course's domain (optional); if not supplied, uses |
| |
domain for current $env{'request.course.id'}. |
| |
|
| |
Returns an array containing lines from the scantron format file for |
| |
the domain of the course. |
| |
|
| |
If a url for a custom.tab file is listed in domain's configuration.db, |
| |
lines are from this file. |
| |
|
| |
Otherwise, if a default.tab has been published in RES space by the |
| |
domainconfig user, lines are from this file. |
| |
|
| |
Otherwise, fall back to getting lines from the legacy file on the |
| |
local server: /home/httpd/lonTabs/default_scantronformat.tab |
| |
|
| =back |
=back |
| |
|
|
Line 8156 resource. Expects the local filesystem p
|
Line 16163 resource. Expects the local filesystem p
|
| |
|
| =item * |
=item * |
| |
|
| EXT($varname,$symb,$udom,$uname) : evaluates and returns the value of |
EXT($varname,$symb,$udom,$uname,$usection,$recurse,$cid) : evaluates |
| a vairety of different possible values, $varname should be a request |
and returns the value of a variety of different possible values, |
| string, and the other parameters can be used to specify who and what |
$varname should be a request string, and the other parameters can be |
| one is asking about. |
used to specify who and what one is asking about. Ordinarily, $cid |
| |
does not need to be specified, as it is retrived from |
| |
$env{'request.course.id'}, but &Apache::lonnet::EXT() is called |
| |
within lonuserstate::loadmap() when initializing a course, before |
| |
$env{'request.course.id'} has been set, so it needs to be provided |
| |
in that one case. |
| |
|
| Possible values for $varname are environment.lastname (or other item |
Possible values for $varname are environment.lastname (or other item |
| from the envirnment hash), user.name (or someother aspect about the |
from the envirnment hash), user.name (or someother aspect about the |
|
Line 8177 condval($condidx) : value of condition i
|
Line 16189 condval($condidx) : value of condition i
|
| |
|
| =item * |
=item * |
| |
|
| metadata($uri,$what,$liburi,$prefix,$depthcount) : request a |
metadata($uri,$what,$toolsymb,$liburi,$prefix,$depthcount) : request a |
| resource's metadata, $what should be either a specific key, or either |
resource's metadata, $what should be either a specific key, or either |
| 'keys' (to get a list of possible keys) or 'packages' to get a list of |
'keys' (to get a list of possible keys) or 'packages' to get a list of |
| packages that this resource currently uses, the last 3 arguments are only used internally for recursive metadata. |
packages that this resource currently uses, the last 3 arguments are |
| |
only used internally for recursive metadata. |
| |
|
| this function automatically caches all requests |
the toolsymb is only used where the uri is for an external tool (for which |
| |
the uri as well as the symb are guaranteed to be unique). |
| |
|
| |
this function automatically caches all requests except any made recursively |
| |
to retrieve a list of metadata keys for an imported library file ($liburi is |
| |
defined). |
| |
|
| =item * |
=item * |
| |
|
|
Line 8192 will be stored for query
|
Line 16210 will be stored for query
|
| |
|
| =item * |
=item * |
| |
|
| symbread($filename) : return symbolic list entry (filename argument optional); |
symbread($filename,$donotrecurse,$ignorecachednull,$checkforblock,$possibles) : |
| |
return symbolic list entry (all arguments optional). |
| |
|
| |
Args: filename is the filename (including path) for the file for which a symb |
| |
is required; donotrecurse, if true will prevent calls to allowed() being made |
| |
to check access status if more than one resource was found in the bighash |
| |
(see rev. 1.249) to avoid an infinite loop if an ambiguous resource is part of |
| |
a randompick); ignorecachednull, if true will prevent a symb of '' being |
| |
returned if $env{$cache_str} is defined as ''; checkforblock if true will |
| |
cause possible symbs to be checked to determine if they are subject to content |
| |
blocking, if so they will not be included as possible symbs; possibles is a |
| |
ref to a hash, which, as a side effect, will be populated with all possible |
| |
symbs (content blocking not tested). |
| |
|
| returns the data handle |
returns the data handle |
| |
|
| =item * |
=item * |
| |
|
| symbverify($symb,$thisfn) : verifies that $symb actually exists and is |
symbverify($symb,$thisfn,$encstate) : verifies that $symb actually exists |
| a possible symb for the URL in $thisfn, and if is an encryypted |
and is a possible symb for the URL in $thisfn, and if is an encrypted |
| resource that the user accessed using /enc/ returns a 1 on success, 0 |
resource that the user accessed using /enc/ returns a 1 on success, 0 |
| on failure, user must be in a course, as it assumes the existance of |
on failure, user must be in a course, as it assumes the existence of |
| the course initial hash, and uses $env('request.course.id'} |
the course initial hash, and uses $env('request.course.id'}. The third |
| |
arg is an optional reference to a scalar. If this arg is passed in the |
| |
call to symbverify, it will be set to 1 if the symb has been set to be |
| |
encrypted; otherwise it will be null. |
| |
|
| =item * |
=item * |
| |
|
|
Line 8255 expirespread($uname,$udom,$stype,$usymb)
|
Line 16288 expirespread($uname,$udom,$stype,$usymb)
|
| devalidate($symb) : devalidate temporary spreadsheet calculations, |
devalidate($symb) : devalidate temporary spreadsheet calculations, |
| forcing spreadsheet to reevaluate the resource scores next time. |
forcing spreadsheet to reevaluate the resource scores next time. |
| |
|
| |
=item * |
| |
|
| |
can_edit_resource($file,$cnum,$cdom,$resurl,$symb,$group) : determine if current user can edit a particular resource, |
| |
when viewing in course context. |
| |
|
| |
input: six args -- filename (decluttered), course number, course domain, |
| |
url, symb (if registered) and group (if this is a |
| |
group item -- e.g., bulletin board, group page etc.). |
| |
|
| |
output: array of five scalars -- |
| |
$cfile -- url for file editing if editable on current server |
| |
$home -- homeserver of resource (i.e., for author if published, |
| |
or course if uploaded.). |
| |
$switchserver -- 1 if server switch will be needed. |
| |
$forceedit -- 1 if icon/link should be to go to edit mode |
| |
$forceview -- 1 if icon/link should be to go to view mode |
| |
|
| |
=item * |
| |
|
| |
is_course_upload($file,$cnum,$cdom) |
| |
|
| |
Used in course context to determine if current file was uploaded to |
| |
the course (i.e., would be found in /userfiles/docs on the course's |
| |
homeserver. |
| |
|
| |
input: 3 args -- filename (decluttered), course number and course domain. |
| |
output: boolean -- 1 if file was uploaded. |
| |
|
| =back |
=back |
| |
|
| =head2 Storing/Retreiving Data |
=head2 Storing/Retreiving Data |
|
Line 8263 forcing spreadsheet to reevaluate the re
|
Line 16324 forcing spreadsheet to reevaluate the re
|
| |
|
| =item * |
=item * |
| |
|
| store($storehash,$symb,$namespace,$udom,$uname) : stores hash permanently |
store($storehash,$symb,$namespace,$udom,$uname,$laststore) : stores hash |
| for this url; hashref needs to be given and should be a \%hashname; the |
permanently for this url; hashref needs to be given and should be a \%hashname; |
| remaining args aren't required and if they aren't passed or are '' they will |
the remaining args aren't required and if they aren't passed or are '' they will |
| be derived from the env |
be derived from the env (with the exception of $laststore, which is an |
| |
optional arg used when a user's submission is stored in grading). |
| |
$laststore is $version=$timestamp, where $version is the most recent version |
| |
number retrieved for the corresponding $symb in the $namespace db file, and |
| |
$timestamp is the timestamp for that transaction (UNIX time). |
| |
$laststore is currently only passed when cstore() is called by |
| |
structuretags::finalize_storage(). |
| |
|
| =item * |
=item * |
| |
|
| cstore($storehash,$symb,$namespace,$udom,$uname) : same as store but |
cstore($storehash,$symb,$namespace,$udom,$uname,$laststore) : same as store |
| uses critical subroutine |
but uses critical subroutine |
| |
|
| =item * |
=item * |
| |
|
|
Line 8294 $range should be either an integer '100'
|
Line 16361 $range should be either an integer '100'
|
| |
|
| =item * |
=item * |
| |
|
| putstore($namespace,$symb,$version,$storehash,$udomain,$uname) : |
putstore($namespace,$symb,$version,$storehash,$udomain,$uname,$tolog) : |
| replaces a &store() version of data with a replacement set of data |
replaces a &store() version of data with a replacement set of data |
| for a particular resource in a namespace passed in the $storehash hash |
for a particular resource in a namespace passed in the $storehash hash |
| reference |
reference. If $tolog is true, the transaction is logged in the courselog |
| |
with an action=PUTSTORE. |
| |
|
| =item * |
=item * |
| |
|
|
Line 8377 Returns:
|
Line 16445 Returns:
|
| 'key_exists: <key>' -> failed to anything out of $storehash, as at |
'key_exists: <key>' -> failed to anything out of $storehash, as at |
| least <key> already existed in the db (other |
least <key> already existed in the db (other |
| requested keys may also already exist) |
requested keys may also already exist) |
| 'error: <msg>' -> unable to tie the DB or other erorr occured |
'error: <msg>' -> unable to tie the DB or other error occurred |
| 'con_lost' -> unable to contact request server |
'con_lost' -> unable to contact request server |
| 'refused' -> action was not allowed by remote machine |
'refused' -> action was not allowed by remote machine |
| |
|
|
Line 8395 critical subroutine
|
Line 16463 critical subroutine
|
| |
|
| =item * |
=item * |
| |
|
| get_dom($namespace,$storearr,$udomain) : returns hash with keys from array |
get_dom($namespace,$storearr,$udom,$uhome) : returns hash with keys from |
| reference filled in from namespace found in domain level on primary domain server ($udomain is optional) |
array reference filled in from namespace found in domain level on either |
| |
specified domain server ($uhome) or primary domain server ($udom and $uhome are optional). |
| |
|
| =item * |
=item * |
| |
|
| put_dom($namespace,$storehash,$udomain) : stores hash in namespace at domain level on primary domain server ($udomain is optional) |
put_dom($namespace,$storehash,$udom,$uhome) : stores hash in namespace at |
| |
domain level either on specified domain server ($uhome) or primary domain |
| |
server ($udom and $uhome are optional) |
| |
|
| |
=item * |
| |
|
| |
get_domain_defaults($target_domain,$ignore_cache) : returns hash with defaults |
| |
for: authentication, language, quotas, timezone, date locale, and portal URL in |
| |
the target domain. |
| |
|
| |
May also include additional key => value pairs for the following groups: |
| |
|
| |
=over |
| |
|
| |
=item |
| |
disk quotas (MB allocated by default to portfolios and authoring spaces). |
| |
|
| |
=over |
| |
|
| |
=item defaultquota, authorquota |
| |
|
| |
=back |
| |
|
| |
=item |
| |
tools (availability of aboutme page, blog, webDAV access for authoring spaces, |
| |
portfolio for users). |
| |
|
| |
=over |
| |
|
| |
=item |
| |
aboutme, blog, webdav, portfolio |
| |
|
| |
=back |
| |
|
| |
=item |
| |
requestcourses: ability to request courses, and how requests are processed. |
| |
|
| |
=over |
| |
|
| |
=item |
| |
official, unofficial, community, textbook, placement |
| |
|
| |
=back |
| |
|
| |
=item |
| |
inststatus: types of institutional affiliation, and order in which they are displayed. |
| |
|
| |
=over |
| |
|
| |
=item |
| |
inststatustypes, inststatusorder, inststatusguest |
| |
|
| |
=back |
| |
|
| |
=item |
| |
coursedefaults: can PDF forms can be created, default credits for courses, default quotas (MB) |
| |
for course's uploaded content. |
| |
|
| |
=over |
| |
|
| |
=item |
| |
canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota, |
| |
communityquota, textbookquota, placementquota |
| |
|
| |
=back |
| |
|
| |
=item |
| |
usersessions: set options for hosting of your users in other domains, and hosting of users from other domains |
| |
on your servers. |
| |
|
| |
=over |
| |
|
| |
=item |
| |
remotesessions, hostedsessions |
| |
|
| |
=back |
| |
|
| |
=back |
| |
|
| |
In cases where a domain coordinator has never used the "Set Domain Configuration" |
| |
utility to create a configuration.db file on a domain's primary library server |
| |
only the following domain defaults: auth_def, auth_arg_def, lang_def |
| |
-- corresponding values are authentication type (internal, krb4, krb5, |
| |
or localauth), initial password or a kerberos realm, language (e.g., en-us) -- |
| |
will be available. Values are retrieved from cache (if current), unless the |
| |
optional $ignore_cache arg is true, or from domain's configuration.db (if available), |
| |
or lastly from values in lonTabs/dns_domain,tab, or lonTabs/domain.tab. |
| |
|
| |
Typical usage: |
| |
|
| |
%domdefaults = &get_domain_defaults($target_domain); |
| |
|
| =back |
=back |
| |
|
|
Line 8410 put_dom($namespace,$storehash,$udomain)
|
Line 16569 put_dom($namespace,$storehash,$udomain)
|
| |
|
| =item * |
=item * |
| |
|
| dirlist($uri) : return directory list based on URI |
dirlist() : return directory list based on URI (first arg). |
| |
|
| |
Inputs: 1 required, 5 optional. |
| |
|
| |
=over |
| |
|
| |
=item |
| |
$uri - path to file in filesystem (starts: /res or /userfiles/). Required. |
| |
|
| |
=item |
| |
$userdomain - domain of user/course to be listed. Extracted from $uri if absent. |
| |
|
| |
=item |
| |
$username - username of user/course to be listed. Extracted from $uri if absent. |
| |
|
| |
=item |
| |
$getpropath - boolean: 1 if prepend path using &propath(). |
| |
|
| |
=item |
| |
$getuserdir - boolean: 1 if prepend path for "userfiles". |
| |
|
| |
=item |
| |
$alternateRoot - path to prepend in place of path from $uri. |
| |
|
| |
=back |
| |
|
| |
Returns: Array of up to two items. |
| |
|
| |
=over |
| |
|
| |
a reference to an array of files/subdirectories |
| |
|
| |
=over |
| |
|
| |
Each element in the array of files/subdirectories is a & separated list of |
| |
item name and the result of running stat on the item. If dirlist was requested |
| |
for a file instead of a directory, the item name will be ''. For a directory |
| |
listing, if the item is a metadata file, the element will end &N&M |
| |
(where N amd M are either 0 or 1, corresponding to obsolete set (1), or |
| |
default copyright set (1). |
| |
|
| |
=back |
| |
|
| |
a scalar containing error condition (if encountered). |
| |
|
| |
=over |
| |
|
| |
=item |
| |
no_host (no homeserver identified for $username:$domain). |
| |
|
| |
=item |
| |
no_such_host (server contacted for listing not identified as valid host). |
| |
|
| |
=item |
| |
con_lost (connection to remote server failed). |
| |
|
| |
=item |
| |
refused (invalid $username:$domain received on lond side). |
| |
|
| |
=item |
| |
no_such_dir (directory at specified path on lond side does not exist). |
| |
|
| |
=item |
| |
empty (directory at specified path on lond side is empty). |
| |
|
| |
=over |
| |
|
| |
This is currently not encountered because the &ls3, &ls2, |
| |
&ls (_handler) routines on the lond side do not filter out |
| |
. and .. from a directory listing. |
| |
|
| |
=back |
| |
|
| |
=back |
| |
|
| |
=back |
| |
|
| =item * |
=item * |
| |
|
| 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 |
|
Line 8465 splitting on '&', supports elements that
|
Line 16706 splitting on '&', supports elements that
|
| |
|
| =head2 Logging Routines |
=head2 Logging Routines |
| |
|
| =over 4 |
|
| |
|
| These routines allow one to make log messages in the lonnet.log and |
These routines allow one to make log messages in the lonnet.log and |
| lonnet.perm logfiles. |
lonnet.perm logfiles. |
| |
|
| |
=over 4 |
| |
|
| =item * |
=item * |
| |
|
| logtouch() : make sure the logfile, lonnet.log, exists |
logtouch() : make sure the logfile, lonnet.log, exists |
|
Line 8485 logperm() : append a permanent message t
|
Line 16727 logperm() : append a permanent message t
|
| file never gets deleted by any automated portion of the system, only |
file never gets deleted by any automated portion of the system, only |
| messages of critical importance should go in here. |
messages of critical importance should go in here. |
| |
|
| |
|
| =back |
=back |
| |
|
| =head2 General File Helper Routines |
=head2 General File Helper Routines |
|
Line 8541 filelocation except for hrefs
|
Line 16784 filelocation except for hrefs
|
| |
|
| =item * |
=item * |
| |
|
| declutter() : declutters URLs (remove docroot, beginning slashes, 'res' etc) |
declutter() : declutters URLs -- remove beginning slashes, 'res' etc. |
| |
also removes beginning /home/httpd/html unless /priv/ follows it. |
| |
|
| =back |
=back |
| |
|
|
Line 8558 userfileupload(): main rotine for puttin
|
Line 16802 userfileupload(): main rotine for puttin
|
| filename, and the contents of the file to create/modifed exist |
filename, and the contents of the file to create/modifed exist |
| the filename is in $env{'form.'.$formname.'.filename'} and the |
the filename is in $env{'form.'.$formname.'.filename'} and the |
| contents of the file is located in $env{'form.'.$formname} |
contents of the file is located in $env{'form.'.$formname} |
| coursedoc - if true, store the file in the course of the active role |
context - if coursedoc, store the file in the course of the active role |
| of the current user |
of the current user; |
| |
if 'existingfile': store in 'overwrites' in /home/httpd/perl/tmp |
| |
if 'canceloverwrite': delete file in tmp/overwrites directory |
| subdir - required - subdirectory to put the file in under ../userfiles/ |
subdir - required - subdirectory to put the file in under ../userfiles/ |
| if undefined, it will be placed in "unknown" |
if undefined, it will be placed in "unknown" |
| |
|
|
Line 8581 returns: the new clean filename
|
Line 16827 returns: the new clean filename
|
| |
|
| =item * |
=item * |
| |
|
| finishuserfileupload(): routine that creaes and sends the file to |
finishuserfileupload(): routine that creates and sends the file to |
| userspace, probably shouldn't be called directly |
userspace, probably shouldn't be called directly |
| |
|
| docuname: username or courseid of destination for the file |
docuname: username or courseid of destination for the file |
| docudom: domain of user/course of destination for the file |
docudom: domain of user/course of destination for the file |
| formname: same as for userfileupload() |
formname: same as for userfileupload() |
| fname: filename (inculding subdirectories) for the file |
fname: filename (including subdirectories) for the file |
| |
parser: if 'parse', will parse (html) file to extract references to objects, links etc. |
| |
if hashref, and context is scantron, will convert csv format to standard format |
| |
allfiles: reference to hash used to store objects found by parser |
| |
codebase: reference to hash used for codebases of java objects found by parser |
| |
thumbwidth: width (pixels) of thumbnail to be created for uploaded image |
| |
thumbheight: height (pixels) of thumbnail to be created for uploaded image |
| |
resizewidth: width to be used to resize image using resizeImage from ImageMagick |
| |
resizeheight: height to be used to resize image using resizeImage from ImageMagick |
| |
context: if 'overwrite', will move the uploaded file from its temporary location to |
| |
userfiles to facilitate overwriting a previously uploaded file with same name. |
| |
mimetype: reference to scalar to accommodate mime type determined |
| |
from File::MMagic if $parser = parse. |
| |
|
| returns either the url of the uploaded file (/uploaded/....) if successful |
returns either the url of the uploaded file (/uploaded/....) if successful |
| and /adm/notfound.html if unsuccessful |
and /adm/notfound.html if unsuccessful (or an error message if context |
| |
was 'overwrite'). |
| |
|
| |
|
| =item * |
=item * |
| |
|
|
Line 8696 Internal notes:
|
Line 16956 Internal notes:
|
| |
|
| Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays. |
Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays. |
| |
|
| |
=item * |
| |
|
| modify_access_controls(): |
modify_access_controls(): |
| |
|
| Modifies access controls for a portfolio file |
Modifies access controls for a portfolio file |
|
Line 8713 Returns:
|
Line 16975 Returns:
|
| 3. reference to hash of any new or updated access controls. |
3. reference to hash of any new or updated access controls. |
| 4. reference to hash used to map incoming IDs to uniqueIDs assigned to control. |
4. reference to hash used to map incoming IDs to uniqueIDs assigned to control. |
| key = integer (inbound ID) |
key = integer (inbound ID) |
| value = uniqueID |
value = uniqueID |
| |
|
| |
=item * |
| |
|
| |
get_timebased_id(): |
| |
|
| |
Attempts to get a unique timestamp-based suffix for use with items added to a |
| |
course via the Course Editor (e.g., folders, composite pages, |
| |
group bulletin boards). |
| |
|
| |
Args: (first three required; six others optional) |
| |
|
| |
1. prefix (alphanumeric): of keys in hash, e.g., suppsequence, docspage, |
| |
docssequence, or name of group |
| |
|
| |
2. keyid (alphanumeric): name of temporary locking key in hash, |
| |
e.g., num, boardids |
| |
|
| |
3. namespace: name of gdbm file used to store suffixes already assigned; |
| |
file will be named nohist_namespace.db |
| |
|
| |
4. cdom: domain of course; default is current course domain from %env |
| |
|
| |
5. cnum: course number; default is current course number from %env |
| |
|
| |
6. idtype: set to concat if an additional digit is to be appended to the |
| |
unix timestamp to form the suffix, if the plain timestamp is already |
| |
in use. Default is to not do this, but simply increment the unix |
| |
timestamp by 1 until a unique key is obtained. |
| |
|
| |
7. who: holder of locking key; defaults to user:domain for user. |
| |
|
| |
8. locktries: number of attempts to obtain a lock (sleep of 1s before |
| |
retrying); default is 3. |
| |
|
| |
9. maxtries: number of attempts to obtain a unique suffix; default is 20. |
| |
|
| |
Returns: |
| |
|
| |
1. suffix obtained (numeric) |
| |
|
| |
2. result of deleting locking key (ok if deleted, or lock never obtained) |
| |
|
| |
3. error: contains (localized) error message if an error occurred. |
| |
|
| |
|
| =back |
=back |
| |
|
|
Line 8793 symblist($mapname,%newhash) : update sym
|
Line 17099 symblist($mapname,%newhash) : update sym
|
| =back |
=back |
| |
|
| =cut |
=cut |
| |
|
![[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