|
version 1.425, 2003/10/04 02:27:02
|
version 1.443, 2003/11/10 20:27:32
|
|
Line 25
|
Line 25
|
| # |
# |
| # http://www.lon-capa.org/ |
# http://www.lon-capa.org/ |
| # |
# |
| # 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30, |
|
| # 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19, |
|
| # 11/8,11/16,11/18,11/22,11/23,12/22, |
|
| # 01/06,01/13,02/24,02/28,02/29, |
|
| # 03/01,03/02,03/06,03/07,03/13, |
|
| # 04/05,05/29,05/31,06/01, |
|
| # 06/05,06/26 Gerd Kortemeyer |
|
| # 06/26 Ben Tyszka |
|
| # 06/30,07/15,07/17,07/18,07/20,07/21,07/22,07/25 Gerd Kortemeyer |
|
| # 08/14 Ben Tyszka |
|
| # 08/22,08/28,08/31,09/01,09/02,09/04,09/05,09/25,09/28,09/30 Gerd Kortemeyer |
|
| # 10/04 Gerd Kortemeyer |
|
| # 10/04 Guy Albertelli |
|
| # 10/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29, |
|
| # 10/30,10/31, |
|
| # 11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25,11/27, |
|
| # 12/02,12/12,12/13,12/14,12/28,12/29 Gerd Kortemeyer |
|
| # 05/01/01 Guy Albertelli |
|
| # 05/01,06/01,09/01 Gerd Kortemeyer |
|
| # 09/01 Guy Albertelli |
|
| # 09/01,10/01,11/01 Gerd Kortemeyer |
|
| # YEAR=2001 |
|
| # 3/2 Gerd Kortemeyer |
|
| # 3/19,3/20 Gerd Kortemeyer |
|
| # 5/26,5/28 Gerd Kortemeyer |
|
| # 5/30 H. K. Ng |
|
| # 6/1 Gerd Kortemeyer |
|
| # July Guy Albertelli |
|
| # 8/4,8/7,8/8,8/9,8/11,8/16,8/17,8/18,8/20,8/23,9/20,9/21,9/26, |
|
| # 10/2 Gerd Kortemeyer |
|
| # 11/17,11/20,11/22,11/29 Gerd Kortemeyer |
|
| # 12/5 Matthew Hall |
|
| # 12/5 Guy Albertelli |
|
| # 12/6,12/7,12/12 Gerd Kortemeyer |
|
| # 12/21,12/22,12/27,12/28 Gerd Kortemeyer |
|
| # YEAR=2002 |
|
| # 1/4,2/4,2/7 Gerd Kortemeyer |
|
| # |
|
| ### |
### |
| |
|
| package Apache::lonnet; |
package Apache::lonnet; |
|
Line 73 use LWP::UserAgent();
|
Line 35 use LWP::UserAgent();
|
| use HTTP::Headers; |
use HTTP::Headers; |
| use vars |
use vars |
| qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom |
qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom |
| %libserv %pr %prp %metacache %packagetab %titlecache |
%libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache |
| %courselogs %accesshash %userrolehash $processmarker $dumpcount |
%courselogs %accesshash %userrolehash $processmarker $dumpcount |
| %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache |
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache |
| %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def |
%userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def |
|
Line 86 use HTML::LCParser;
|
Line 48 use HTML::LCParser;
|
| use Fcntl qw(:flock); |
use Fcntl qw(:flock); |
| use Apache::loncoursedata; |
use Apache::loncoursedata; |
| use Apache::lonlocal; |
use Apache::lonlocal; |
| use Storable qw(lock_store lock_nstore lock_retrieve); |
use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw); |
| use Time::HiRes(); |
use Time::HiRes(); |
| my $readit; |
my $readit; |
| |
|
|
Line 274 sub transfer_profile_to_env {
|
Line 236 sub transfer_profile_to_env {
|
| $idf->close(); |
$idf->close(); |
| } |
} |
| my $envi; |
my $envi; |
| |
my %Remove; |
| for ($envi=0;$envi<=$#profile;$envi++) { |
for ($envi=0;$envi<=$#profile;$envi++) { |
| chomp($profile[$envi]); |
chomp($profile[$envi]); |
| my ($envname,$envvalue)=split(/=/,$profile[$envi]); |
my ($envname,$envvalue)=split(/=/,$profile[$envi]); |
| $ENV{$envname} = $envvalue; |
$ENV{$envname} = $envvalue; |
| |
if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) { |
| |
if ($time < time-300) { |
| |
$Remove{$key}++; |
| |
} |
| |
} |
| |
} |
| |
foreach my $expired_key (keys(%Remove)) { |
| |
&delenv($expired_key); |
| } |
} |
| $ENV{'user.environment'} = "$lonidsdir/$handle.id"; |
$ENV{'user.environment'} = "$lonidsdir/$handle.id"; |
| } |
} |
|
Line 396 sub userload {
|
Line 367 sub userload {
|
| while ($filename=readdir(LONIDS)) { |
while ($filename=readdir(LONIDS)) { |
| if ($filename eq '.' || $filename eq '..') {next;} |
if ($filename eq '.' || $filename eq '..') {next;} |
| my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9]; |
my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9]; |
| if ($curtime-$mtime < 3600) { $numusers++; } |
if ($curtime-$mtime < 1800) { $numusers++; } |
| } |
} |
| closedir(LONIDS); |
closedir(LONIDS); |
| } |
} |
|
Line 586 sub authenticate {
|
Line 557 sub authenticate {
|
| sub homeserver { |
sub homeserver { |
| my ($uname,$udom,$ignoreBadCache)=@_; |
my ($uname,$udom,$ignoreBadCache)=@_; |
| my $index="$uname:$udom"; |
my $index="$uname:$udom"; |
| if ($homecache{$index}) { |
|
| return "$homecache{$index}"; |
my ($result,$cached)=&is_cached(\%homecache,$index,'home',86400); |
| } |
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 596 sub homeserver {
|
Line 567 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') { |
| $homecache{$index}=$tryserver; |
return &do_cache(\%homecache,$index,$tryserver,'home'); |
| return $tryserver; |
|
| } elsif ($answer eq 'no_host') { |
} elsif ($answer eq 'no_host') { |
| $badServerCache{$tryserver}=1; |
$badServerCache{$tryserver}=1; |
| } |
} |
|
Line 850 sub getsection {
|
Line 820 sub getsection {
|
| } |
} |
| |
|
| sub devalidate_cache { |
sub devalidate_cache { |
| my ($cache,$id) = @_; |
my ($cache,$id,$name) = @_; |
| delete $$cache{$id.'.time'}; |
delete $$cache{$id.'.time'}; |
| delete $$cache{$id}; |
delete $$cache{$id}; |
| |
my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db"; |
| |
open(DB,"$filename.lock"); |
| |
flock(DB,LOCK_EX); |
| |
my %hash; |
| |
if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) { |
| |
eval <<'EVALBLOCK'; |
| |
delete($hash{$id}); |
| |
delete($hash{$id.'.time'}); |
| |
EVALBLOCK |
| |
if ($@) { |
| |
&logthis("<font color='red'>devalidate_cache blew up :$@:$name</font>"); |
| |
unlink($filename); |
| |
} |
| |
} else { |
| |
if (-e $filename) { |
| |
&logthis("Unable to tie hash (devalidate cache): $name"); |
| |
unlink($filename); |
| |
} |
| |
} |
| |
untie(%hash); |
| |
flock(DB,LOCK_UN); |
| |
close(DB); |
| } |
} |
| |
|
| sub is_cached { |
sub is_cached { |
| my ($cache,$id,$name,$time) = @_; |
my ($cache,$id,$name,$time) = @_; |
| if (!$time) { $time=300; } |
if (!$time) { $time=300; } |
| if (!exists($$cache{$id.'.time'})) { |
if (!exists($$cache{$id.'.time'})) { |
| &load_cache($cache,$name); |
&load_cache_item($cache,$name,$id); |
| } |
} |
| if (!exists($$cache{$id.'.time'})) { |
if (!exists($$cache{$id.'.time'})) { |
| # &logthis("Didn't find $id"); |
# &logthis("Didn't find $id"); |
| return (undef,undef); |
return (undef,undef); |
| } else { |
} else { |
| if (time-($$cache{$id.'.time'})>$time) { |
if (time-($$cache{$id.'.time'})>$time) { |
| # &logthis("Devailidating $id"); |
# &logthis("Devalidating $id - ".time-($$cache{$id.'.time'})); |
| &devalidate_cache($cache,$id); |
&devalidate_cache($cache,$id,$name); |
| return (undef,undef); |
return (undef,undef); |
| } |
} |
| } |
} |
|
Line 878 sub do_cache {
|
Line 870 sub do_cache {
|
| my ($cache,$id,$value,$name) = @_; |
my ($cache,$id,$value,$name) = @_; |
| $$cache{$id.'.time'}=time; |
$$cache{$id.'.time'}=time; |
| $$cache{$id}=$value; |
$$cache{$id}=$value; |
| &save_cache($cache,$name); |
# &logthis("Caching $id as :$value:"); |
| |
&save_cache_item($cache,$name,$id); |
| # do_cache implictly return the set value |
# do_cache implictly return the set value |
| $$cache{$id}; |
$$cache{$id}; |
| } |
} |
| |
|
| sub save_cache { |
sub save_cache_item { |
| my ($cache,$name)=@_; |
my ($cache,$name,$id)=@_; |
| # my $starttime=&Time::HiRes::time(); |
my $starttime=&Time::HiRes::time(); |
| # &logthis("Saving :$name:"); |
# &logthis("Saving :$name:$id"); |
| eval lock_store($cache,$perlvar{'lonDaemons'}.'/tmp/'.$name.".storable"); |
my %hash; |
| if ($@) { &logthis("lock_store threw a die ".$@); } |
my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db"; |
| # &logthis("save_cache took ".(&Time::HiRes::time()-$starttime)); |
open(DB,"$filename.lock"); |
| } |
flock(DB,LOCK_EX); |
| |
if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) { |
| sub load_cache { |
eval <<'EVALBLOCK'; |
| my ($cache,$name)=@_; |
$hash{$id.'.time'}=$$cache{$id.'.time'}; |
| # my $starttime=&Time::HiRes::time(); |
$hash{$id}=freeze({'item'=>$$cache{$id}}); |
| # &logthis("Before Loading $name size is ".scalar(%$cache)); |
EVALBLOCK |
| my $tmpcache; |
if ($@) { |
| eval { |
&logthis("<font color='red'>save_cache blew up :$@:$name</font>"); |
| $tmpcache=lock_retrieve($perlvar{'lonDaemons'}.'/tmp/'.$name.".storable"); |
unlink($filename); |
| }; |
|
| if ($@) { &logthis("lock_retreive threw a die ".$@); return; } |
|
| if (!%$cache) { |
|
| my $count; |
|
| while (my ($key,$value)=each(%$tmpcache)) { |
|
| $count++; |
|
| $$cache{$key}=$value; |
|
| } |
} |
| # &logthis("Initial load: $count"); |
|
| } else { |
} else { |
| my $key; |
if (-e $filename) { |
| my $count; |
&logthis("Unable to tie hash (save cache item): $name"); |
| while ($key=each(%$tmpcache)) { |
unlink($filename); |
| if ($key !~/^(.*)\.time$/) { next; } |
} |
| my $name=$1; |
} |
| if (exists($$cache{$key})) { |
untie(%hash); |
| if ($$tmpcache{$key} >= $$cache{$key}) { |
flock(DB,LOCK_UN); |
| $$cache{$key}=$$tmpcache{$key}; |
close(DB); |
| $$cache{$name}=$$tmpcache{$name}; |
# &logthis("save_cache_item $name took ".(&Time::HiRes::time()-$starttime)); |
| } else { |
} |
| # &logthis("Would have overwritten $name with is set to expire at ".$$cache{$key}." with ".$$tmpcache{$key}." Whew!"); |
|
| |
sub load_cache_item { |
| |
my ($cache,$name,$id)=@_; |
| |
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"; |
| |
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 { |
} else { |
| $count++; |
my $hashref=thaw($hash{$id}); |
| $$cache{$key}=$$tmpcache{$key}; |
$$cache{$id}=$hashref->{'item'}; |
| $$cache{$name}=$$tmpcache{$name}; |
$$cache{$id.'.time'}=$hash{$id.'.time'}; |
| } |
} |
| |
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); |
| } |
} |
| # &logthis("Additional load: $count"); |
|
| } |
} |
| |
untie(%hash); |
| |
flock(DB,LOCK_UN); |
| |
close(DB); |
| # &logthis("After Loading $name size is ".scalar(%$cache)); |
# &logthis("After Loading $name size is ".scalar(%$cache)); |
| # &logthis("load_cache took ".(&Time::HiRes::time()-$starttime)); |
# &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime)); |
| } |
} |
| |
|
| sub usection { |
sub usection { |
|
Line 1002 sub getversion {
|
Line 1019 sub getversion {
|
| |
|
| sub currentversion { |
sub currentversion { |
| my $fname=shift; |
my $fname=shift; |
| |
my ($result,$cached)=&is_cached(\%resversioncache,$fname,'resversion',600); |
| |
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); |
|
Line 1013 sub currentversion {
|
Line 1032 sub currentversion {
|
| if (($answer eq 'con_lost') || ($answer eq 'rejected')) { |
if (($answer eq 'con_lost') || ($answer eq 'rejected')) { |
| return -1; |
return -1; |
| } |
} |
| return $answer; |
return &do_cache(\%resversioncache,$fname,$answer,'resversion'); |
| } |
} |
| |
|
| # ----------------------------- Subscribe to a resource, return URL if possible |
# ----------------------------- Subscribe to a resource, return URL if possible |
|
Line 1048 sub repcopy {
|
Line 1067 sub repcopy {
|
| &logthis("Subscribe returned $remoteurl: $filename"); |
&logthis("Subscribe returned $remoteurl: $filename"); |
| return HTTP_SERVICE_UNAVAILABLE; |
return HTTP_SERVICE_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 HTTP_NOT_FOUND; |
| } elsif ($remoteurl =~ /^rejected by/) { |
} elsif ($remoteurl =~ /^rejected by/) { |
| &logthis("Subscribe returned $remoteurl: $filename"); |
&logthis("Subscribe returned $remoteurl: $filename"); |
|
Line 2409 sub customaccess {
|
Line 2428 sub customaccess {
|
| |
|
| sub allowed { |
sub allowed { |
| my ($priv,$uri)=@_; |
my ($priv,$uri)=@_; |
| |
$uri=&deversion($uri); |
| my $orguri=$uri; |
my $orguri=$uri; |
| $uri=&declutter($uri); |
$uri=&declutter($uri); |
| |
|
|
Line 2694 sub allowed {
|
Line 2713 sub allowed {
|
| |
|
| sub is_on_map { |
sub is_on_map { |
| my $uri=&declutter(shift); |
my $uri=&declutter(shift); |
| |
$uri=~s/\.\d+\.(\w+)$/\.$1/; |
| my @uriparts=split(/\//,$uri); |
my @uriparts=split(/\//,$uri); |
| my $filename=$uriparts[$#uriparts]; |
my $filename=$uriparts[$#uriparts]; |
| my $pathname=$uri; |
my $pathname=$uri; |
|
Line 2705 sub is_on_map {
|
Line 2725 sub is_on_map {
|
| if ($match) { |
if ($match) { |
| return (1,$1); |
return (1,$1); |
| } else { |
} else { |
| my ($name,$ext)=($filename=~/^(.+)\.(\w+)$/); |
return (0,0); |
| $ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ |
} |
| /\&(\Q$name\E\.\d+\.$ext)\:([\d\|]+)\&/; |
} |
| return (0,$2,$pathname.'/'.$1); |
|
| |
# --------------------------------------------------------- Get symb from alias |
| |
|
| |
sub get_symb_from_alias { |
| |
my $symb=shift; |
| |
my ($map,$resid,$url)=&decode_symb($symb); |
| |
# Already is a symb |
| |
if ($url) { return $symb; } |
| |
# Must be an alias |
| |
my $aliassymb=''; |
| |
my %bighash; |
| |
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', |
| |
&GDBM_READER(),0640)) { |
| |
my $rid=$bighash{'mapalias_'.$symb}; |
| |
if ($rid) { |
| |
my ($mapid,$resid)=split(/\./,$rid); |
| |
$aliassymb=&encode_symb($bighash{'map_id_'.$mapid}, |
| |
$resid,$bighash{'src_'.$rid}); |
| |
} |
| |
untie %bighash; |
| } |
} |
| |
return $aliassymb; |
| } |
} |
| |
|
| # ----------------------------------------------------------------- Define Role |
# ----------------------------------------------------------------- Define Role |
|
Line 3366 sub condval {
|
Line 3406 sub condval {
|
| sub devalidatecourseresdata { |
sub devalidatecourseresdata { |
| my ($coursenum,$coursedomain)=@_; |
my ($coursenum,$coursedomain)=@_; |
| my $hashid=$coursenum.':'.$coursedomain; |
my $hashid=$coursenum.':'.$coursedomain; |
| &devalidate_cache(\%courseresdatacache,$hashid); |
&devalidate_cache(\%courseresdatacache,$hashid,'courseres'); |
| } |
} |
| |
|
| # --------------------------------------------------- Course Resourcedata Query |
# --------------------------------------------------- Course Resourcedata Query |
|
Line 3430 sub EXT {
|
Line 3470 sub EXT {
|
| #get real user name/domain, courseid and symb |
#get real user name/domain, courseid and symb |
| my $courseid; |
my $courseid; |
| my $publicuser; |
my $publicuser; |
| |
if ($symbparm) { |
| |
$symbparm=&get_symb_from_alias($symbparm); |
| |
} |
| if (!($uname && $udom)) { |
if (!($uname && $udom)) { |
| (my $cursymb,$courseid,$udom,$uname,$publicuser)= |
(my $cursymb,$courseid,$udom,$uname,$publicuser)= |
| &Apache::lonxml::whichuser($symbparm); |
&Apache::lonxml::whichuser($symbparm); |
|
Line 3515 sub EXT {
|
Line 3558 sub EXT {
|
| } elsif ($realm eq 'request') { |
} elsif ($realm eq 'request') { |
| # ------------------------------------------------------------- request.browser |
# ------------------------------------------------------------- request.browser |
| if ($space eq 'browser') { |
if ($space eq 'browser') { |
| return $ENV{'browser.'.$qualifier}; |
if ($qualifier eq 'textremote') { |
| |
if (&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 3707 sub metadata {
|
Line 3758 sub metadata {
|
| # Look at timestamp of caching |
# Look at timestamp of caching |
| # Everything is cached by the main uri, libraries are never directly cached |
# Everything is cached by the main uri, libraries are never directly cached |
| # |
# |
| unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600 && !defined($liburi)) { |
if (!defined($liburi)) { |
| |
my ($result,$cached)=&is_cached(\%metacache,$uri,'meta'); |
| |
if (defined($cached)) { return $result->{':'.$what}; } |
| |
} |
| |
{ |
| # |
# |
| # Is this a recursive call for a library? |
# Is this a recursive call for a library? |
| # |
# |
| |
my %lcmetacache; |
| if ($liburi) { |
if ($liburi) { |
| $liburi=&declutter($liburi); |
$liburi=&declutter($liburi); |
| $filename=$liburi; |
$filename=$liburi; |
| } else { |
} else { |
| delete($metacache{$uri.':packages'}); |
&devalidate_cache(\%metacache,$uri,'meta'); |
| } |
} |
| my %metathesekeys=(); |
my %metathesekeys=(); |
| unless ($filename=~/\.meta$/) { $filename.='.meta'; } |
unless ($filename=~/\.meta$/) { $filename.='.meta'; } |
|
Line 3734 sub metadata {
|
Line 3790 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 ($lcmetacache{':packages'}) { |
| $metacache{$uri.':packages'}.=','.$package.$keyroot; |
$lcmetacache{':packages'}.=','.$package.$keyroot; |
| } else { |
} else { |
| $metacache{$uri.':packages'}=$package.$keyroot; |
$lcmetacache{':packages'}=$package.$keyroot; |
| } |
} |
| foreach (keys %packagetab) { |
foreach (keys %packagetab) { |
| if ($_=~/^$package\&/) { |
my $part=$keyroot; |
| |
$part=~s/^\_//; |
| |
if ($_=~/^\Q$package\E\&/ || |
| |
$_=~/^\Q$package\E_0\&/) { |
| my ($pack,$name,$subp)=split(/\&/,$_); |
my ($pack,$name,$subp)=split(/\&/,$_); |
| # ignore package.tab specified default values |
# ignore package.tab specified default values |
| # here &package_tab_default() will fetch those |
# here &package_tab_default() will fetch those |
| if ($subp eq 'default') { next; } |
if ($subp eq 'default') { next; } |
| my $value=$packagetab{$_}; |
my $value=$packagetab{$_}; |
| my $part=$keyroot; |
my $unikey; |
| $part=~s/^\_//; |
if ($pack =~ /_0$/) { |
| |
$unikey='parameter_0_'.$name; |
| |
$part=0; |
| |
} else { |
| |
$unikey='parameter'.$keyroot.'_'.$name; |
| |
} |
| if ($subp eq 'display') { |
if ($subp eq 'display') { |
| $value.=' [Part: '.$part.']'; |
$value.=' [Part: '.$part.']'; |
| } |
} |
| my $unikey='parameter'.$keyroot.'_'.$name; |
$lcmetacache{':'.$unikey.'.part'}=$part; |
| $metacache{$uri.':'.$unikey.'.part'}=$part; |
|
| $metathesekeys{$unikey}=1; |
$metathesekeys{$unikey}=1; |
| unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) { |
unless (defined($lcmetacache{':'.$unikey.'.'.$subp})) { |
| $metacache{$uri.':'.$unikey.'.'.$subp}=$value; |
$lcmetacache{':'.$unikey.'.'.$subp}=$value; |
| } |
} |
| if (defined($metacache{$uri.':'.$unikey.'.default'})) { |
if (defined($lcmetacache{':'.$unikey.'.default'})) { |
| $metacache{$uri.':'.$unikey}= |
$lcmetacache{':'.$unikey}= |
| $metacache{$uri.':'.$unikey.'.default'}; |
$lcmetacache{':'.$unikey.'.default'}; |
| } |
} |
| } |
} |
| } |
} |
|
Line 3802 sub metadata {
|
Line 3865 sub metadata {
|
| } |
} |
| $metathesekeys{$unikey}=1; |
$metathesekeys{$unikey}=1; |
| foreach (@{$token->[3]}) { |
foreach (@{$token->[3]}) { |
| $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_}; |
$lcmetacache{':'.$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=$lcmetacache{':'.$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; |
$lcmetacache{':'.$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; |
$lcmetacache{':'.$unikey}=$internaltext; |
| } |
} |
| # end of not-a-package not-a-library import |
# end of not-a-package not-a-library import |
| } |
} |
|
Line 3823 sub metadata {
|
Line 3886 sub metadata {
|
| } |
} |
| } |
} |
| # are there custom rights to evaluate |
# are there custom rights to evaluate |
| if ($metacache{$uri.':copyright'} eq 'custom') { |
if ($lcmetacache{':copyright'} eq 'custom') { |
| |
|
| # |
# |
| # Importing a rights file here |
# Importing a rights file here |
| # |
# |
| unless ($depthcount) { |
unless ($depthcount) { |
| my $location=$metacache{$uri.':customdistributionfile'}; |
my $location=$lcmetacache{':customdistributionfile'}; |
| my $dir=$filename; |
my $dir=$filename; |
| $dir=~s|[^/]*$||; |
$dir=~s|[^/]*$||; |
| $location=&filelocation($dir,$location); |
$location=&filelocation($dir,$location); |
|
Line 3840 sub metadata {
|
Line 3903 sub metadata {
|
| } |
} |
| } |
} |
| } |
} |
| $metacache{$uri.':keys'}=join(',',keys %metathesekeys); |
$lcmetacache{':keys'}=join(',',keys %metathesekeys); |
| &metadata_generate_part0(\%metathesekeys,\%metacache,$uri); |
&metadata_generate_part0(\%metathesekeys,\%lcmetacache,$uri); |
| $metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys); |
$lcmetacache{':allpossiblekeys'}=join(',',keys %metathesekeys); |
| $metacache{$uri.':cachedtimestamp'}=time; |
&do_cache(\%metacache,$uri,\%lcmetacache,'meta'); |
| # 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 $metacache{$uri}->{':'.$what}; |
| } |
} |
| |
|
| sub metadata_generate_part0 { |
sub metadata_generate_part0 { |
|
Line 3854 sub metadata_generate_part0 {
|
Line 3917 sub metadata_generate_part0 {
|
| my %allnames; |
my %allnames; |
| foreach my $metakey (sort keys %$metadata) { |
foreach my $metakey (sort keys %$metadata) { |
| if ($metakey=~/^parameter\_(.*)/) { |
if ($metakey=~/^parameter\_(.*)/) { |
| my $part=$$metacache{$uri.':'.$metakey.'.part'}; |
my $part=$$metacache{':'.$metakey.'.part'}; |
| my $name=$$metacache{$uri.':'.$metakey.'.name'}; |
my $name=$$metacache{':'.$metakey.'.name'}; |
| if (! exists($$metadata{'parameter_0_'.$name.'.name'})) { |
if (! exists($$metadata{'parameter_0_'.$name.'.name'})) { |
| $allnames{$name}=$part; |
$allnames{$name}=$part; |
| } |
} |
|
Line 3863 sub metadata_generate_part0 {
|
Line 3926 sub metadata_generate_part0 {
|
| } |
} |
| foreach my $name (keys(%allnames)) { |
foreach my $name (keys(%allnames)) { |
| $$metadata{"parameter_0_$name"}=1; |
$$metadata{"parameter_0_$name"}=1; |
| my $key="$uri:parameter_0_$name"; |
my $key=":parameter_0_$name"; |
| $$metacache{"$key.part"}='0'; |
$$metacache{"$key.part"}='0'; |
| $$metacache{"$key.name"}=$name; |
$$metacache{"$key.name"}=$name; |
| $$metacache{"$key.type"}=$$metacache{$uri.':parameter_'. |
$$metacache{"$key.type"}=$$metacache{':parameter_'. |
| $allnames{$name}.'_'.$name. |
$allnames{$name}.'_'.$name. |
| '.type'}; |
'.type'}; |
| my $olddis=$$metacache{$uri.':parameter_'.$allnames{$name}.'_'.$name. |
my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name. |
| '.display'}; |
'.display'}; |
| my $expr='\\[Part: '.$allnames{$name}.'\\]'; |
my $expr='\\[Part: '.$allnames{$name}.'\\]'; |
| $olddis=~s/$expr/\[Part: 0\]/; |
$olddis=~s/$expr/\[Part: 0\]/; |
|
Line 3909 sub gettitle {
|
Line 3972 sub gettitle {
|
| |
|
| sub symblist { |
sub symblist { |
| my ($mapname,%newhash)=@_; |
my ($mapname,%newhash)=@_; |
| $mapname=declutter($mapname); |
$mapname=&deversion(&declutter($mapname)); |
| my %hash; |
my %hash; |
| 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 (keys %newhash) { |
foreach (keys %newhash) { |
| $hash{declutter($_)}=$mapname.'___'.$newhash{$_}; |
$hash{declutter($_)}=$mapname.'___'.&deversion($newhash{$_}); |
| } |
} |
| if (untie(%hash)) { |
if (untie(%hash)) { |
| return 'ok'; |
return 'ok'; |
|
Line 3934 sub symbverify {
|
Line 3997 sub symbverify {
|
| if ($thisfn=~/\.(page|sequence)$/) { return 1; } |
if ($thisfn=~/\.(page|sequence)$/) { return 1; } |
| # check URL part |
# check URL part |
| my ($map,$resid,$url)=&decode_symb($symb); |
my ($map,$resid,$url)=&decode_symb($symb); |
| unless (&symbclean($url) eq &symbclean($thisfn)) { return 0; } |
|
| |
unless ($url eq $thisfn) { return 0; } |
| |
|
| $symb=&symbclean($symb); |
$symb=&symbclean($symb); |
| |
$thisfn=&deversion($thisfn); |
| |
|
| my %bighash; |
my %bighash; |
| my $okay=0; |
my $okay=0; |
| |
|
| 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($thisfn)}; |
my $ids=$bighash{'ids_'.&clutter($thisfn)}; |
|
Line 3978 sub symbclean {
|
Line 4044 sub symbclean {
|
| |
|
| # ---------------------------------------------- Split symb to find map and url |
# ---------------------------------------------- Split symb to find map and url |
| |
|
| |
sub encode_symb { |
| |
my ($map,$resid,$url)=@_; |
| |
return &symbclean(&declutter($map).'___'.$resid.'___'.&declutter($url)); |
| |
} |
| |
|
| sub decode_symb { |
sub decode_symb { |
| my ($map,$resid,$url)=split(/\_\_\_/,shift); |
my ($map,$resid,$url)=split(/\_\_\_/,shift); |
| return (&fixversion($map),$resid,&fixversion($url)); |
return (&fixversion($map),$resid,&fixversion($url)); |
|
Line 3986 sub decode_symb {
|
Line 4057 sub decode_symb {
|
| sub fixversion { |
sub fixversion { |
| my $fn=shift; |
my $fn=shift; |
| if ($fn=~/^(adm|uploaded|public)/) { return $fn; } |
if ($fn=~/^(adm|uploaded|public)/) { return $fn; } |
| my ($match,$cond,$versioned)=&is_on_map($fn); |
my %bighash; |
| unless ($match) { |
my $uri=&clutter($fn); |
| $fn=$versioned; |
my $key=$ENV{'request.course.id'}.'_'.$uri; |
| } |
# is this cached? |
| return $fn; |
my ($result,$cached)=&is_cached(\%courseresversioncache,$key, |
| |
'courseresversion',600); |
| |
if (defined($cached)) { return $result; } |
| |
# unfortunately not cached, or expired |
| |
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', |
| |
&GDBM_READER(),0640)) { |
| |
if ($bighash{'version_'.$uri}) { |
| |
my $version=$bighash{'version_'.$uri}; |
| |
unless ($version eq 'mostrecent') { |
| |
$uri=~s/\.(\w+)$/\.$version\.$1/; |
| |
} |
| |
} |
| |
untie %bighash; |
| |
} |
| |
return &do_cache |
| |
(\%courseresversioncache,$key,&declutter($uri),'courseresversion'); |
| |
} |
| |
|
| |
sub deversion { |
| |
my $url=shift; |
| |
$url=~s/\.\d+\.(\w+)$/\.$1/; |
| |
return $url; |
| } |
} |
| |
|
| # ------------------------------------------------------ Return symb list entry |
# ------------------------------------------------------ Return symb list entry |
|
Line 4090 sub numval {
|
Line 4182 sub numval {
|
| } |
} |
| |
|
| sub latest_rnd_algorithm_id { |
sub latest_rnd_algorithm_id { |
| return '64bit'; |
return '64bit2'; |
| } |
} |
| |
|
| sub rndseed { |
sub rndseed { |
|
Line 4107 sub rndseed {
|
Line 4199 sub rndseed {
|
| my $CODE=$ENV{'scantron.CODE'}; |
my $CODE=$ENV{'scantron.CODE'}; |
| if (defined($CODE)) { |
if (defined($CODE)) { |
| &rndseed_CODE_64bit($symb,$courseid,$domain,$username); |
&rndseed_CODE_64bit($symb,$courseid,$domain,$username); |
| |
} elsif ($which eq '64bit2') { |
| |
return &rndseed_64bit2($symb,$courseid,$domain,$username); |
| } elsif ($which eq '64bit') { |
} elsif ($which eq '64bit') { |
| return &rndseed_64bit($symb,$courseid,$domain,$username); |
return &rndseed_64bit($symb,$courseid,$domain,$username); |
| } |
} |
|
Line 4150 sub rndseed_64bit {
|
Line 4244 sub rndseed_64bit {
|
| } |
} |
| } |
} |
| |
|
| |
sub rndseed_64bit2 { |
| |
my ($symb,$courseid,$domain,$username)=@_; |
| |
{ |
| |
use integer; |
| |
# strings need to be an even # of cahracters long, it it is odd the |
| |
# last characters gets thrown away |
| |
my $symbchck=unpack("%32S*",$symb.' ') << 21; |
| |
my $symbseed=numval($symb) << 10; |
| |
my $namechck=unpack("%32S*",$username.' '); |
| |
|
| |
my $nameseed=numval($username) << 21; |
| |
my $domainseed=unpack("%32S*",$domain.' ') << 10; |
| |
my $courseseed=unpack("%32S*",$courseid.' '); |
| |
|
| |
my $num1=$symbchck+$symbseed+$namechck; |
| |
my $num2=$nameseed+$domainseed+$courseseed; |
| |
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
| |
#&Apache::lonxml::debug("rndseed :$num:$symb"); |
| |
return "$num1,$num2"; |
| |
} |
| |
} |
| |
|
| sub rndseed_CODE_64bit { |
sub rndseed_CODE_64bit { |
| my ($symb,$courseid,$domain,$username)=@_; |
my ($symb,$courseid,$domain,$username)=@_; |
| { |
{ |
| use integer; |
use integer; |
| my $symbchck=unpack("%32S*",$symb) << 16; |
my $symbchck=unpack("%32S*",$symb.' ') << 16; |
| my $symbseed=numval($symb); |
my $symbseed=numval($symb); |
| my $CODEseed=numval($ENV{'scantron.CODE'}) << 16; |
my $CODEseed=numval($ENV{'scantron.CODE'}) << 16; |
| my $courseseed=unpack("%32S*",$courseid); |
my $courseseed=unpack("%32S*",$courseid.' '); |
| my $num1=$symbseed+$CODEseed; |
my $num1=$symbseed+$CODEseed; |
| my $num2=$courseseed+$symbchck; |
my $num2=$courseseed+$symbchck; |
| #&Apache::lonxml::debug("$symbseed:$CODEseed|$courseseed:$symbchck"); |
#&Apache::lonxml::debug("$symbseed:$CODEseed|$courseseed:$symbchck"); |
|
Line 4298 sub mod_perl_version {
|
Line 4414 sub mod_perl_version {
|
| } |
} |
| return 1; |
return 1; |
| } |
} |
| |
|
| |
sub correct_line_ends { |
| |
my ($result)=@_; |
| |
$$result =~s/\r\n/\n/mg; |
| |
$$result =~s/\r/\n/mg; |
| |
} |
| # ================================================================ Main Program |
# ================================================================ Main Program |
| |
|
| sub goodbye { |
sub goodbye { |
| &logthis("Starting Shut down"); |
&logthis("Starting Shut down"); |
| #not converted to using infrastruture |
#not converted to using infrastruture and probably shouldn't be |
| &logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache))); |
|
| &logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache))); |
&logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache))); |
| &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); |
|
| #converted |
#converted |
| |
&logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); |
| |
&logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache))); |
| &logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache))); |
&logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache))); |
| &logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache))); |
&logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache))); |
| #1.1 only |
#1.1 only |
| &logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache))); |
&logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache))); |
| &logthis(sprintf("%-20s is %s",'%usectioncache',scalar(%usectioncache))); |
&logthis(sprintf("%-20s is %s",'%usectioncache',scalar(%usectioncache))); |
| |
&logthis(sprintf("%-20s is %s",'%courseresversioncache',scalar(%courseresversioncache))); |
| |
&logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache))); |
| &flushcourselogs(); |
&flushcourselogs(); |
| &logthis("Shutting down"); |
&logthis("Shutting down"); |
| return DONE; |
return DONE; |
![[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