|
version 1.580, 2004/12/20 20:29:00
|
version 1.612, 2005/03/17 21:18:12
|
|
Line 35 use HTTP::Headers;
|
Line 35 use HTTP::Headers;
|
| use HTTP::Date; |
use HTTP::Date; |
| # use Date::Parse; |
# use Date::Parse; |
| use vars |
use vars |
| qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom |
qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom |
| %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache |
%libserv %pr %prp $memcache %packagetab |
| %courselogs %accesshash %userrolehash $processmarker $dumpcount |
%courselogs %accesshash %userrolehash $processmarker $dumpcount |
| %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %courseresdatacache |
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf |
| %userresdatacache %getsectioncache %domaindescription %domain_auth_def %domain_auth_arg_def |
%domaindescription %domain_auth_def %domain_auth_arg_def |
| %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit); |
%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit); |
| |
|
| use IO::Socket; |
use IO::Socket; |
|
Line 50 use Fcntl qw(:flock);
|
Line 50 use Fcntl qw(:flock);
|
| use Apache::lonlocal; |
use Apache::lonlocal; |
| use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze); |
use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze); |
| use Time::HiRes qw( gettimeofday tv_interval ); |
use Time::HiRes qw( gettimeofday tv_interval ); |
| |
use Cache::Memcached; |
| my $readit; |
my $readit; |
| my $max_connection_retries = 10; # Or some such value. |
my $max_connection_retries = 10; # Or some such value. |
| |
|
|
Line 157 sub reply {
|
Line 158 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 eq 'con_lost') { |
|
| #sleep 5; |
|
| #$answer=subreply($cmd,$server); |
|
| #if ($answer eq 'con_lost') { |
|
| # &logthis("Second attempt con_lost on $server"); |
|
| # my $peerfile="$perlvar{'lonSockDir'}/$server"; |
|
| # my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", |
|
| # Type => SOCK_STREAM, |
|
| # Timeout => 10) |
|
| # or return "con_lost"; |
|
| # &logthis("Killing socket"); |
|
| # print $client "close_connection_exit\n"; |
|
| #sleep 5; |
|
| # $answer=subreply($cmd,$server); |
|
| #} |
|
| } |
|
| if (($answer=~/^refused/) || ($answer=~/^rejected/)) { |
if (($answer=~/^refused/) || ($answer=~/^rejected/)) { |
| &logthis("<font color=blue>WARNING:". |
&logthis("<font color=blue>WARNING:". |
| " $cmd to $server returned $answer</font>"); |
" $cmd to $server returned $answer</font>"); |
|
Line 220 sub critical {
|
Line 205 sub critical {
|
| } |
} |
| my $answer=reply($cmd,$server); |
my $answer=reply($cmd,$server); |
| if ($answer eq 'con_lost') { |
if ($answer eq 'con_lost') { |
| my $pingreply=reply('ping',$server); |
|
| &reconlonc("$perlvar{'lonSockDir'}/$server"); |
&reconlonc("$perlvar{'lonSockDir'}/$server"); |
| my $pongreply=reply('pong',$server); |
my $answer=reply($cmd,$server); |
| &logthis("Ping/Pong for $server: $pingreply/$pongreply"); |
|
| $answer=reply($cmd,$server); |
|
| if ($answer eq 'con_lost') { |
if ($answer eq 'con_lost') { |
| my $now=time; |
my $now=time; |
| my $middlename=$cmd; |
my $middlename=$cmd; |
|
Line 577 sub authenticate {
|
Line 559 sub authenticate {
|
| |
|
| # ---------------------- Find the homebase for a user from domain's lib servers |
# ---------------------- Find the homebase for a user from domain's lib servers |
| |
|
| |
my %homecache; |
| sub homeserver { |
sub homeserver { |
| my ($uname,$udom,$ignoreBadCache)=@_; |
my ($uname,$udom,$ignoreBadCache)=@_; |
| my $index="$uname:$udom"; |
my $index="$uname:$udom"; |
| |
|
| my ($result,$cached)=&is_cached(\%homecache,$index,'home',86400); |
if (exists($homecache{$index})) { return $homecache{$index}; } |
| if (defined($cached)) { return $result; } |
|
| my $tryserver; |
my $tryserver; |
| foreach $tryserver (keys %libserv) { |
foreach $tryserver (keys %libserv) { |
| next if ($ignoreBadCache ne 'true' && |
next if ($ignoreBadCache ne 'true' && |
|
Line 590 sub homeserver {
|
Line 572 sub homeserver {
|
| if ($hostdom{$tryserver} eq $udom) { |
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 &do_cache(\%homecache,$index,$tryserver,'home'); |
return $homecache{$index}=$tryserver; |
| } elsif ($answer eq 'no_host') { |
} elsif ($answer eq 'no_host') { |
| $badServerCache{$tryserver}=1; |
$badServerCache{$tryserver}=1; |
| } |
} |
|
Line 795 sub validate_access_key {
|
Line 777 sub validate_access_key {
|
| |
|
| sub getsection { |
sub getsection { |
| my ($udom,$unam,$courseid)=@_; |
my ($udom,$unam,$courseid)=@_; |
| |
my $cachetime=1800; |
| $courseid=~s/\_/\//g; |
$courseid=~s/\_/\//g; |
| $courseid=~s/^(\w)/\/$1/; |
$courseid=~s/^(\w)/\/$1/; |
| |
|
| my $hashid="$udom:$unam:$courseid"; |
my $hashid="$udom:$unam:$courseid"; |
| my ($result,$cached)=&is_cached(\%getsectioncache,$hashid,'getsection'); |
my ($result,$cached)=&is_cached_new('getsection',$hashid); |
| if (defined($cached)) { return $result; } |
if (defined($cached)) { return $result; } |
| |
|
| my %Pending; |
my %Pending; |
|
Line 834 sub getsection {
|
Line 817 sub getsection {
|
| $Pending{$start}=$section; |
$Pending{$start}=$section; |
| next; |
next; |
| } |
} |
| return &do_cache(\%getsectioncache,$hashid,$section,'getsection'); |
return &do_cache_new('getsection',$hashid,$section,$cachetime); |
| } |
} |
| # |
# |
| # Presumedly there will be few matching roles from the above |
# Presumedly there will be few matching roles from the above |
| # loop and the sorting time will be negligible. |
# loop and the sorting time will be negligible. |
| if (scalar(keys(%Pending))) { |
if (scalar(keys(%Pending))) { |
| my ($time) = sort {$a <=> $b} keys(%Pending); |
my ($time) = sort {$a <=> $b} keys(%Pending); |
| return &do_cache(\%getsectioncache,$hashid,$Pending{$time},'getsection'); |
return &do_cache_new('getsection',$hashid,$Pending{$time},$cachetime); |
| } |
} |
| if (scalar(keys(%Expired))) { |
if (scalar(keys(%Expired))) { |
| my @sorted = sort {$a <=> $b} keys(%Expired); |
my @sorted = sort {$a <=> $b} keys(%Expired); |
| my $time = pop(@sorted); |
my $time = pop(@sorted); |
| return &do_cache(\%getsectioncache,$hashid,$Expired{$time},'getsection'); |
return &do_cache_new('getsection',$hashid,$Expired{$time},$cachetime); |
| } |
} |
| return &do_cache(\%getsectioncache,$hashid,'-1','getsection'); |
return &do_cache_new('getsection',$hashid,'-1',$cachetime); |
| } |
} |
| |
|
| |
sub save_cache { |
| |
&purge_remembered(); |
| |
} |
| |
|
| my $disk_caching_disabled=1; |
my $to_remember=-1; |
| |
my %remembered; |
| sub devalidate_cache { |
my %accessed; |
| my ($cache,$id,$name) = @_; |
my $kicks=0; |
| delete $$cache{$id.'.time'}; |
my $hits=0; |
| delete $$cache{$id.'.file'}; |
sub devalidate_cache_new { |
| delete $$cache{$id}; |
my ($name,$id,$debug) = @_; |
| if (1 || $disk_caching_disabled) { return; } |
if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); } |
| my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db"; |
$id=&escape($name.':'.$id); |
| if (!-e $filename) { return; } |
$memcache->delete($id); |
| open(DB,">$filename.lock"); |
delete($remembered{$id}); |
| flock(DB,LOCK_EX); |
delete($accessed{$id}); |
| my %hash; |
} |
| if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) { |
|
| eval <<'EVALBLOCK'; |
sub is_cached_new { |
| delete($hash{$id}); |
my ($name,$id,$debug) = @_; |
| delete($hash{$id.'.time'}); |
$id=&escape($name.':'.$id); |
| EVALBLOCK |
if (exists($remembered{$id})) { |
| if ($@) { |
if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); } |
| &logthis("<font color='red'>devalidate_cache blew up :$@:$name</font>"); |
$accessed{$id}=[&gettimeofday()]; |
| unlink($filename); |
$hits++; |
| } |
return ($remembered{$id},1); |
| } else { |
} |
| if (-e $filename) { |
my $value = $memcache->get($id); |
| &logthis("Unable to tie hash (devalidate cache): $name"); |
if (!(defined($value))) { |
| unlink($filename); |
if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); } |
| } |
|
| } |
|
| untie(%hash); |
|
| flock(DB,LOCK_UN); |
|
| close(DB); |
|
| } |
|
| |
|
| sub is_cached { |
|
| my ($cache,$id,$name,$time) = @_; |
|
| if (!$time) { $time=300; } |
|
| if (!exists($$cache{$id.'.time'})) { |
|
| &load_cache_item($cache,$name,$id,$time); |
|
| } |
|
| if (!exists($$cache{$id.'.time'})) { |
|
| # &logthis("Didn't find $id"); |
|
| return (undef,undef); |
return (undef,undef); |
| } else { |
|
| if (time-($$cache{$id.'.time'})>$time) { |
|
| if (exists($$cache{$id.'.file'})) { |
|
| foreach my $filename (@{ $$cache{$id.'.file'} }) { |
|
| my $mtime=(stat($filename))[9]; |
|
| #+1 is to take care of edge effects |
|
| if ($mtime && (($mtime+1) < ($$cache{$id.'.time'}))) { |
|
| # &logthis("Upping $mtime - ".$$cache{$id.'.time'}. |
|
| # "$id because of $filename"); |
|
| } else { |
|
| &logthis("Devalidating $filename $id - ".(time-($$cache{$id.'.time'}))); |
|
| &devalidate_cache($cache,$id,$name); |
|
| return (undef,undef); |
|
| } |
|
| } |
|
| $$cache{$id.'.time'}=time; |
|
| } else { |
|
| # &logthis("Devalidating $id - ".time-($$cache{$id.'.time'})); |
|
| &devalidate_cache($cache,$id,$name); |
|
| return (undef,undef); |
|
| } |
|
| } |
|
| } |
} |
| return ($$cache{$id},1); |
if ($value eq '__undef__') { |
| } |
if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); } |
| |
$value=undef; |
| sub do_cache { |
} |
| my ($cache,$id,$value,$name) = @_; |
&make_room($id,$value,$debug); |
| $$cache{$id.'.time'}=time; |
if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); } |
| $$cache{$id}=$value; |
return ($value,1); |
| # &logthis("Caching $id as :$value:"); |
} |
| &save_cache_item($cache,$name,$id); |
|
| # do_cache implictly return the set value |
sub do_cache_new { |
| $$cache{$id}; |
my ($name,$id,$value,$time,$debug) = @_; |
| } |
$id=&escape($name.':'.$id); |
| |
my $setvalue=$value; |
| my %do_save_item; |
if (!defined($setvalue)) { |
| my %do_save; |
$setvalue='__undef__'; |
| sub save_cache_item { |
} |
| my ($cache,$name,$id)=@_; |
if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); } |
| if ($disk_caching_disabled) { return; } |
$memcache->set($id,$setvalue,$time); |
| $do_save{$name}=$cache; |
# need to make a copy of $value |
| if (!exists($do_save_item{$name})) { $do_save_item{$name}={} } |
#&make_room($id,$value,$debug); |
| $do_save_item{$name}->{$id}=1; |
return $value; |
| |
} |
| |
|
| |
sub make_room { |
| |
my ($id,$value,$debug)=@_; |
| |
$remembered{$id}=$value; |
| |
if ($to_remember<0) { return; } |
| |
$accessed{$id}=[&gettimeofday()]; |
| |
if (scalar(keys(%remembered)) <= $to_remember) { return; } |
| |
my $to_kick; |
| |
my $max_time=0; |
| |
foreach my $other (keys(%accessed)) { |
| |
if (&tv_interval($accessed{$other}) > $max_time) { |
| |
$to_kick=$other; |
| |
$max_time=&tv_interval($accessed{$other}); |
| |
} |
| |
} |
| |
delete($remembered{$to_kick}); |
| |
delete($accessed{$to_kick}); |
| |
$kicks++; |
| |
if ($debug) { &logthis("kicking $to_kick $max_time $kicks\n"); } |
| return; |
return; |
| } |
} |
| |
|
| sub save_cache { |
sub purge_remembered { |
| if ($disk_caching_disabled) { return; } |
#&logthis("Tossing ".scalar(keys(%remembered))); |
| my ($cache,$name,$id); |
#&logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered)))); |
| foreach $name (keys(%do_save)) { |
undef(%remembered); |
| $cache=$do_save{$name}; |
undef(%accessed); |
| |
|
| my $starttime=&Time::HiRes::time(); |
|
| &logthis("Saving :$name:"); |
|
| my %hash; |
|
| my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db"; |
|
| open(DB,">$filename.lock"); |
|
| flock(DB,LOCK_EX); |
|
| if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) { |
|
| foreach $id (keys(%{ $do_save_item{$name} })) { |
|
| eval <<'EVALBLOCK'; |
|
| $hash{$id.'.time'}=$$cache{$id.'.time'}; |
|
| $hash{$id}=freeze({'item'=>$$cache{$id}}); |
|
| if (exists($$cache{$id.'.file'})) { |
|
| $hash{$id.'.file'}=freeze({'item'=>$$cache{$id.'.file'}}); |
|
| } |
|
| EVALBLOCK |
|
| if ($@) { |
|
| &logthis("<font color='red'>save_cache blew up :$@:$name</font>"); |
|
| unlink($filename); |
|
| last; |
|
| } |
|
| } |
|
| } else { |
|
| if (-e $filename) { |
|
| &logthis("Unable to tie hash (save cache): $name ($!)"); |
|
| unlink($filename); |
|
| } |
|
| } |
|
| untie(%hash); |
|
| flock(DB,LOCK_UN); |
|
| close(DB); |
|
| &logthis("save_cache $name took ".(&Time::HiRes::time()-$starttime)); |
|
| } |
|
| undef(%do_save); |
|
| undef(%do_save_item); |
|
| |
|
| } |
|
| |
|
| sub load_cache_item { |
|
| my ($cache,$name,$id,$time)=@_; |
|
| if ($disk_caching_disabled) { return; } |
|
| my $starttime=&Time::HiRes::time(); |
|
| # &logthis("Before Loading $name for $id size is ".scalar(%$cache)); |
|
| my %hash; |
|
| my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db"; |
|
| if (!-e $filename) { return; } |
|
| open(DB,">$filename.lock"); |
|
| flock(DB,LOCK_SH); |
|
| if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) { |
|
| eval <<'EVALBLOCK'; |
|
| if (!%$cache) { |
|
| my $count; |
|
| while (my ($key,$value)=each(%hash)) { |
|
| $count++; |
|
| if ($key =~ /\.time$/) { |
|
| $$cache{$key}=$value; |
|
| } else { |
|
| my $hashref=thaw($value); |
|
| $$cache{$key}=$hashref->{'item'}; |
|
| } |
|
| } |
|
| # &logthis("Initial load: $count"); |
|
| } else { |
|
| if (($$cache{$id.'.time'}+$time) < time) { |
|
| $$cache{$id.'.time'}=$hash{$id.'.time'}; |
|
| { |
|
| my $hashref=thaw($hash{$id}); |
|
| $$cache{$id}=$hashref->{'item'}; |
|
| } |
|
| if (exists($hash{$id.'.file'})) { |
|
| my $hashref=thaw($hash{$id.'.file'}); |
|
| $$cache{$id.'.file'}=$hashref->{'item'}; |
|
| } |
|
| } |
|
| } |
|
| EVALBLOCK |
|
| if ($@) { |
|
| &logthis("<font color='red'>load_cache blew up :$@:$name</font>"); |
|
| unlink($filename); |
|
| } |
|
| } else { |
|
| if (-e $filename) { |
|
| &logthis("Unable to tie hash (load cache item): $name ($!)"); |
|
| unlink($filename); |
|
| } |
|
| } |
|
| untie(%hash); |
|
| flock(DB,LOCK_UN); |
|
| close(DB); |
|
| # &logthis("After Loading $name size is ".scalar(%$cache)); |
|
| # &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime)); |
|
| } |
} |
| |
|
| # ------------------------------------- Read an entry from a user's environment |
# ------------------------------------- Read an entry from a user's environment |
| |
|
| sub userenvironment { |
sub userenvironment { |
|
Line 1076 sub getversion {
|
Line 953 sub getversion {
|
| |
|
| sub currentversion { |
sub currentversion { |
| my $fname=shift; |
my $fname=shift; |
| my ($result,$cached)=&is_cached(\%resversioncache,$fname,'resversion',600); |
my ($result,$cached)=&is_cached_new('resversion',$fname); |
| if (defined($cached)) { return $result; } |
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/; |
|
Line 1089 sub currentversion {
|
Line 966 sub currentversion {
|
| if (($answer eq 'con_lost') || ($answer eq 'rejected')) { |
if (($answer eq 'con_lost') || ($answer eq 'rejected')) { |
| return -1; |
return -1; |
| } |
} |
| return &do_cache(\%resversioncache,$fname,$answer,'resversion'); |
return &do_cache_new('resversion',$fname,$answer,600); |
| } |
} |
| |
|
| # ----------------------------- Subscribe to a resource, return URL if possible |
# ----------------------------- Subscribe to a resource, return URL if possible |
|
Line 1117 sub subscribe {
|
Line 994 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; } |
if ($filename=~m|^/home/httpd/html/adm/|) { return 'ok'; } |
| if ($filename=~m|^/home/httpd/html/lonUsers/|) { return OK; } |
if ($filename=~m|^/home/httpd/html/lonUsers/|) { return 'ok'; } |
| if ($filename=~m|^/home/httpd/html/userfiles/| or |
if ($filename=~m|^/home/httpd/html/userfiles/| or |
| $filename=~m|^/*uploaded/|) { |
$filename=~m -^/*(uploaded|editupload)/-) { |
| return &repcopy_userfile($filename); |
return &repcopy_userfile($filename); |
| } |
} |
| $filename=~s/[\n\r]//g; |
$filename=~s/[\n\r]//g; |
| my $transname="$filename.in.transfer"; |
my $transname="$filename.in.transfer"; |
| if ((-e $filename) || (-e $transname)) { return OK; } |
if ((-e $filename) || (-e $transname)) { return 'ok'; } |
| my $remoteurl=subscribe($filename); |
my $remoteurl=subscribe($filename); |
| if ($remoteurl =~ /^con_lost by/) { |
if ($remoteurl =~ /^con_lost by/) { |
| &logthis("Subscribe returned $remoteurl: $filename"); |
&logthis("Subscribe returned $remoteurl: $filename"); |
| return HTTP_SERVICE_UNAVAILABLE; |
return 'unavailable'; |
| } elsif ($remoteurl eq 'not_found') { |
} elsif ($remoteurl eq 'not_found') { |
| #&logthis("Subscribe returned not_found: $filename"); |
#&logthis("Subscribe returned not_found: $filename"); |
| return HTTP_NOT_FOUND; |
return 'not_found'; |
| } elsif ($remoteurl =~ /^rejected by/) { |
} elsif ($remoteurl =~ /^rejected by/) { |
| &logthis("Subscribe returned $remoteurl: $filename"); |
&logthis("Subscribe returned $remoteurl: $filename"); |
| return FORBIDDEN; |
return 'forbidden'; |
| } elsif ($remoteurl eq 'directory') { |
} elsif ($remoteurl eq 'directory') { |
| return OK; |
return 'ok'; |
| } else { |
} else { |
| my $author=$filename; |
my $author=$filename; |
| $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; |
$author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; |
|
Line 1148 sub repcopy {
|
Line 1025 sub repcopy {
|
| 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 "$perlvar{'lonDocRoot'}/res") { |
| &logthis("Malconfiguration for replication: $filename"); |
&logthis("Malconfiguration for replication: $filename"); |
| return HTTP_BAD_REQUEST; |
return 'bad_request'; |
| } |
} |
| my $count; |
my $count; |
| for ($count=5;$count<$#parts;$count++) { |
for ($count=5;$count<$#parts;$count++) { |
|
Line 1165 sub repcopy {
|
Line 1042 sub repcopy {
|
| my $message=$response->status_line; |
my $message=$response->status_line; |
| &logthis("<font color=blue>WARNING:" |
&logthis("<font color=blue>WARNING:" |
| ." LWP get: $message: $filename</font>"); |
." LWP get: $message: $filename</font>"); |
| return HTTP_SERVICE_UNAVAILABLE; |
return 'unavailable'; |
| } else { |
} else { |
| if ($remoteurl!~/\.meta$/) { |
if ($remoteurl!~/\.meta$/) { |
| my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta'); |
my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta'); |
|
Line 1177 sub repcopy {
|
Line 1054 sub repcopy {
|
| } |
} |
| } |
} |
| rename($transname,$filename); |
rename($transname,$filename); |
| return OK; |
return 'ok'; |
| } |
} |
| } |
} |
| } |
} |
|
Line 1186 sub repcopy {
|
Line 1063 sub repcopy {
|
| # ------------------------------------------------ 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'})) { |
| |
$form{'LONCAPA_INTERNAL_no_discussion'}='true'; |
| |
} |
| my $output=($filelink=~/^http\:/?&externalssi($filelink): |
my $output=($filelink=~/^http\:/?&externalssi($filelink): |
| &ssi($filelink,%form)); |
&ssi($filelink,%form)); |
| $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+// END LON-CAPA Internal\s*(-->)?\s||gs; |
$output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+// END LON-CAPA Internal\s*(-->)?\s||gs; |
|
Line 1319 sub process_coursefile {
|
Line 1199 sub process_coursefile {
|
| return $fetchresult; |
return $fetchresult; |
| } |
} |
| |
|
| # --------------- Take an uploaded file and put it into the userfiles directory |
|
| # input: name of form element, coursedoc=1 means this is for the course |
|
| # output: url of file in userspace |
|
| |
|
| sub clean_filename { |
sub clean_filename { |
| my ($fname)=@_; |
my ($fname)=@_; |
| # Replace Windows backslashes by forward slashes |
# Replace Windows backslashes by forward slashes |
|
Line 1339 sub clean_filename {
|
Line 1215 sub clean_filename {
|
| return $fname; |
return $fname; |
| } |
} |
| |
|
| |
# --------------- Take an uploaded file and put it into the userfiles directory |
| |
# input: name of form element, coursedoc=1 means this is for the course |
| |
# output: url of file in userspace |
| |
|
| |
|
| sub userfileupload { |
sub userfileupload { |
| my ($formname,$coursedoc,$subdir)=@_; |
my ($formname,$coursedoc,$subdir)=@_; |
| if (!defined($subdir)) { $subdir='unknown'; } |
if (!defined($subdir)) { $subdir='unknown'; } |
|
Line 1588 sub courseacclog {
|
Line 1469 sub courseacclog {
|
| 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|page)$/) { |
if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|page)$/) { |
| $what.=':POST'; |
$what.=':POST'; |
| |
# FIXME: Probably ought to escape things.... |
| foreach (keys %ENV) { |
foreach (keys %ENV) { |
| if ($_=~/^form\.(.*)/) { |
if ($_=~/^form\.(.*)/) { |
| $what.=':'.$1.'='.$ENV{$_}; |
$what.=':'.$1.'='.$ENV{$_}; |
| } |
} |
| } |
} |
| |
} elsif ($fnsymb =~ m:^/adm/searchcat:) { |
| |
# FIXME: We should not be depending on a form parameter that someone |
| |
# editing lonsearchcat.pm might change in the future. |
| |
if ($ENV{'form.phase'} eq 'course_search') { |
| |
$what.= ':POST'; |
| |
# FIXME: Probably ought to escape things.... |
| |
foreach my $element ('courseexp','crsfulltext','crsrelated', |
| |
'crsdiscuss') { |
| |
$what.=':'.$element.'='.$ENV{'form.'.$element}; |
| |
} |
| |
} |
| } |
} |
| &courselog($what); |
&courselog($what); |
| } |
} |
|
Line 1746 sub get_first_access {
|
Line 1639 sub get_first_access {
|
| my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); |
my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::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') { $res=$map; } |
if ($type eq 'map') { |
| my %times=&get('firstaccesstimes',[$res],$udom,$uname); |
$res=&symbread($map); |
| return $times{$res}; |
} else { |
| |
$res=$symb; |
| |
} |
| |
my %times=&get('firstaccesstimes',["$courseid\0$res"],$udom,$uname); |
| |
return $times{"$courseid\0$res"}; |
| } |
} |
| |
|
| sub set_first_access { |
sub set_first_access { |
| my ($type)=@_; |
my ($type)=@_; |
| my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); |
my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); |
| my ($map,$id,$res)=&decode_symb($symb); |
my ($map,$id,$res)=&decode_symb($symb); |
| if ($type eq 'map') { $res=$map; } |
if ($type eq 'map') { |
| my $firstaccess=&get_first_access($type); |
$res=&symbread($map); |
| |
} else { |
| |
$res=$symb; |
| |
} |
| |
my $firstaccess=&get_first_access($type,$symb); |
| if (!$firstaccess) { |
if (!$firstaccess) { |
| return &put('firstaccesstimes',{$res=>time},$udom,$uname); |
return &put('firstaccesstimes',{"$courseid\0$res"=>time},$udom,$uname); |
| } |
} |
| return 'already_set'; |
return 'already_set'; |
| } |
} |
|
Line 1816 sub checkin {
|
Line 1717 sub checkin {
|
| my $now=time; |
my $now=time; |
| my ($ta,$tb,$lonhost)=split(/\*/,$token); |
my ($ta,$tb,$lonhost)=split(/\*/,$token); |
| $lonhost=~tr/A-Z/a-z/; |
$lonhost=~tr/A-Z/a-z/; |
| my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb; |
my $dtoken=$ta.'_'.$hostname{$lonhost}.'_'.$tb; |
| $dtoken=~s/\W/\_/g; |
$dtoken=~s/\W/\_/g; |
| my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)= |
my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)= |
| split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost))); |
split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost))); |
|
Line 2099 sub tmpreset {
|
Line 2000 sub tmpreset {
|
| $namespace=~s/\//\_/g; |
$namespace=~s/\//\_/g; |
| $namespace=~s/\W//g; |
$namespace=~s/\W//g; |
| |
|
| #FIXME needs to do something for /pub resources |
|
| 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') { |
| |
$stuname=$ENV{'REMOTE_ADDR'}; |
| |
} |
| my $path=$perlvar{'lonDaemons'}.'/tmp'; |
my $path=$perlvar{'lonDaemons'}.'/tmp'; |
| my %hash; |
my %hash; |
| if (tie(%hash,'GDBM_File', |
if (tie(%hash,'GDBM_File', |
|
Line 2134 sub tmpstore {
|
Line 2037 sub tmpstore {
|
| } |
} |
| $namespace=~s/\//\_/g; |
$namespace=~s/\//\_/g; |
| $namespace=~s/\W//g; |
$namespace=~s/\W//g; |
| #FIXME needs to do something for /pub resources |
|
| 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') { |
| |
$stuname=$ENV{'REMOTE_ADDR'}; |
| |
} |
| my $now=time; |
my $now=time; |
| my %hash; |
my %hash; |
| my $path=$perlvar{'lonDaemons'}.'/tmp'; |
my $path=$perlvar{'lonDaemons'}.'/tmp'; |
|
Line 2148 sub tmpstore {
|
Line 2053 sub tmpstore {
|
| my $allkeys=''; |
my $allkeys=''; |
| foreach my $key (keys(%$storehash)) { |
foreach my $key (keys(%$storehash)) { |
| $allkeys.=$key.':'; |
$allkeys.=$key.':'; |
| $hash{"$version:$symb:$key"}=$$storehash{$key}; |
$hash{"$version:$symb:$key"}=&freeze_escape($$storehash{$key}); |
| } |
} |
| $hash{"$version:$symb:timestamp"}=$now; |
$hash{"$version:$symb:timestamp"}=$now; |
| $allkeys.='timestamp'; |
$allkeys.='timestamp'; |
|
Line 2175 sub tmprestore {
|
Line 2080 sub tmprestore {
|
| $symb=escape($symb); |
$symb=escape($symb); |
| |
|
| if (!$namespace) { $namespace=$ENV{'request.state'}; } |
if (!$namespace) { $namespace=$ENV{'request.state'}; } |
| #FIXME needs to do something for /pub resources |
|
| 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') { |
| |
$stuname=$ENV{'REMOTE_ADDR'}; |
| |
} |
| my %returnhash; |
my %returnhash; |
| $namespace=~s/\//\_/g; |
$namespace=~s/\//\_/g; |
| $namespace=~s/\W//g; |
$namespace=~s/\W//g; |
|
Line 2196 sub tmprestore {
|
Line 2103 sub tmprestore {
|
| my $key; |
my $key; |
| $returnhash{"$scope:keys"}=$vkeys; |
$returnhash{"$scope:keys"}=$vkeys; |
| foreach $key (@keys) { |
foreach $key (@keys) { |
| $returnhash{"$scope:$key"}=$hash{"$scope:$symb:$key"}; |
$returnhash{"$scope:$key"}=&thaw_unescape($hash{"$scope:$symb:$key"}); |
| $returnhash{"$key"}=$hash{"$scope:$symb:$key"}; |
$returnhash{"$key"}=&thaw_unescape($hash{"$scope:$symb:$key"}); |
| } |
} |
| } |
} |
| if (!(untie(%hash))) { |
if (!(untie(%hash))) { |
|
Line 2238 sub store {
|
Line 2145 sub store {
|
| |
|
| my $namevalue=''; |
my $namevalue=''; |
| foreach (keys %$storehash) { |
foreach (keys %$storehash) { |
| $namevalue.=escape($_).'='.escape($$storehash{$_}).'&'; |
$namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; |
| } |
} |
| $namevalue=~s/\&$//; |
$namevalue=~s/\&$//; |
| &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue); |
&courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue); |
|
Line 2274 sub cstore {
|
Line 2181 sub cstore {
|
| |
|
| my $namevalue=''; |
my $namevalue=''; |
| foreach (keys %$storehash) { |
foreach (keys %$storehash) { |
| $namevalue.=escape($_).'='.escape($$storehash{$_}).'&'; |
$namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; |
| } |
} |
| $namevalue=~s/\&$//; |
$namevalue=~s/\&$//; |
| &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue); |
&courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue); |
|
Line 2308 sub restore {
|
Line 2215 sub restore {
|
| my %returnhash=(); |
my %returnhash=(); |
| foreach (split(/\&/,$answer)) { |
foreach (split(/\&/,$answer)) { |
| my ($name,$value)=split(/\=/,$_); |
my ($name,$value)=split(/\=/,$_); |
| $returnhash{&unescape($name)}=&unescape($value); |
$returnhash{&unescape($name)}=&thaw_unescape($value); |
| } |
} |
| my $version; |
my $version; |
| for ($version=1;$version<=$returnhash{'version'};$version++) { |
for ($version=1;$version<=$returnhash{'version'};$version++) { |
|
Line 2364 sub privileged {
|
Line 2271 sub privileged {
|
| my $now=time; |
my $now=time; |
| if ($rolesdump ne '') { |
if ($rolesdump ne '') { |
| foreach (split(/&/,$rolesdump)) { |
foreach (split(/&/,$rolesdump)) { |
| if ($_!~/^rolesdef\&/) { |
if ($_!~/^rolesdef_/) { |
| my ($area,$role)=split(/=/,$_); |
my ($area,$role)=split(/=/,$_); |
| $area=~s/\_\w\w$//; |
$area=~s/\_\w\w$//; |
| my ($trole,$tend,$tstart)=split(/_/,$role); |
my ($trole,$tend,$tstart)=split(/_/,$role); |
|
Line 2396 sub rolesinit {
|
Line 2303 sub rolesinit {
|
| |
|
| if ($rolesdump ne '') { |
if ($rolesdump ne '') { |
| foreach (split(/&/,$rolesdump)) { |
foreach (split(/&/,$rolesdump)) { |
| if ($_!~/^rolesdef\&/) { |
if ($_!~/^rolesdef_/) { |
| my ($area,$role)=split(/=/,$_); |
my ($area,$role)=split(/=/,$_); |
| $area=~s/\_\w\w$//; |
$area=~s/\_\w\w$//; |
| my ($trole,$tend,$tstart)=split(/_/,$role); |
|
| |
my ($trole,$tend,$tstart); |
| |
if ($role=~/^cr/) { |
| |
($trole,my $trest)=($role=~m|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$|); |
| |
($tend,$tstart)=split('_',$trest); |
| |
} else { |
| |
($trole,$tend,$tstart)=split(/_/,$role); |
| |
} |
| $userroles.=&set_arearole($trole,$area,$tstart,$tend,$domain,$username); |
$userroles.=&set_arearole($trole,$area,$tstart,$tend,$domain,$username); |
| if (($tend!=0) && ($tend<$now)) { $trole=''; } |
if (($tend!=0) && ($tend<$now)) { $trole=''; } |
| if (($tstart!=0) && ($tstart>$now)) { $trole=''; } |
if (($tstart!=0) && ($tstart>$now)) { $trole=''; } |
|
Line 2692 sub putstore {
|
Line 2606 sub putstore {
|
| my $key = $1.':keys:'.$2; |
my $key = $1.':keys:'.$2; |
| $allitems{$key} .= $3.':'; |
$allitems{$key} .= $3.':'; |
| } |
} |
| $items.=$_.'='.&escape($$storehash{$_}).'&'; |
$items.=$_.'='.&freeze_escape($$storehash{$_}).'&'; |
| } |
} |
| foreach (keys %allitems) { |
foreach (keys %allitems) { |
| $allitems{$_} =~ s/\:$//; |
$allitems{$_} =~ s/\:$//; |
|
Line 2793 sub allowed {
|
Line 2707 sub allowed {
|
| |
|
| # Free bre access to user's own portfolio contents |
# Free bre access to user's own portfolio contents |
| my ($space,$domain,$name,$dir)=split('/',$uri); |
my ($space,$domain,$name,$dir)=split('/',$uri); |
| if (('uploaded' eq $space) && ($ENV{'user.name'} eq $name) && |
if (($space=~/^(uploaded|ediupload)$/) && ($ENV{'user.name'} eq $name) && |
| ($ENV{'user.domain'} eq $domain) && ('portfolio' eq $dir)) { |
($ENV{'user.domain'} eq $domain) && ('portfolio' eq $dir)) { |
| return 'F'; |
return 'F'; |
| } |
} |
|
Line 2862 sub allowed {
|
Line 2776 sub allowed {
|
| } |
} |
| |
|
| # URI is an uploaded document for this course |
# URI is an uploaded document for this course |
| |
# not allowing 'edit' access (editupload) to uploaded course docs |
| if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) { |
if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) { |
| my $refuri=$ENV{'httpref.'.$orguri}; |
my $refuri=$ENV{'httpref.'.$orguri}; |
| if ($refuri) { |
if ($refuri) { |
|
Line 3360 sub auto_instcode_format {
|
Line 3274 sub auto_instcode_format {
|
| my $courses = ''; |
my $courses = ''; |
| my $homeserver; |
my $homeserver; |
| if ($caller eq 'global') { |
if ($caller eq 'global') { |
| $homeserver = $perlvar{'lonHostID'}; |
foreach my $tryserver (keys %libserv) { |
| |
if ($hostdom{$tryserver} eq $codedom) { |
| |
$homeserver = $tryserver; |
| |
last; |
| |
} |
| |
} |
| |
if (($ENV{'user.name'}) && ($ENV{'user.domain'} eq $codedom)) { |
| |
$homeserver = &homeserver($ENV{'user.name'},$codedom); |
| |
} |
| } else { |
} else { |
| $homeserver = &homeserver($caller,$codedom); |
$homeserver = &homeserver($caller,$codedom); |
| } |
} |
| my $host=$hostname{$homeserver}; |
|
| foreach (keys %{$instcodes}) { |
foreach (keys %{$instcodes}) { |
| $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&'; |
$courses .= &escape($_).'='.&escape($$instcodes{$_}).'&'; |
| } |
} |
|
Line 3555 sub modifyuser {
|
Line 3476 sub modifyuser {
|
| 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) { $names{'notification'} = $email; |
if ($email) { |
| $names{'critnotification'} = $email; } |
$email=~s/[^\w\@\.\-\,]//gs; |
| |
if ($email=~/\@/) { $names{'notification'} = $email; |
| |
$names{'critnotification'} = $email; |
| |
$names{'permanentemail'} = $email; } |
| |
} |
| 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; } |
| &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '. |
&logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '. |
|
Line 3975 sub dirlist {
|
Line 3899 sub dirlist {
|
| |
|
| if($udom) { |
if($udom) { |
| if($uname) { |
if($uname) { |
| my $listing=reply('ls:'.$dirRoot.'/'.$uri, |
my $listing=reply('ls2:'.$dirRoot.'/'.$uri, |
| homeserver($uname,$udom)); |
homeserver($uname,$udom)); |
| return split(/:/,$listing); |
my @listing_results; |
| |
if ($listing eq 'unknown_cmd') { |
| |
$listing=reply('ls:'.$dirRoot.'/'.$uri, |
| |
homeserver($uname,$udom)); |
| |
@listing_results = split(/:/,$listing); |
| |
} else { |
| |
@listing_results = map { &unescape($_); } split(/:/,$listing); |
| |
} |
| |
return @listing_results; |
| } elsif(!defined($alternateDirectoryRoot)) { |
} elsif(!defined($alternateDirectoryRoot)) { |
| my $tryserver; |
my $tryserver; |
| my %allusers=(); |
my %allusers=(); |
| foreach $tryserver (keys %libserv) { |
foreach $tryserver (keys %libserv) { |
| if($hostdom{$tryserver} eq $udom) { |
if($hostdom{$tryserver} eq $udom) { |
| my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. |
my $listing=reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'. |
| $udom, $tryserver); |
$udom, $tryserver); |
| if (($listing ne 'no_such_dir') && ($listing ne 'empty') |
my @listing_results; |
| && ($listing ne 'con_lost')) { |
if ($listing eq 'unknown_cmd') { |
| foreach (split(/:/,$listing)) { |
$listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'. |
| |
$udom, $tryserver); |
| |
@listing_results = split(/:/,$listing); |
| |
} else { |
| |
@listing_results = |
| |
map { &unescape($_); } split(/:/,$listing); |
| |
} |
| |
if ($listing_results[0] ne 'no_such_dir' && |
| |
$listing_results[0] ne 'empty' && |
| |
$listing_results[0] ne 'con_lost') { |
| |
foreach (@listing_results) { |
| my ($entry,@stat)=split(/&/,$_); |
my ($entry,@stat)=split(/&/,$_); |
| $allusers{$entry}=1; |
$allusers{$entry}=1; |
| } |
} |
|
Line 4115 sub condval {
|
Line 4057 sub condval {
|
| sub devalidatecourseresdata { |
sub devalidatecourseresdata { |
| my ($coursenum,$coursedomain)=@_; |
my ($coursenum,$coursedomain)=@_; |
| my $hashid=$coursenum.':'.$coursedomain; |
my $hashid=$coursenum.':'.$coursedomain; |
| &devalidate_cache(\%courseresdatacache,$hashid,'courseres'); |
&devalidate_cache_new('courseres',$hashid); |
| } |
} |
| |
|
| # --------------------------------------------------- Course Resourcedata Query |
# --------------------------------------------------- Course Resourcedata Query |
|
Line 4124 sub courseresdata {
|
Line 4066 sub courseresdata {
|
| my ($coursenum,$coursedomain,@which)=@_; |
my ($coursenum,$coursedomain,@which)=@_; |
| my $coursehom=&homeserver($coursenum,$coursedomain); |
my $coursehom=&homeserver($coursenum,$coursedomain); |
| my $hashid=$coursenum.':'.$coursedomain; |
my $hashid=$coursenum.':'.$coursedomain; |
| my ($result,$cached)=&is_cached(\%courseresdatacache,$hashid,'courseres'); |
my ($result,$cached)=&is_cached_new('courseres',$hashid); |
| unless (defined($cached)) { |
unless (defined($cached)) { |
| my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum); |
my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum); |
| $result=\%dumpreply; |
$result=\%dumpreply; |
| my ($tmp) = keys(%dumpreply); |
my ($tmp) = keys(%dumpreply); |
| if ($tmp !~ /^(con_lost|error|no_such_host)/i) { |
if ($tmp !~ /^(con_lost|error|no_such_host)/i) { |
| &do_cache(\%courseresdatacache,$hashid,$result,'courseres'); |
&do_cache_new('courseres',$hashid,$result,600); |
| } elsif ($tmp =~ /^(con_lost|no_such_host)/) { |
} elsif ($tmp =~ /^(con_lost|no_such_host)/) { |
| return $tmp; |
return $tmp; |
| } elsif ($tmp =~ /^(error)/) { |
} elsif ($tmp =~ /^(error)/) { |
| $result=undef; |
$result=undef; |
| &do_cache(\%courseresdatacache,$hashid,$result,'courseres'); |
&do_cache_new('courseres',$hashid,$result,600); |
| } |
} |
| } |
} |
| foreach my $item (@which) { |
foreach my $item (@which) { |
|
Line 4289 sub EXT {
|
Line 4231 sub EXT {
|
| if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) { |
if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) { |
| if (!$symbparm) { $symbparm=&symbread(); } |
if (!$symbparm) { $symbparm=&symbread(); } |
| } |
} |
| |
my ($courselevelm,$courselevel); |
| if ($symbparm && defined($courseid) && |
if ($symbparm && defined($courseid) && |
| $courseid eq $ENV{'request.course.id'}) { |
$courseid eq $ENV{'request.course.id'}) { |
| |
|
|
Line 4316 sub EXT {
|
Line 4259 sub EXT {
|
| my $seclevelr=$courseid.'.['.$section.'].'.$symbparm; |
my $seclevelr=$courseid.'.['.$section.'].'.$symbparm; |
| my $seclevelm=$courseid.'.['.$section.'].'.$mapparm; |
my $seclevelm=$courseid.'.['.$section.'].'.$mapparm; |
| |
|
| my $courselevel=$courseid.'.'.$spacequalifierrest; |
$courselevel=$courseid.'.'.$spacequalifierrest; |
| my $courselevelr=$courseid.'.'.$symbparm; |
my $courselevelr=$courseid.'.'.$symbparm; |
| my $courselevelm=$courseid.'.'.$mapparm; |
$courselevelm=$courseid.'.'.$mapparm; |
| |
|
| # ----------------------------------------------------------- first, check user |
# ----------------------------------------------------------- first, check user |
| #most student don\'t have any data set, check if there is some data |
#most student don\'t have any data set, check if there is some data |
| if (! &EXT_cache_status($udom,$uname)) { |
if (! &EXT_cache_status($udom,$uname)) { |
| my $hashid="$udom:$uname"; |
my $hashid="$udom:$uname"; |
| my ($result,$cached)=&is_cached(\%userresdatacache,$hashid, |
my ($result,$cached)=&is_cached_new('userres',$hashid); |
| 'userres'); |
|
| if (!defined($cached)) { |
if (!defined($cached)) { |
| my %resourcedata=&dump('resourcedata',$udom,$uname); |
my %resourcedata=&dump('resourcedata',$udom,$uname); |
| $result=\%resourcedata; |
$result=\%resourcedata; |
| &do_cache(\%userresdatacache,$hashid,$result,'userres'); |
&do_cache_new('userres',$hashid,$result); |
| } |
} |
| my ($tmp)=keys(%$result); |
my ($tmp)=keys(%$result); |
| if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { |
if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { |
|
Line 4354 sub EXT {
|
Line 4296 sub EXT {
|
| } |
} |
| } |
} |
| |
|
| # -------------------------------------------------------- second, check course |
# ------------------------------------------------ second, check some of course |
| |
|
| my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'}, |
my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'}, |
| $ENV{'course.'.$courseid.'.domain'}, |
$ENV{'course.'.$courseid.'.domain'}, |
| ($seclevelr,$seclevelm,$seclevel, |
($seclevelr,$seclevelm,$seclevel, |
| $courselevelr,$courselevelm, |
$courselevelr)); |
| $courselevel)); |
|
| if (defined($coursereply)) { return $coursereply; } |
if (defined($coursereply)) { return $coursereply; } |
| |
|
| # ------------------------------------------------------ third, check map parms |
# ------------------------------------------------------ third, check map parms |
|
Line 4374 sub EXT {
|
Line 4315 sub EXT {
|
| } |
} |
| if ($thisparm) { return $thisparm; } |
if ($thisparm) { return $thisparm; } |
| } |
} |
| # --------------------------------------------- last, look in resource metadata |
# ------------------------------------------ fourth, look in resource metadata |
| |
|
| $spacequalifierrest=~s/\./\_/; |
$spacequalifierrest=~s/\./\_/; |
| my $filename; |
my $filename; |
|
Line 4389 sub EXT {
|
Line 4330 sub EXT {
|
| $metadata=&metadata($filename,'parameter_'.$spacequalifierrest); |
$metadata=&metadata($filename,'parameter_'.$spacequalifierrest); |
| if (defined($metadata)) { return $metadata; } |
if (defined($metadata)) { return $metadata; } |
| |
|
| |
# ---------------------------------------------- fourth, look in rest pf course |
| |
if ($symbparm && defined($courseid) && |
| |
$courseid eq $ENV{'request.course.id'}) { |
| |
my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'}, |
| |
$ENV{'course.'.$courseid.'.domain'}, |
| |
($courselevelm,$courselevel)); |
| |
if (defined($coursereply)) { return $coursereply; } |
| |
} |
| # ------------------------------------------------------------------ Cascade up |
# ------------------------------------------------------------------ Cascade up |
| unless ($space eq '0') { |
unless ($space eq '0') { |
| my @parts=split(/_/,$space); |
my @parts=split(/_/,$space); |
|
Line 4431 sub packages_tab_default {
|
Line 4380 sub packages_tab_default {
|
| if (defined($packagetab{"$pack_type&$name&default"})) { |
if (defined($packagetab{"$pack_type&$name&default"})) { |
| return $packagetab{"$pack_type&$name&default"}; |
return $packagetab{"$pack_type&$name&default"}; |
| } |
} |
| |
if ($pack_type eq 'part') { $pack_part='0'; } |
| if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) { |
if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) { |
| return $packagetab{$pack_type."_".$pack_part."&$name&default"}; |
return $packagetab{$pack_type."_".$pack_part."&$name&default"}; |
| } |
} |
|
Line 4456 sub add_prefix_and_part {
|
Line 4406 sub add_prefix_and_part {
|
| |
|
| # ---------------------------------------------------------------- Get metadata |
# ---------------------------------------------------------------- Get metadata |
| |
|
| |
my %metaentry; |
| sub metadata { |
sub metadata { |
| my ($uri,$what,$liburi,$prefix,$depthcount)=@_; |
my ($uri,$what,$liburi,$prefix,$depthcount)=@_; |
| $uri=&declutter($uri); |
$uri=&declutter($uri); |
|
Line 4475 sub metadata {
|
Line 4426 sub metadata {
|
| # Everything is cached by the main uri, libraries are never directly cached |
# Everything is cached by the main uri, libraries are never directly cached |
| # |
# |
| if (!defined($liburi)) { |
if (!defined($liburi)) { |
| my ($result,$cached)=&is_cached(\%metacache,$uri,'meta'); |
my ($result,$cached)=&is_cached_new('meta',$uri); |
| if (defined($cached)) { return $result->{':'.$what}; } |
if (defined($cached)) { return $result->{':'.$what}; } |
| } |
} |
| { |
{ |
| # |
# |
| # 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}={}; |
| } |
# } |
| if ($liburi) { |
if ($liburi) { |
| $liburi=&declutter($liburi); |
$liburi=&declutter($liburi); |
| $filename=$liburi; |
$filename=$liburi; |
| } else { |
} else { |
| &devalidate_cache(\%metacache,$uri,'meta'); |
&devalidate_cache_new('meta',$uri); |
| |
undef(%metaentry); |
| } |
} |
| my %metathesekeys=(); |
my %metathesekeys=(); |
| unless ($filename=~/\.meta$/) { $filename.='.meta'; } |
unless ($filename=~/\.meta$/) { $filename.='.meta'; } |
| my $metastring; |
my $metastring; |
| if ($uri !~ m|^uploaded/|) { |
if ($uri !~ m -^(uploaded|editupload)/-) { |
| my $file=&filelocation('',&clutter($filename)); |
my $file=&filelocation('',&clutter($filename)); |
| push(@{$metacache{$uri.'.file'}},$file); |
#push(@{$metaentry{$uri.'.file'}},$file); |
| $metastring=&getfile($file); |
$metastring=&getfile($file); |
| } |
} |
| my $parser=HTML::LCParser->new(\$metastring); |
my $parser=HTML::LCParser->new(\$metastring); |
|
Line 4513 sub metadata {
|
Line 4465 sub metadata {
|
| if (defined($token->[2]->{'id'})) { |
if (defined($token->[2]->{'id'})) { |
| $keyroot.='_'.$token->[2]->{'id'}; |
$keyroot.='_'.$token->[2]->{'id'}; |
| } |
} |
| if ($metacache{$uri}->{':packages'}) { |
if ($metaentry{':packages'}) { |
| $metacache{$uri}->{':packages'}.=','.$package.$keyroot; |
$metaentry{':packages'}.=','.$package.$keyroot; |
| } else { |
} else { |
| $metacache{$uri}->{':packages'}=$package.$keyroot; |
$metaentry{':packages'}=$package.$keyroot; |
| } |
} |
| foreach (keys %packagetab) { |
foreach (keys %packagetab) { |
| my $part=$keyroot; |
my $part=$keyroot; |
|
Line 4538 sub metadata {
|
Line 4490 sub metadata {
|
| if ($subp eq 'display') { |
if ($subp eq 'display') { |
| $value.=' [Part: '.$part.']'; |
$value.=' [Part: '.$part.']'; |
| } |
} |
| $metacache{$uri}->{':'.$unikey.'.part'}=$part; |
$metaentry{':'.$unikey.'.part'}=$part; |
| $metathesekeys{$unikey}=1; |
$metathesekeys{$unikey}=1; |
| unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) { |
unless (defined($metaentry{':'.$unikey.'.'.$subp})) { |
| $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value; |
$metaentry{':'.$unikey.'.'.$subp}=$value; |
| } |
} |
| if (defined($metacache{$uri}->{':'.$unikey.'.default'})) { |
if (defined($metaentry{':'.$unikey.'.default'})) { |
| $metacache{$uri}->{':'.$unikey}= |
$metaentry{':'.$unikey}= |
| $metacache{$uri}->{':'.$unikey.'.default'}; |
$metaentry{':'.$unikey.'.default'}; |
| } |
} |
| } |
} |
| } |
} |
|
Line 4578 sub metadata {
|
Line 4530 sub metadata {
|
| foreach (sort(split(/\,/,&metadata($uri,'keys', |
foreach (sort(split(/\,/,&metadata($uri,'keys', |
| $location,$unikey, |
$location,$unikey, |
| $depthcount+1)))) { |
$depthcount+1)))) { |
| $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_}; |
$metaentry{':'.$_}=$metaentry{':'.$_}; |
| $metathesekeys{$_}=1; |
$metathesekeys{$_}=1; |
| } |
} |
| } |
} |
|
Line 4589 sub metadata {
|
Line 4541 sub metadata {
|
| } |
} |
| $metathesekeys{$unikey}=1; |
$metathesekeys{$unikey}=1; |
| foreach (@{$token->[3]}) { |
foreach (@{$token->[3]}) { |
| $metacache{$uri}->{':'.$unikey.'.'.$_}=$token->[2]->{$_}; |
$metaentry{':'.$unikey.'.'.$_}=$token->[2]->{$_}; |
| } |
} |
| my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry)); |
my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry)); |
| my $default=$metacache{$uri}->{':'.$unikey.'.default'}; |
my $default=$metaentry{':'.$unikey.'.default'}; |
| if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) { |
if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) { |
| # 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 |
| $metacache{$uri}->{':'.$unikey}=$default; |
$metaentry{':'.$unikey}=$default; |
| } else { |
} else { |
| # either something interesting inside the tag or default |
# either something interesting inside the tag or default |
| # uninteresting |
# uninteresting |
| $metacache{$uri}->{':'.$unikey}=$internaltext; |
$metaentry{':'.$unikey}=$internaltext; |
| } |
} |
| # end of not-a-package not-a-library import |
# end of not-a-package not-a-library import |
| } |
} |
|
Line 4617 sub metadata {
|
Line 4569 sub metadata {
|
| &metadata_create_package_def($uri,$key,'extension_'.$extension, |
&metadata_create_package_def($uri,$key,'extension_'.$extension, |
| \%metathesekeys); |
\%metathesekeys); |
| } |
} |
| if (!exists($metacache{$uri}->{':packages'})) { |
if (!exists($metaentry{':packages'})) { |
| foreach my $key (sort(keys(%packagetab))) { |
foreach my $key (sort(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 4626 sub metadata {
|
Line 4578 sub metadata {
|
| } |
} |
| } |
} |
| # are there custom rights to evaluate |
# are there custom rights to evaluate |
| if ($metacache{$uri}->{':copyright'} eq 'custom') { |
if ($metaentry{':copyright'} eq 'custom') { |
| |
|
| # |
# |
| # Importing a rights file here |
# Importing a rights file here |
| # |
# |
| unless ($depthcount) { |
unless ($depthcount) { |
| my $location=$metacache{$uri}->{':customdistributionfile'}; |
my $location=$metaentry{':customdistributionfile'}; |
| my $dir=$filename; |
my $dir=$filename; |
| $dir=~s|[^/]*$||; |
$dir=~s|[^/]*$||; |
| $location=&filelocation($dir,$location); |
$location=&filelocation($dir,$location); |
| foreach (sort(split(/\,/,&metadata($uri,'keys', |
foreach (sort(split(/\,/,&metadata($uri,'keys', |
| $location,'_rights', |
$location,'_rights', |
| $depthcount+1)))) { |
$depthcount+1)))) { |
| $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_}; |
#$metaentry{':'.$_}=$metacache{$uri}->{':'.$_}; |
| $metathesekeys{$_}=1; |
$metathesekeys{$_}=1; |
| } |
} |
| } |
} |
| } |
} |
| $metacache{$uri}->{':keys'}=join(',',keys %metathesekeys); |
$metaentry{':keys'}=join(',',keys %metathesekeys); |
| &metadata_generate_part0(\%metathesekeys,$metacache{$uri},$uri); |
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); |
| $metacache{$uri}->{':allpossiblekeys'}=join(',',keys %metathesekeys); |
$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); |
| &do_cache(\%metacache,$uri,$metacache{$uri},'meta'); |
&do_cache_new('meta',$uri,\%metaentry); |
| # this is the end of "was not already recently cached |
# this is the end of "was not already recently cached |
| } |
} |
| return $metacache{$uri}->{':'.$what}; |
return $metaentry{':'.$what}; |
| } |
} |
| |
|
| sub metadata_create_package_def { |
sub metadata_create_package_def { |
|
Line 4658 sub metadata_create_package_def {
|
Line 4610 sub metadata_create_package_def {
|
| my ($pack,$name,$subp)=split(/\&/,$key); |
my ($pack,$name,$subp)=split(/\&/,$key); |
| if ($subp eq 'default') { next; } |
if ($subp eq 'default') { next; } |
| |
|
| if (defined($metacache{$uri}->{':packages'})) { |
if (defined($metaentry{':packages'})) { |
| $metacache{$uri}->{':packages'}.=','.$package; |
$metaentry{':packages'}.=','.$package; |
| } else { |
} else { |
| $metacache{$uri}->{':packages'}=$package; |
$metaentry{':packages'}=$package; |
| } |
} |
| my $value=$packagetab{$key}; |
my $value=$packagetab{$key}; |
| my $unikey; |
my $unikey; |
| $unikey='parameter_0_'.$name; |
$unikey='parameter_0_'.$name; |
| $metacache{$uri}->{':'.$unikey.'.part'}=0; |
$metaentry{':'.$unikey.'.part'}=0; |
| $$metathesekeys{$unikey}=1; |
$$metathesekeys{$unikey}=1; |
| unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) { |
unless (defined($metaentry{':'.$unikey.'.'.$subp})) { |
| $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value; |
$metaentry{':'.$unikey.'.'.$subp}=$value; |
| } |
} |
| if (defined($metacache{$uri}->{':'.$unikey.'.default'})) { |
if (defined($metaentry{':'.$unikey.'.default'})) { |
| $metacache{$uri}->{':'.$unikey}= |
$metaentry{':'.$unikey}= |
| $metacache{$uri}->{':'.$unikey.'.default'}; |
$metaentry{':'.$unikey.'.default'}; |
| } |
} |
| } |
} |
| |
|
|
Line 4711 sub gettitle {
|
Line 4663 sub gettitle {
|
| my $urlsymb=shift; |
my $urlsymb=shift; |
| my $symb=&symbread($urlsymb); |
my $symb=&symbread($urlsymb); |
| if ($symb) { |
if ($symb) { |
| my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600); |
my $key=$ENV{'request.course.id'}."\0".$symb; |
| |
my ($result,$cached)=&is_cached_new('title',$key); |
| if (defined($cached)) { |
if (defined($cached)) { |
| return $result; |
return $result; |
| } |
} |
|
Line 4726 sub gettitle {
|
Line 4679 sub gettitle {
|
| } |
} |
| $title=~s/\&colon\;/\:/gs; |
$title=~s/\&colon\;/\:/gs; |
| if ($title) { |
if ($title) { |
| return &do_cache(\%titlecache,$symb,$title,'title'); |
return &do_cache_new('title',$key,$title,600); |
| } |
} |
| $urlsymb=$url; |
$urlsymb=$url; |
| } |
} |
|
Line 4745 sub symblist {
|
Line 4698 sub symblist {
|
| 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 (keys %newhash) { |
foreach (keys %newhash) { |
| $hash{declutter($_)}=$mapname.'___'.&deversion($newhash{$_}); |
$hash{declutter($_)}=&encode_symb($mapname,$newhash{$_}->[1], |
| |
$newhash{$_}->[0]); |
| } |
} |
| if (untie(%hash)) { |
if (untie(%hash)) { |
| return 'ok'; |
return 'ok'; |
|
Line 4790 sub symbverify {
|
Line 4744 sub symbverify {
|
| if ( |
if ( |
| &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) |
&symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) |
| eq $symb) { |
eq $symb) { |
| $okay=1; |
if (($ENV{'request.role.adv'}) || |
| } |
$bighash{'encrypted_'.$_} eq $ENV{'request.enc'}) { |
| |
$okay=1; |
| |
} |
| |
} |
| } |
} |
| } |
} |
| untie(%bighash); |
untie(%bighash); |
|
Line 4832 sub decode_symb {
|
Line 4789 sub decode_symb {
|
| |
|
| sub fixversion { |
sub fixversion { |
| my $fn=shift; |
my $fn=shift; |
| if ($fn=~/^(adm|uploaded|public)/) { return $fn; } |
if ($fn=~/^(adm|uploaded|editupload|public)/) { return $fn; } |
| my %bighash; |
my %bighash; |
| my $uri=&clutter($fn); |
my $uri=&clutter($fn); |
| my $key=$ENV{'request.course.id'}.'_'.$uri; |
my $key=$ENV{'request.course.id'}.'_'.$uri; |
| # is this cached? |
# is this cached? |
| my ($result,$cached)=&is_cached(\%courseresversioncache,$key, |
my ($result,$cached)=&is_cached_new('courseresversion',$key); |
| 'courseresversion',600); |
|
| if (defined($cached)) { return $result; } |
if (defined($cached)) { return $result; } |
| # unfortunately not cached, or expired |
# unfortunately not cached, or expired |
| if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', |
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', |
|
Line 4852 sub fixversion {
|
Line 4808 sub fixversion {
|
| } |
} |
| untie %bighash; |
untie %bighash; |
| } |
} |
| return &do_cache |
return &do_cache_new('courseresversion',$key,&declutter($uri),600); |
| (\%courseresversioncache,$key,&declutter($uri),'courseresversion'); |
|
| } |
} |
| |
|
| sub deversion { |
sub deversion { |
|
Line 4888 sub symbread {
|
Line 4843 sub symbread {
|
| my $syval=''; |
my $syval=''; |
| if (($ENV{'request.course.fn'}) && ($thisfn)) { |
if (($ENV{'request.course.fn'}) && ($thisfn)) { |
| my $targetfn = $thisfn; |
my $targetfn = $thisfn; |
| if ( ($thisfn =~ m/^uploaded\//) && ($thisfn !~ m/\.(page|sequence)$/) ) { |
if ( ($thisfn =~ m/^(uploaded|editupload)\//) && ($thisfn !~ m/\.(page|sequence)$/) ) { |
| $targetfn = 'adm/wrapper/'.$thisfn; |
$targetfn = 'adm/wrapper/'.$thisfn; |
| } |
} |
| if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', |
if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', |
|
Line 4898 sub symbread {
|
Line 4853 sub symbread {
|
| } |
} |
| # ---------------------------------------------------------- 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; |
| } |
#} |
| } else { |
} else { |
| # ------------------------------------------------------- Was not in symb table |
# ------------------------------------------------------- Was not in symb table |
| if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', |
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', |
|
Line 4948 sub symbread {
|
Line 4903 sub symbread {
|
| } |
} |
| } |
} |
| if ($syval) { |
if ($syval) { |
| return $ENV{$cache_str}=&symbclean($syval.'___'.$thisfn); |
return $ENV{$cache_str}=$syval; |
| |
#return $ENV{$cache_str}=&symbclean($syval.'___'.$thisfn); |
| } |
} |
| } |
} |
| &appenv('request.ambiguous' => $thisfn); |
&appenv('request.ambiguous' => $thisfn); |
|
Line 5295 sub receipt {
|
Line 5251 sub receipt {
|
| |
|
| sub getfile { |
sub getfile { |
| my ($file) = @_; |
my ($file) = @_; |
| |
if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); } |
| if ($file =~ m|^/*uploaded/|) { $file=&filelocation("",$file); } |
|
| &repcopy($file); |
&repcopy($file); |
| return &readfile($file); |
return &readfile($file); |
| } |
} |
| |
|
| sub repcopy_userfile { |
sub repcopy_userfile { |
| my ($file)=@_; |
my ($file)=@_; |
| |
if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); } |
| if ($file =~ m|^/*uploaded/|) { $file=&filelocation("",$file); } |
if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; } |
| if ($file =~ m|^/home/httpd/html/lonUsers/|) { return OK; } |
|
| |
|
| my ($cdom,$cnum,$filename) = |
my ($cdom,$cnum,$filename) = |
| ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)|); |
($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)|); |
| my ($info,$rtncode); |
my ($info,$rtncode); |
|
Line 5329 sub repcopy_userfile {
|
Line 5282 sub repcopy_userfile {
|
| return -1; |
return -1; |
| } |
} |
| if ($info < $fileinfo[9]) { |
if ($info < $fileinfo[9]) { |
| return OK; |
return 'ok'; |
| } |
} |
| $info = ''; |
$info = ''; |
| $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode); |
$lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode); |
|
Line 5363 sub repcopy_userfile {
|
Line 5316 sub repcopy_userfile {
|
| open(FILE,">$file"); |
open(FILE,">$file"); |
| print FILE $info; |
print FILE $info; |
| close(FILE); |
close(FILE); |
| return OK; |
return 'ok'; |
| } |
} |
| |
|
| sub tokenwrapper { |
sub tokenwrapper { |
|
Line 5414 sub readfile {
|
Line 5367 sub readfile {
|
| } |
} |
| |
|
| sub filelocation { |
sub filelocation { |
| my ($dir,$file) = @_; |
my ($dir,$file) = @_; |
| my $location; |
my $location; |
| $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces |
$file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces |
| if ($file=~m:^/~:) { # is a contruction space reference |
if ($file=~m:^/~:) { # is a contruction space reference |
| $location = $file; |
$location = $file; |
| $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; |
$location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; |
| } elsif ($file=~/^\/*uploaded/) { # is an uploaded file |
} elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file |
| my ($udom,$uname,$filename)= |
my ($udom,$uname,$filename)= |
| ($file=~m|^/+uploaded/+([^/]+)/+([^/]+)/+(.*)$|); |
($file=~m -^/+(?:uploaded|editupload)/+([^/]+)/+([^/]+)/+(.*)$-); |
| my $home=&homeserver($uname,$udom); |
my $home=&homeserver($uname,$udom); |
| my $is_me=0; |
my $is_me=0; |
| 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=&Apache::loncommon::propath($udom,$uname). |
$location=&Apache::loncommon::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; |
| } |
} |
| } else { |
|
| $file=~s/^\Q$perlvar{'lonDocRoot'}\E//; |
|
| $file=~s:^/res/:/:; |
|
| if ( !( $file =~ m:^/:) ) { |
|
| $location = $dir. '/'.$file; |
|
| } else { |
} else { |
| $location = '/home/httpd/html/res'.$file; |
$file=~s/^\Q$perlvar{'lonDocRoot'}\E//; |
| |
$file=~s:^/res/:/:; |
| |
if ( !( $file =~ m:^/:) ) { |
| |
$location = $dir. '/'.$file; |
| |
} else { |
| |
$location = '/home/httpd/html/res'.$file; |
| |
} |
| } |
} |
| } |
$location=~s://+:/:g; # remove duplicate / |
| $location=~s://+:/:g; # remove duplicate / |
while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/.. |
| while ($location=~m:/\.\./:) {$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 { |
|
Line 5504 sub declutter {
|
Line 5457 sub declutter {
|
| |
|
| sub clutter { |
sub clutter { |
| my $thisfn='/'.&declutter(shift); |
my $thisfn='/'.&declutter(shift); |
| unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv|public)\//) { |
unless ($thisfn=~/^\/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)\//) { |
| $thisfn='/res'.$thisfn; |
$thisfn='/res'.$thisfn; |
| } |
} |
| return $thisfn; |
return $thisfn; |
|
Line 5562 sub correct_line_ends {
|
Line 5515 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',scalar(%badServerCache))); |
&logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%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',scalar(%homecache))); |
&logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache)))); |
| &logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache))); |
# &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache)))); |
| &logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache))); |
# &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache)))); |
| #1.1 only |
#1.1 only |
| &logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache))); |
# &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache)))); |
| &logthis(sprintf("%-20s is %s",'%getsectioncache',scalar(%getsectioncache))); |
# &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache)))); |
| &logthis(sprintf("%-20s is %s",'%courseresversioncache',scalar(%courseresversioncache))); |
# &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache)))); |
| &logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache))); |
# &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%resversioncache)))); |
| |
&logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered)))); |
| |
&logthis(sprintf("%-20s is %s",'kicks',$kicks)); |
| |
&logthis(sprintf("%-20s is %s",'hits',$hits)); |
| &flushcourselogs(); |
&flushcourselogs(); |
| &logthis("Shutting down"); |
&logthis("Shutting down"); |
| return DONE; |
return DONE; |
|
Line 5582 BEGIN {
|
Line 5538 BEGIN {
|
| # ----------------------------------- Read loncapa.conf and loncapa_apache.conf |
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf |
| unless ($readit) { |
unless ($readit) { |
| { |
{ |
| |
# FIXME: Use LONCAPA::Configuration::read_conf here and omit next block |
| open(my $config,"</etc/httpd/conf/loncapa.conf"); |
open(my $config,"</etc/httpd/conf/loncapa.conf"); |
| |
|
| while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
|
Line 5642 BEGIN {
|
Line 5599 BEGIN {
|
| while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
| next if ($configline =~ /^(\#|\s*$)/); |
next if ($configline =~ /^(\#|\s*$)/); |
| chomp($configline); |
chomp($configline); |
| my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline); |
my ($id,$domain,$role,$name)=split(/:/,$configline); |
| if ($id && $domain && $role && $name && $ip) { |
$name=~s/\s//g; |
| |
if ($id && $domain && $role && $name) { |
| $hostname{$id}=$name; |
$hostname{$id}=$name; |
| $hostdom{$id}=$domain; |
$hostdom{$id}=$domain; |
| $hostip{$id}=$ip; |
|
| $iphost{$ip}=$id; |
|
| if ($role eq 'library') { $libserv{$id}=$name; } |
if ($role eq 'library') { $libserv{$id}=$name; } |
| } |
} |
| } |
} |
| close($config); |
close($config); |
| } |
} |
| |
|
| |
sub get_iphost { |
| |
if (%iphost) { return %iphost; } |
| |
foreach my $id (keys(%hostname)) { |
| |
my $name=$hostname{$id}; |
| |
my $ip = gethostbyname($name); |
| |
if (!$ip || length($ip) ne 4) { |
| |
&logthis("Skipping host $id name $name no IP found\n"); |
| |
next; |
| |
} |
| |
$ip=inet_ntoa($ip); |
| |
push(@{$iphost{$ip}},$id); |
| |
} |
| |
return %iphost; |
| |
} |
| |
|
| # ------------------------------------------------------ Read spare server file |
# ------------------------------------------------------ Read spare server file |
| { |
{ |
| open(my $config,"<$perlvar{'lonTabDir'}/spare.tab"); |
open(my $config,"<$perlvar{'lonTabDir'}/spare.tab"); |
|
Line 5717 BEGIN {
|
Line 5688 BEGIN {
|
| |
|
| } |
} |
| |
|
| %metacache=(); |
$memcache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']}); |
| |
|
| $processmarker='_'.time.'_'.$perlvar{'lonHostID'}; |
$processmarker='_'.time.'_'.$perlvar{'lonHostID'}; |
| $dumpcount=0; |
$dumpcount=0; |
|
Line 6162 subscribe($fname) : subscribe to a resou
|
Line 6133 subscribe($fname) : subscribe to a resou
|
| |
|
| repcopy($filename) : subscribes to the requested file, and attempts to |
repcopy($filename) : subscribes to the requested file, and attempts to |
| replicate from the owning library server, Might return |
replicate from the owning library server, Might return |
| HTTP_SERVICE_UNAVAILABLE, HTTP_NOT_FOUND, FORBIDDEN, OK, or |
'unavailable', 'not_found', 'forbidden', 'ok', or |
| HTTP_BAD_REQUEST, also attempts to grab the metadata for the |
'bad_request', also attempts to grab the metadata for the |
| resource. Expects the local filesystem pathname |
resource. Expects the local filesystem pathname |
| (/home/httpd/html/res/....) |
(/home/httpd/html/res/....) |
| |
|
|
Line 6217 returns the data handle
|
Line 6188 returns the data handle
|
| =item * |
=item * |
| |
|
| symbverify($symb,$thisfn) : verifies that $symb actually exists and is |
symbverify($symb,$thisfn) : verifies that $symb actually exists and is |
| a possible symb for the URL in $thisfn, returns a 1 on success, 0 on |
a possible symb for the URL in $thisfn, and if is an encryypted |
| failure, user must be in a course, as it assumes the existance of the |
resource that the user accessed using /enc/ returns a 1 on success, 0 |
| course initi hash, and uses $ENV('request.course.id'} |
on failure, user must be in a course, as it assumes the existance of |
| |
the course initial hash, and uses $ENV('request.course.id'} |
| |
|
| |
|
| =item * |
=item * |
|
Line 6504 declutter() : declutters URLs (remove do
|
Line 6476 declutter() : declutters URLs (remove do
|
| |
|
| =back |
=back |
| |
|
| |
=head2 Usererfile file routines (/uploaded*) |
| |
|
| |
=over 4 |
| |
|
| |
=item * |
| |
|
| |
userfileupload(): main rotine for putting a file in a user or course's |
| |
filespace, arguments are, |
| |
|
| |
formname - required - this is the name of the element in $ENV where the |
| |
filename, and the contents of the file to create/modifed exist |
| |
the filename is in $ENV{'form.'.$formname.'.filename'} and the |
| |
contents of the file is located in $ENV{'form.'.$formname} |
| |
coursedoc - if true, store the file in the course of the active role |
| |
of the current user |
| |
subdir - required - subdirectory to put the file in under ../userfiles/ |
| |
if undefined, it will be placed in "unknown" |
| |
|
| |
(This routine calls clean_filename() to remove any dangerous |
| |
characters from the filename, and then calls finuserfileupload() to |
| |
complete the transaction) |
| |
|
| |
returns either the url of the uploaded file (/uploaded/....) if successful |
| |
and /adm/notfound.html if unsuccessful |
| |
|
| |
=item * |
| |
|
| |
clean_filename(): routine for cleaing a filename up for storage in |
| |
userfile space, argument is: |
| |
|
| |
filename - proposed filename |
| |
|
| |
returns: the new clean filename |
| |
|
| |
=item * |
| |
|
| |
finishuserfileupload(): routine that creaes and sends the file to |
| |
userspace, probably shouldn't be called directly |
| |
|
| |
docuname: username or courseid of destination for the file |
| |
docudom: domain of user/course of destination for the file |
| |
docuhome: loncapa id of the library server that is getting the file |
| |
formname: same as for userfileupload() |
| |
fname: filename (inculding subdirectories) for the file |
| |
|
| |
returns either the url of the uploaded file (/uploaded/....) if successful |
| |
and /adm/notfound.html if unsuccessful |
| |
|
| |
=item * |
| |
|
| |
renameuserfile(): renames an existing userfile to a new name |
| |
|
| |
Args: |
| |
docuname: username or courseid of destination for the file |
| |
docudom: domain of user/course of destination for the file |
| |
old: current file name (including any subdirs under userfiles) |
| |
new: desired file name (including any subdirs under userfiles) |
| |
|
| |
=item * |
| |
|
| |
mkdiruserfile(): creates a directory is a userfiles dir |
| |
|
| |
Args: |
| |
docuname: username or courseid of destination for the file |
| |
docudom: domain of user/course of destination for the file |
| |
dir: dir to create (including any subdirs under userfiles) |
| |
|
| |
=item * |
| |
|
| |
removeuserfile(): removes a file that exists in userfiles |
| |
|
| |
Args: |
| |
docuname: username or courseid of destination for the file |
| |
docudom: domain of user/course of destination for the file |
| |
fname: filname to delete (including any subdirs under userfiles) |
| |
|
| |
=item * |
| |
|
| |
removeuploadedurl(): convience function for removeuserfile() |
| |
|
| |
Args: |
| |
url: a full /uploaded/... url to delete |
| |
|
| |
=back |
| |
|
| =head2 HTTP Helper Routines |
=head2 HTTP Helper Routines |
| |
|
| =over 4 |
=over 4 |
![[BACK]](/icons/back.gif){kind=icon}
Return to lonnet.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / lonnet / perl