--- loncom/lonnet/perl/lonnet.pm	2003/10/06 20:38:25	1.427
+++ loncom/lonnet/perl/lonnet.pm	2003/10/30 22:52:25	1.437
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.427 2003/10/06 20:38:25 www Exp $
+# $Id: lonnet.pm,v 1.437 2003/10/30 22:52:25 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,7 @@ use HTML::LCParser;
 use Fcntl qw(:flock);
 use Apache::loncoursedata;
 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();
 my $readit;
 
@@ -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";
 }
@@ -396,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);
     }
@@ -849,24 +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,$name,$time) = @_;
     if (!$time) { $time=300; }
     if (!exists($$cache{$id.'.time'})) {
-	&load_cache($cache,$name);
+	&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) {
-#	    &logthis("Devailidating $id");
-	    &devalidate_cache($cache,$id);
+#	    &logthis("Devalidating $id - ".time-($$cache{$id.'.time'}));
+	    &devalidate_cache($cache,$id,$name);
 	    return (undef,undef);
 	}
     }
@@ -877,14 +861,15 @@ sub do_cache {
     my ($cache,$id,$value,$name) = @_;
     $$cache{$id.'.time'}=time;
     $$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
     $$cache{$id};
 }
 
 sub save_cache {
     my ($cache,$name)=@_;
-#    my $starttime=&Time::HiRes::time();
+    my $starttime=&Time::HiRes::time();
 #    &logthis("Saving :$name:");
     eval lock_store($cache,$perlvar{'lonDaemons'}.'/tmp/'.$name.".storable");
     if ($@) { &logthis("lock_store threw a die ".$@); }
@@ -893,7 +878,7 @@ sub save_cache {
 
 sub load_cache {
     my ($cache,$name)=@_;
-#    my $starttime=&Time::HiRes::time();
+    my $starttime=&Time::HiRes::time();
 #    &logthis("Before Loading $name size is ".scalar(%$cache));
     my $tmpcache;
     eval {
@@ -932,6 +917,62 @@ sub load_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";
@@ -2693,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;
@@ -2704,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);
     }
 }
 
@@ -2726,10 +2765,8 @@ sub get_symb_from_alias {
         my $rid=$bighash{'mapalias_'.$symb};
 	if ($rid) {
 	    my ($mapid,$resid)=split(/\./,$rid);
-	    $aliassymb=
-		&declutter($bighash{'map_id_'.$mapid}).
-		'___'.$resid.'___'.
-		&declutter($bighash{'src_'.$rid});
+	    $aliassymb=&encode_symb($bighash{'map_id_'.$mapid},
+				    $resid,$bighash{'src_'.$rid});
 	}
         untie %bighash;
     }
@@ -3390,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
@@ -3542,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};
@@ -3734,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'; }
@@ -3761,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'};
 			    }
 			}
 		    }
@@ -3829,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
 		    }
@@ -3850,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);
@@ -3867,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 {
@@ -3881,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;
 	  }
@@ -3890,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\]/;
@@ -3956,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)};
@@ -4005,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));
@@ -4013,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
@@ -4325,6 +4396,13 @@ 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 {