--- loncom/lonnet/perl/lonnet.pm 2003/10/12 22:02:44 1.430 +++ loncom/lonnet/perl/lonnet.pm 2003/10/30 00:26:25 1.435 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.430 2003/10/12 22:02:44 www Exp $ +# $Id: lonnet.pm,v 1.435 2003/10/30 00:26:25 www 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; @@ -274,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"; } @@ -860,7 +831,7 @@ sub devalidate_cache { delete($hash{$id}); delete($hash{$id.'.time'}); } else { - &logthis("Unable to tie hash"); + &logthis("Unable to tie hash (devalidate cache): $name"); } untie(%hash); flock(DB,LOCK_UN); @@ -878,7 +849,7 @@ sub is_cached { return (undef,undef); } else { if (time-($$cache{$id.'.time'})>$time) { -# &logthis("Devailidating $id - ".time-($$cache{$id.'.time'})); +# &logthis("Devalidating $id - ".time-($$cache{$id.'.time'})); &devalidate_cache($cache,$id,$name); return (undef,undef); } @@ -958,7 +929,7 @@ sub save_cache_item { $hash{$id.'.time'}=$$cache{$id.'.time'}; $hash{$id}=freeze({'item'=>$$cache{$id}}); } else { - &logthis("Unable to tie hash"); + &logthis("Unable to tie hash (save cache item): $name"); } untie(%hash); flock(DB,LOCK_UN); @@ -993,7 +964,7 @@ sub load_cache_item { $$cache{$id.'.time'}=$hash{$id.'.time'}; } } else { - &logthis("Unable to tie hash"); + &logthis("Unable to tie hash (load cache item): $name"); } untie(%hash); flock(DB,LOCK_UN); @@ -2763,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; @@ -2774,10 +2746,7 @@ 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); } } @@ -3848,18 +3817,25 @@ sub metadata { $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; $lcmetacache{':'.$unikey.'.part'}=$part; $metathesekeys{$unikey}=1; unless (defined($lcmetacache{':'.$unikey.'.'.$subp})) { @@ -4037,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)}; @@ -4099,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