--- loncom/lonnet/perl/lonnet.pm 2003/09/22 19:32:49 1.421 +++ loncom/lonnet/perl/lonnet.pm 2003/10/30 20:22:00 1.436 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.421 2003/09/22 19:32:49 albertel Exp $ +# $Id: lonnet.pm,v 1.436 2003/10/30 20:22:00 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; @@ -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"; } @@ -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,37 @@ sub getsection { } sub devalidate_cache { - my ($cache,$id) = @_; + my ($cache,$id,$name) = @_; delete $$cache{$id.'.time'}; delete $$cache{$id}; + my $filename=$perlvar{'lonDaemons'}.'/tmp/'.$name.".db"; + open(DB,"$filename.lock"); + flock(DB,LOCK_EX); + my %hash; + if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) { + delete($hash{$id}); + delete($hash{$id.'.time'}); + } else { + &logthis("Unable to tie hash (devalidate cache): $name"); + } + 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 +858,126 @@ 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 { + my ($cache,$name)=@_; + my $starttime=&Time::HiRes::time(); +# &logthis("Saving :$name:"); + eval lock_store($cache,$perlvar{'lonDaemons'}.'/tmp/'.$name.".storable"); + if ($@) { &logthis("lock_store threw a die ".$@); } +# &logthis("save_cache took ".(&Time::HiRes::time()-$starttime)); +} + +sub load_cache { + my ($cache,$name)=@_; + my $starttime=&Time::HiRes::time(); +# &logthis("Before Loading $name size is ".scalar(%$cache)); + my $tmpcache; + eval { + $tmpcache=lock_retrieve($perlvar{'lonDaemons'}.'/tmp/'.$name.".storable"); + }; + 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 { + my $key; + my $count; + while ($key=each(%$tmpcache)) { + if ($key !~/^(.*)\.time$/) { next; } + my $name=$1; + if (exists($$cache{$key})) { + if ($$tmpcache{$key} >= $$cache{$key}) { + $$cache{$key}=$$tmpcache{$key}; + $$cache{$name}=$$tmpcache{$name}; + } else { +# &logthis("Would have overwritten $name with is set to expire at ".$$cache{$key}." with ".$$tmpcache{$key}." Whew!"); + } + } else { + $count++; + $$cache{$key}=$$tmpcache{$key}; + $$cache{$name}=$$tmpcache{$name}; + } + } +# &logthis("Additional load: $count"); + } +# &logthis("After Loading $name size is ".scalar(%$cache)); +# &logthis("load_cache took ".(&Time::HiRes::time()-$starttime)); +} + +sub save_cache_item { + my ($cache,$name,$id)=@_; + my $starttime=&Time::HiRes::time(); + # &logthis("Saving :$name:$id"); + my %hash; + my $filename=$perlvar{'lonDaemons'}.'/tmp/'.$name.".db"; + open(DB,"$filename.lock"); + flock(DB,LOCK_EX); + if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) { + $hash{$id.'.time'}=$$cache{$id.'.time'}; + $hash{$id}=freeze({'item'=>$$cache{$id}}); + } else { + &logthis("Unable to tie hash (save cache item): $name"); + } + 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/'.$name.".db"; + open(DB,"$filename.lock"); + flock(DB,LOCK_SH); + if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) { + 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'}; + } + } else { + &logthis("Unable to tie hash (load cache item): $name"); + } + 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 +998,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 @@ -2220,27 +2318,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 +2331,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 { @@ -2629,6 +2734,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 +2746,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 +3427,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 +3436,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 +3491,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 +3579,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 +3633,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 +3656,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 +3765,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 =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) || + ($uri =~ m|home/[^/]+/public_html/|)) { return ''; } my $filename=$uri; @@ -3643,15 +3779,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 +3811,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 +3886,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 +3907,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 +3924,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 +3938,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 +3947,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 +3970,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 +3983,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'); } @@ -3865,17 +4013,18 @@ sub symblist { sub symbverify { my ($symb,$thisfn)=@_; - $thisfn=&declutter($thisfn); + $thisfn=&symbclean(&declutter($thisfn)); # direct jump to resource in page or to a sequence - will construct own symbs 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); 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 +4063,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 +4076,19 @@ 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; + my %bighash; + my $uri=&clutter($fn); + 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 $fn; + return &declutter($uri); } # ------------------------------------------------------ Return symb list entry @@ -4234,10 +4396,27 @@ sub mod_perl_version { } return 1; } + +sub correct_line_ends { + my ($result)=@_; + &logthis("Wha $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 + &logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache))); + &logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache))); + &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); +#converted + &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))); &flushcourselogs(); &logthis("Shutting down"); return DONE;