--- loncom/lonnet/perl/lonnet.pm	2003/10/06 20:38:25	1.427
+++ loncom/lonnet/perl/lonnet.pm	2003/10/07 07:20:05	1.428
@@ -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.428 2003/10/07 07:20:05 albertel 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";
@@ -3390,7 +3460,7 @@ sub condval {
 sub devalidatecourseresdata {
     my ($coursenum,$coursedomain)=@_;
     my $hashid=$coursenum.':'.$coursedomain;
-    &devalidate_cache(\%courseresdatacache,$hashid);
+    &devalidate_cache(\%courseresdatacache,$hashid,'courseres');
 }
 
 # --------------------------------------------------- Course Resourcedata Query
@@ -3734,15 +3804,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 +3836,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 +3854,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 +3904,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 +3925,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 +3942,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 +3956,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 +3965,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\]/;