--- loncom/lonnet/perl/lonnet.pm	2003/10/06 20:38:25	1.427
+++ loncom/lonnet/perl/lonnet.pm	2003/10/22 18:29:28	1.431
@@ -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.431 2003/10/22 18:29:28 www Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -86,7 +86,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;
 
@@ -849,24 +849,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");
+    }
+    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("Devailidating $id - ".time-($$cache{$id.'.time'}));
+	    &devalidate_cache($cache,$id,$name);
 	    return (undef,undef);
 	}
     }
@@ -877,14 +890,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 +907,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 +946,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");
+    }
+    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");
+    }
+    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";
@@ -2726,10 +2796,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 +3458,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 +3610,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 +3810,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,10 +3842,10 @@ 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\&/) {
@@ -3779,14 +3860,14 @@ sub metadata {
 				$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 +3910,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 +3931,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 +3948,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 +3962,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 +3971,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 +4037,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 +4087,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));