--- loncom/lonnet/perl/lonnet.pm 2003/09/25 19:47:13 1.422
+++ loncom/lonnet/perl/lonnet.pm 2003/11/10 20:27:32 1.443
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.422 2003/09/25 19:47:13 albertel Exp $
+# $Id: lonnet.pm,v 1.443 2003/11/10 20:27:32 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -25,44 +25,6 @@
#
# 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;
@@ -73,7 +35,7 @@ use LWP::UserAgent();
use HTTP::Headers;
use vars
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
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache
%userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def
@@ -86,7 +48,8 @@ use HTML::LCParser;
use Fcntl qw(:flock);
use Apache::loncoursedata;
use Apache::lonlocal;
-
+use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw);
+use Time::HiRes();
my $readit;
# --------------------------------------------------------------------- Logging
@@ -273,10 +236,19 @@ sub transfer_profile_to_env {
$idf->close();
}
my $envi;
+ my %Remove;
for ($envi=0;$envi<=$#profile;$envi++) {
chomp($profile[$envi]);
my ($envname,$envvalue)=split(/=/,$profile[$envi]);
$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";
}
@@ -395,7 +367,7 @@ sub userload {
while ($filename=readdir(LONIDS)) {
if ($filename eq '.' || $filename eq '..') {next;}
my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
- if ($curtime-$mtime < 3600) { $numusers++; }
+ if ($curtime-$mtime < 1800) { $numusers++; }
}
closedir(LONIDS);
}
@@ -585,9 +557,9 @@ sub authenticate {
sub homeserver {
my ($uname,$udom,$ignoreBadCache)=@_;
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;
foreach $tryserver (keys %libserv) {
next if ($ignoreBadCache ne 'true' &&
@@ -595,8 +567,7 @@ sub homeserver {
if ($hostdom{$tryserver} eq $udom) {
my $answer=reply("home:$udom:$uname",$tryserver);
if ($answer eq 'found') {
- $homecache{$index}=$tryserver;
- return $tryserver;
+ return &do_cache(\%homecache,$index,$tryserver,'home');
} elsif ($answer eq 'no_host') {
$badServerCache{$tryserver}=1;
}
@@ -849,19 +820,46 @@ sub getsection {
}
sub devalidate_cache {
- my ($cache,$id) = @_;
+ my ($cache,$id,$name) = @_;
delete $$cache{$id.'.time'};
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("devalidate_cache blew up :$@:$name");
+ 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 {
- my ($cache,$id,$time) = @_;
+ my ($cache,$id,$name,$time) = @_;
if (!$time) { $time=300; }
if (!exists($$cache{$id.'.time'})) {
+ &load_cache_item($cache,$name,$id);
+ }
+ if (!exists($$cache{$id.'.time'})) {
+# &logthis("Didn't find $id");
return (undef,undef);
} else {
- if (time-$$cache{$id.'.time'}>$time) {
- &devalidate_cache($cache,$id);
+ if (time-($$cache{$id.'.time'})>$time) {
+# &logthis("Devalidating $id - ".time-($$cache{$id.'.time'}));
+ &devalidate_cache($cache,$id,$name);
return (undef,undef);
}
}
@@ -869,17 +867,94 @@ sub is_cached {
}
sub do_cache {
- my ($cache,$id,$value) = @_;
+ my ($cache,$id,$value,$name) = @_;
$$cache{$id.'.time'}=time;
- # do_cache implictly return the set value
$$cache{$id}=$value;
+# &logthis("Caching $id as :$value:");
+ &save_cache_item($cache,$name,$id);
+ # do_cache implictly return the set value
+ $$cache{$id};
+}
+
+sub save_cache_item {
+ my ($cache,$name,$id)=@_;
+ my $starttime=&Time::HiRes::time();
+# &logthis("Saving :$name:$id");
+ 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)) {
+ eval <<'EVALBLOCK';
+ $hash{$id.'.time'}=$$cache{$id.'.time'};
+ $hash{$id}=freeze({'item'=>$$cache{$id}});
+EVALBLOCK
+ if ($@) {
+ &logthis("save_cache blew up :$@:$name");
+ unlink($filename);
+ }
+ } else {
+ if (-e $filename) {
+ &logthis("Unable to tie hash (save cache item): $name");
+ unlink($filename);
+ }
+ }
+ untie(%hash);
+ flock(DB,LOCK_UN);
+ close(DB);
+# &logthis("save_cache_item $name took ".(&Time::HiRes::time()-$starttime));
+}
+
+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 {
+ my $hashref=thaw($hash{$id});
+ $$cache{$id}=$hashref->{'item'};
+ $$cache{$id.'.time'}=$hash{$id.'.time'};
+ }
+EVALBLOCK
+ if ($@) {
+ &logthis("load_cache blew up :$@:$name");
+ 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));
}
sub usection {
my ($udom,$unam,$courseid)=@_;
my $hashid="$udom:$unam:$courseid";
- my ($result,$cached)=&is_cached(\%usectioncache,$hashid);
+ my ($result,$cached)=&is_cached(\%usectioncache,$hashid,'usection');
if (defined($cached)) { return $result; }
$courseid=~s/\_/\//g;
$courseid=~s/^(\w)/\/$1/;
@@ -900,11 +975,11 @@ sub usection {
if ($now>$end) { $notactive=1; }
}
unless ($notactive) {
- return &do_cache(\%usectioncache,$hashid,$section);
+ return &do_cache(\%usectioncache,$hashid,$section,'usection');
}
}
}
- return &do_cache(\%usectioncache,$hashid,'-1');
+ return &do_cache(\%usectioncache,$hashid,'-1','usection');
}
# ------------------------------------- Read an entry from a user's environment
@@ -944,6 +1019,8 @@ sub getversion {
sub currentversion {
my $fname=shift;
+ my ($result,$cached)=&is_cached(\%resversioncache,$fname,'resversion',600);
+ if (defined($cached)) { return $result; }
my $author=$fname;
$author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
my ($udom,$uname)=split(/\//,$author);
@@ -955,7 +1032,7 @@ sub currentversion {
if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
return -1;
}
- return $answer;
+ return &do_cache(\%resversioncache,$fname,$answer,'resversion');
}
# ----------------------------- Subscribe to a resource, return URL if possible
@@ -990,7 +1067,7 @@ sub repcopy {
&logthis("Subscribe returned $remoteurl: $filename");
return HTTP_SERVICE_UNAVAILABLE;
} elsif ($remoteurl eq 'not_found') {
- &logthis("Subscribe returned not_found: $filename");
+ #&logthis("Subscribe returned not_found: $filename");
return HTTP_NOT_FOUND;
} elsif ($remoteurl =~ /^rejected by/) {
&logthis("Subscribe returned $remoteurl: $filename");
@@ -2220,27 +2297,7 @@ sub currentdump {
return if ($tmp[0] =~ /^(error:|no_such_host)/);
my %hash = @tmp;
@tmp=();
- # Code ripped from lond, essentially. The only difference
- # here is the unescaping done by lonnet::dump(). Conceivably
- # we might run in to problems with parameter names =~ /^v\./
- while (my ($key,$value) = each(%hash)) {
- my ($v,$symb,$param) = split(/:/,$key);
- next if ($v eq 'version' || $symb eq 'keys');
- next if (exists($returnhash{$symb}) &&
- exists($returnhash{$symb}->{$param}) &&
- $returnhash{$symb}->{'v.'.$param} > $v);
- $returnhash{$symb}->{$param}=$value;
- $returnhash{$symb}->{'v.'.$param}=$v;
- }
- #
- # Remove all of the keys in the hashes which keep track of
- # the version of the parameter.
- while (my ($symb,$param_hash) = each(%returnhash)) {
- # use a foreach because we are going to delete from the hash.
- foreach my $key (keys(%$param_hash)) {
- delete($param_hash->{$key}) if ($key =~ /^v\./);
- }
- }
+ %returnhash = %{&convert_dump_to_currentdump(\%hash)};
} else {
my @pairs=split(/\&/,$rep);
foreach (@pairs) {
@@ -2253,6 +2310,33 @@ sub currentdump {
return %returnhash;
}
+sub convert_dump_to_currentdump{
+ my %hash = %{shift()};
+ my %returnhash;
+ # Code ripped from lond, essentially. The only difference
+ # here is the unescaping done by lonnet::dump(). Conceivably
+ # we might run in to problems with parameter names =~ /^v\./
+ while (my ($key,$value) = each(%hash)) {
+ my ($v,$symb,$param) = split(/:/,$key);
+ next if ($v eq 'version' || $symb eq 'keys');
+ next if (exists($returnhash{$symb}) &&
+ exists($returnhash{$symb}->{$param}) &&
+ $returnhash{$symb}->{'v.'.$param} > $v);
+ $returnhash{$symb}->{$param}=$value;
+ $returnhash{$symb}->{'v.'.$param}=$v;
+ }
+ #
+ # Remove all of the keys in the hashes which keep track of
+ # the version of the parameter.
+ while (my ($symb,$param_hash) = each(%returnhash)) {
+ # use a foreach because we are going to delete from the hash.
+ foreach my $key (keys(%$param_hash)) {
+ delete($param_hash->{$key}) if ($key =~ /^v\./);
+ }
+ }
+ return \%returnhash;
+}
+
# --------------------------------------------------------------- put interface
sub put {
@@ -2344,7 +2428,7 @@ sub customaccess {
sub allowed {
my ($priv,$uri)=@_;
-
+ $uri=&deversion($uri);
my $orguri=$uri;
$uri=&declutter($uri);
@@ -2629,6 +2713,7 @@ sub allowed {
sub is_on_map {
my $uri=&declutter(shift);
+ $uri=~s/\.\d+\.(\w+)$/\.$1/;
my @uriparts=split(/\//,$uri);
my $filename=$uriparts[$#uriparts];
my $pathname=$uri;
@@ -2640,13 +2725,33 @@ sub is_on_map {
if ($match) {
return (1,$1);
} else {
- my ($name,$ext)=($filename=~/^(.+)\.(\w+)$/);
- $ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
- /\&(\Q$name\E\.\d+\.$ext)\:([\d\|]+)\&/;
- return (0,$2,$pathname.'/'.$1);
+ return (0,0);
}
}
+# --------------------------------------------------------- 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
sub definerole {
@@ -3301,7 +3406,7 @@ sub condval {
sub devalidatecourseresdata {
my ($coursenum,$coursedomain)=@_;
my $hashid=$coursenum.':'.$coursedomain;
- &devalidate_cache(\%courseresdatacache,$hashid);
+ &devalidate_cache(\%courseresdatacache,$hashid,'courseres');
}
# --------------------------------------------------- Course Resourcedata Query
@@ -3310,18 +3415,18 @@ sub courseresdata {
my ($coursenum,$coursedomain,@which)=@_;
my $coursehom=&homeserver($coursenum,$coursedomain);
my $hashid=$coursenum.':'.$coursedomain;
- my ($result,$cached)=&is_cached(\%courseresdatacache,$hashid);
+ my ($result,$cached)=&is_cached(\%courseresdatacache,$hashid,'courseres');
unless (defined($cached)) {
my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum);
$result=\%dumpreply;
my ($tmp) = keys(%dumpreply);
if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
- &do_cache(\%courseresdatacache,$hashid,$result);
+ &do_cache(\%courseresdatacache,$hashid,$result,'courseres');
} elsif ($tmp =~ /^(con_lost|no_such_host)/) {
return $tmp;
} elsif ($tmp =~ /^(error)/) {
$result=undef;
- &do_cache(\%courseresdatacache,$hashid,$result);
+ &do_cache(\%courseresdatacache,$hashid,$result,'courseres');
}
}
foreach my $item (@which) {
@@ -3365,6 +3470,9 @@ sub EXT {
#get real user name/domain, courseid and symb
my $courseid;
my $publicuser;
+ if ($symbparm) {
+ $symbparm=&get_symb_from_alias($symbparm);
+ }
if (!($uname && $udom)) {
(my $cursymb,$courseid,$udom,$uname,$publicuser)=
&Apache::lonxml::whichuser($symbparm);
@@ -3450,7 +3558,15 @@ sub EXT {
} elsif ($realm eq 'request') {
# ------------------------------------------------------------- request.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
} else {
return $ENV{'request.'.$spacequalifierrest};
@@ -3496,16 +3612,17 @@ sub EXT {
#most student don\'t have any data set, check if there is some data
if (! &EXT_cache_status($udom,$uname)) {
my $hashid="$udom:$uname";
- my ($result,$cached)=&is_cached(\%userresdatacache,$hashid);
+ my ($result,$cached)=&is_cached(\%userresdatacache,$hashid,
+ 'userres');
if (!defined($cached)) {
my %resourcedata=&get('resourcedata',
[$courselevelr,$courselevelm,
$courselevel],$udom,$uname);
$result=\%resourcedata;
+ &do_cache(\%userresdatacache,$hashid,$result,'userres');
}
my ($tmp)=keys(%$result);
if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {
- &do_cache(\%userresdatacache,$hashid,$result);
if ($$result{$courselevelr}) {
return $$result{$courselevelr}; }
if ($$result{$courselevelm}) {
@@ -3518,11 +3635,9 @@ sub EXT {
" Trying to get resource data for ".
$uname." at ".$udom.": ".
$tmp."");
- &do_cache(\%userresdatacache,$hashid,undef);
} elsif ($tmp=~/error:No such file/) {
&EXT_cache_set($udom,$uname);
} elsif ($tmp =~ /^(con_lost|no_such_host)/) {
- &do_cache(\%userresdatacache,$hashid,undef);
return $tmp;
}
}
@@ -3629,11 +3744,11 @@ sub add_prefix_and_part {
sub metadata {
my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
-
$uri=&declutter($uri);
# if it is a non metadata possible uri return quickly
if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) ||
- ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/)) {
+ ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
+ ($uri =~ m|home/[^/]+/public_html/|)) {
return '';
}
my $filename=$uri;
@@ -3643,15 +3758,20 @@ sub metadata {
# Look at timestamp of caching
# 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?
#
+ my %lcmetacache;
if ($liburi) {
$liburi=&declutter($liburi);
$filename=$liburi;
} else {
- delete($metacache{$uri.':packages'});
+ &devalidate_cache(\%metacache,$uri,'meta');
}
my %metathesekeys=();
unless ($filename=~/\.meta$/) { $filename.='.meta'; }
@@ -3670,32 +3790,39 @@ sub metadata {
if (defined($token->[2]->{'id'})) {
$keyroot.='_'.$token->[2]->{'id'};
}
- if ($metacache{$uri.':packages'}) {
- $metacache{$uri.':packages'}.=','.$package.$keyroot;
+ if ($lcmetacache{':packages'}) {
+ $lcmetacache{':packages'}.=','.$package.$keyroot;
} else {
- $metacache{$uri.':packages'}=$package.$keyroot;
+ $lcmetacache{':packages'}=$package.$keyroot;
}
foreach (keys %packagetab) {
- if ($_=~/^$package\&/) {
+ my $part=$keyroot;
+ $part=~s/^\_//;
+ if ($_=~/^\Q$package\E\&/ ||
+ $_=~/^\Q$package\E_0\&/) {
my ($pack,$name,$subp)=split(/\&/,$_);
# ignore package.tab specified default values
# here &package_tab_default() will fetch those
if ($subp eq 'default') { next; }
my $value=$packagetab{$_};
- my $part=$keyroot;
- $part=~s/^\_//;
+ my $unikey;
+ if ($pack =~ /_0$/) {
+ $unikey='parameter_0_'.$name;
+ $part=0;
+ } else {
+ $unikey='parameter'.$keyroot.'_'.$name;
+ }
if ($subp eq 'display') {
$value.=' [Part: '.$part.']';
}
- my $unikey='parameter'.$keyroot.'_'.$name;
- $metacache{$uri.':'.$unikey.'.part'}=$part;
+ $lcmetacache{':'.$unikey.'.part'}=$part;
$metathesekeys{$unikey}=1;
- unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {
- $metacache{$uri.':'.$unikey.'.'.$subp}=$value;
+ unless (defined($lcmetacache{':'.$unikey.'.'.$subp})) {
+ $lcmetacache{':'.$unikey.'.'.$subp}=$value;
}
- if (defined($metacache{$uri.':'.$unikey.'.default'})) {
- $metacache{$uri.':'.$unikey}=
- $metacache{$uri.':'.$unikey.'.default'};
+ if (defined($lcmetacache{':'.$unikey.'.default'})) {
+ $lcmetacache{':'.$unikey}=
+ $lcmetacache{':'.$unikey.'.default'};
}
}
}
@@ -3738,18 +3865,18 @@ sub metadata {
}
$metathesekeys{$unikey}=1;
foreach (@{$token->[3]}) {
- $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};
+ $lcmetacache{':'.$unikey.'.'.$_}=$token->[2]->{$_};
}
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*$/) {
# only ws inside the tag, and not in default, so use default
# as value
- $metacache{$uri.':'.$unikey}=$default;
+ $lcmetacache{':'.$unikey}=$default;
} else {
# either something interesting inside the tag or default
# uninteresting
- $metacache{$uri.':'.$unikey}=$internaltext;
+ $lcmetacache{':'.$unikey}=$internaltext;
}
# end of not-a-package not-a-library import
}
@@ -3759,13 +3886,13 @@ sub metadata {
}
}
# are there custom rights to evaluate
- if ($metacache{$uri.':copyright'} eq 'custom') {
+ if ($lcmetacache{':copyright'} eq 'custom') {
#
# Importing a rights file here
#
unless ($depthcount) {
- my $location=$metacache{$uri.':customdistributionfile'};
+ my $location=$lcmetacache{':customdistributionfile'};
my $dir=$filename;
$dir=~s|[^/]*$||;
$location=&filelocation($dir,$location);
@@ -3776,13 +3903,13 @@ sub metadata {
}
}
}
- $metacache{$uri.':keys'}=join(',',keys %metathesekeys);
- &metadata_generate_part0(\%metathesekeys,\%metacache,$uri);
- $metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys);
- $metacache{$uri.':cachedtimestamp'}=time;
+ $lcmetacache{':keys'}=join(',',keys %metathesekeys);
+ &metadata_generate_part0(\%metathesekeys,\%lcmetacache,$uri);
+ $lcmetacache{':allpossiblekeys'}=join(',',keys %metathesekeys);
+ &do_cache(\%metacache,$uri,\%lcmetacache,'meta');
# this is the end of "was not already recently cached
}
- return $metacache{$uri.':'.$what};
+ return $metacache{$uri}->{':'.$what};
}
sub metadata_generate_part0 {
@@ -3790,8 +3917,8 @@ sub metadata_generate_part0 {
my %allnames;
foreach my $metakey (sort keys %$metadata) {
if ($metakey=~/^parameter\_(.*)/) {
- my $part=$$metacache{$uri.':'.$metakey.'.part'};
- my $name=$$metacache{$uri.':'.$metakey.'.name'};
+ my $part=$$metacache{':'.$metakey.'.part'};
+ my $name=$$metacache{':'.$metakey.'.name'};
if (! exists($$metadata{'parameter_0_'.$name.'.name'})) {
$allnames{$name}=$part;
}
@@ -3799,13 +3926,13 @@ sub metadata_generate_part0 {
}
foreach my $name (keys(%allnames)) {
$$metadata{"parameter_0_$name"}=1;
- my $key="$uri:parameter_0_$name";
+ my $key=":parameter_0_$name";
$$metacache{"$key.part"}='0';
$$metacache{"$key.name"}=$name;
- $$metacache{"$key.type"}=$$metacache{$uri.':parameter_'.
+ $$metacache{"$key.type"}=$$metacache{':parameter_'.
$allnames{$name}.'_'.$name.
'.type'};
- my $olddis=$$metacache{$uri.':parameter_'.$allnames{$name}.'_'.$name.
+ my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name.
'.display'};
my $expr='\\[Part: '.$allnames{$name}.'\\]';
$olddis=~s/$expr/\[Part: 0\]/;
@@ -3822,7 +3949,7 @@ sub gettitle {
unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; }
return &metadata($urlsymb,'title');
}
- my ($result,$cached)=&is_cached(\%titlecache,$symb,600);
+ my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);
if (defined($cached)) { return $result; }
my ($map,$resid,$url)=&decode_symb($symb);
my $title='';
@@ -3835,7 +3962,7 @@ sub gettitle {
}
$title=~s/\&colon\;/\:/gs;
if ($title) {
- return &do_cache(\%titlecache,$symb,$title);
+ return &do_cache(\%titlecache,$symb,$title,'title');
} else {
return &metadata($urlsymb,'title');
}
@@ -3845,13 +3972,13 @@ sub gettitle {
sub symblist {
my ($mapname,%newhash)=@_;
- $mapname=declutter($mapname);
+ $mapname=&deversion(&declutter($mapname));
my %hash;
if (($ENV{'request.course.fn'}) && (%newhash)) {
if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
&GDBM_WRCREAT(),0640)) {
foreach (keys %newhash) {
- $hash{declutter($_)}=$mapname.'___'.$newhash{$_};
+ $hash{declutter($_)}=$mapname.'___'.&deversion($newhash{$_});
}
if (untie(%hash)) {
return 'ok';
@@ -3870,12 +3997,15 @@ sub symbverify {
if ($thisfn=~/\.(page|sequence)$/) { return 1; }
# check URL part
my ($map,$resid,$url)=&decode_symb($symb);
- unless (&symbclean($url) eq &symbclean($thisfn)) { return 0; }
+
+ unless ($url eq $thisfn) { return 0; }
$symb=&symbclean($symb);
+ $thisfn=&deversion($thisfn);
my %bighash;
my $okay=0;
+
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
&GDBM_READER(),0640)) {
my $ids=$bighash{'ids_'.&clutter($thisfn)};
@@ -3914,6 +4044,11 @@ sub symbclean {
# ---------------------------------------------- Split symb to find map and url
+sub encode_symb {
+ my ($map,$resid,$url)=@_;
+ return &symbclean(&declutter($map).'___'.$resid.'___'.&declutter($url));
+}
+
sub decode_symb {
my ($map,$resid,$url)=split(/\_\_\_/,shift);
return (&fixversion($map),$resid,&fixversion($url));
@@ -3922,11 +4057,32 @@ sub decode_symb {
sub fixversion {
my $fn=shift;
if ($fn=~/^(adm|uploaded|public)/) { return $fn; }
- my ($match,$cond,$versioned)=&is_on_map($fn);
- unless ($match) {
- $fn=$versioned;
- }
- return $fn;
+ my %bighash;
+ my $uri=&clutter($fn);
+ my $key=$ENV{'request.course.id'}.'_'.$uri;
+# is this cached?
+ 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
@@ -4026,7 +4182,7 @@ sub numval {
}
sub latest_rnd_algorithm_id {
- return '64bit';
+ return '64bit2';
}
sub rndseed {
@@ -4043,6 +4199,8 @@ sub rndseed {
my $CODE=$ENV{'scantron.CODE'};
if (defined($CODE)) {
&rndseed_CODE_64bit($symb,$courseid,$domain,$username);
+ } elsif ($which eq '64bit2') {
+ return &rndseed_64bit2($symb,$courseid,$domain,$username);
} elsif ($which eq '64bit') {
return &rndseed_64bit($symb,$courseid,$domain,$username);
}
@@ -4086,14 +4244,36 @@ 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 {
my ($symb,$courseid,$domain,$username)=@_;
{
use integer;
- my $symbchck=unpack("%32S*",$symb) << 16;
+ my $symbchck=unpack("%32S*",$symb.' ') << 16;
my $symbseed=numval($symb);
my $CODEseed=numval($ENV{'scantron.CODE'}) << 16;
- my $courseseed=unpack("%32S*",$courseid);
+ my $courseseed=unpack("%32S*",$courseid.' ');
my $num1=$symbseed+$CODEseed;
my $num2=$courseseed+$symbchck;
#&Apache::lonxml::debug("$symbseed:$CODEseed|$courseseed:$symbchck");
@@ -4234,10 +4414,28 @@ sub mod_perl_version {
}
return 1;
}
+
+sub correct_line_ends {
+ my ($result)=@_;
+ $$result =~s/\r\n/\n/mg;
+ $$result =~s/\r/\n/mg;
+}
# ================================================================ Main Program
sub goodbye {
&logthis("Starting Shut down");
+#not converted to using infrastruture and probably shouldn't be
+ &logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache)));
+#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",'%courseresdatacache',scalar(%courseresdatacache)));
+#1.1 only
+ &logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache)));
+ &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();
&logthis("Shutting down");
return DONE;