--- loncom/lonnet/perl/lonnet.pm	2003/11/01 16:37:21	1.439
+++ loncom/lonnet/perl/lonnet.pm	2003/11/10 23:57:49	1.446
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.439 2003/11/01 16:37:21 www Exp $
+# $Id: lonnet.pm,v 1.446 2003/11/10 23:57:49 albertel Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -35,7 +35,7 @@ use LWP::UserAgent();
 use HTTP::Headers;
 use vars 
 qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom 
-   %libserv %pr %prp %metacache %packagetab %titlecache 
+   %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache
    %courselogs %accesshash %userrolehash $processmarker $dumpcount 
    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache 
    %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def 
@@ -247,10 +247,10 @@ sub transfer_profile_to_env {
             }
         }
     }
+    $ENV{'user.environment'} = "$lonidsdir/$handle.id";
     foreach my $expired_key (keys(%Remove)) {
         &delenv($expired_key);
     }
-    $ENV{'user.environment'} = "$lonidsdir/$handle.id";
 }
 
 # ---------------------------------------------------------- Append Environment
@@ -823,15 +823,24 @@ sub devalidate_cache {
     my ($cache,$id,$name) = @_;
     delete $$cache{$id.'.time'};
     delete $$cache{$id};
-    my $filename=$perlvar{'lonDaemons'}.'/tmp/'.$name.".db";
+    my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$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'});
+	eval <<'EVALBLOCK';
+	    delete($hash{$id});
+	    delete($hash{$id.'.time'});
+EVALBLOCK
+        if ($@) {
+	    &logthis("<font color='red'>devalidate_cache blew up :$@:$name</font>");
+	    unlink($filename);
+	}
     } else {
-	&logthis("Unable to tie hash (devalidate cache): $name");
+	if (-e $filename) {
+	    &logthis("Unable to tie hash (devalidate cache): $name");
+	    unlink($filename);
+	}
     }
     untie(%hash);
     flock(DB,LOCK_UN);
@@ -867,69 +876,28 @@ sub do_cache {
     $$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");
+#    &logthis("Saving :$name:$id");
     my %hash;
-    my $filename=$perlvar{'lonDaemons'}.'/tmp/'.$name.".db";
+    my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$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}});
+	eval <<'EVALBLOCK';
+	    $hash{$id.'.time'}=$$cache{$id.'.time'};
+	    $hash{$id}=freeze({'item'=>$$cache{$id}});
+EVALBLOCK
+        if ($@) {
+	    &logthis("<font color='red'>save_cache blew up :$@:$name</font>");
+	    unlink($filename);
+	}
     } else {
-	&logthis("Unable to tie hash (save cache item): $name");
+	if (-e $filename) {
+	    &logthis("Unable to tie hash (save cache item): $name ($!)");
+	    unlink($filename);
+	}
     }
     untie(%hash);
     flock(DB,LOCK_UN);
@@ -942,29 +910,38 @@ sub load_cache_item {
     my $starttime=&Time::HiRes::time();
 #    &logthis("Before Loading $name  for $id size is ".scalar(%$cache));
     my %hash;
-    my $filename=$perlvar{'lonDaemons'}.'/tmp/'.$name.".db";
+    my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$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'};
+	eval <<'EVALBLOCK';
+	    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 {
+		my $hashref=thaw($hash{$id});
+		$$cache{$id}=$hashref->{'item'};
+		$$cache{$id.'.time'}=$hash{$id.'.time'};
+	    }
+EVALBLOCK
+        if ($@) {
+	    &logthis("<font color='red'>load_cache blew up :$@:$name</font>");
+	    unlink($filename);
+	}        
     } else {
-	&logthis("Unable to tie hash (load cache item): $name");
+	if (-e $filename) {
+	    &logthis("Unable to tie hash (load cache item): $name ($!)");
+	    unlink($filename);
+	}
     }
     untie(%hash);
     flock(DB,LOCK_UN);
@@ -1042,6 +1019,8 @@ sub getversion {
 
 sub currentversion {
     my $fname=shift;
+    my ($result,$cached)=&is_cached(\%resversioncache,$fname,'resversion',600);
+    if (defined($cached)) { return $result; }
     my $author=$fname;
     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
     my ($udom,$uname)=split(/\//,$author);
@@ -1053,7 +1032,7 @@ sub currentversion {
     if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
 	return -1;
     }
-    return $answer;
+    return &do_cache(\%resversioncache,$fname,$answer,'resversion');
 }
 
 # ----------------------------- Subscribe to a resource, return URL if possible
@@ -1088,7 +1067,7 @@ sub repcopy {
 	   &logthis("Subscribe returned $remoteurl: $filename");
            return HTTP_SERVICE_UNAVAILABLE;
     } elsif ($remoteurl eq 'not_found') {
-	   &logthis("Subscribe returned not_found: $filename");
+	   #&logthis("Subscribe returned not_found: $filename");
 	   return HTTP_NOT_FOUND;
     } elsif ($remoteurl =~ /^rejected by/) {
 	   &logthis("Subscribe returned $remoteurl: $filename");
@@ -4080,17 +4059,25 @@ sub fixversion {
     if ($fn=~/^(adm|uploaded|public)/) { return $fn; }
     my %bighash;
     my $uri=&clutter($fn);
+    my $key=$ENV{'request.course.id'}.'_'.$uri;
+# is this cached?
+    my ($result,$cached)=&is_cached(\%courseresversioncache,$key,
+				    'courseresversion',600);
+    if (defined($cached)) { return $result; }
+# unfortunately not cached, or expired
     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;
+	    &GDBM_READER(),0640)) {
+ 	if ($bighash{'version_'.$uri}) {
+ 	    my $version=$bighash{'version_'.$uri};
+ 	    unless (($version eq 'mostrecent') || 
+		    ($version==&getversion($uri))) {
+ 		$uri=~s/\.(\w+)$/\.$version\.$1/;
+ 	    }
+ 	}
+ 	untie %bighash;
     }
-    return &declutter($uri);
+    return &do_cache
+	(\%courseresversioncache,$key,&declutter($uri),'courseresversion');
 }
 
 sub deversion {
@@ -4196,7 +4183,7 @@ sub numval {
 }
 
 sub latest_rnd_algorithm_id {
-    return '64bit';
+    return '64bit2';
 }
 
 sub rndseed {
@@ -4213,6 +4200,8 @@ sub rndseed {
     my $CODE=$ENV{'scantron.CODE'};
     if (defined($CODE)) {
 	&rndseed_CODE_64bit($symb,$courseid,$domain,$username);
+    } elsif ($which eq '64bit2') {
+	return &rndseed_64bit2($symb,$courseid,$domain,$username);
     } elsif ($which eq '64bit') {
 	return &rndseed_64bit($symb,$courseid,$domain,$username);
     }
@@ -4256,14 +4245,36 @@ sub rndseed_64bit {
     }
 }
 
+sub rndseed_64bit2 {
+    my ($symb,$courseid,$domain,$username)=@_;
+    {
+	use integer;
+	# strings need to be an even # of cahracters long, it it is odd the
+        # last characters gets thrown away
+	my $symbchck=unpack("%32S*",$symb.' ') << 21;
+	my $symbseed=numval($symb) << 10;
+	my $namechck=unpack("%32S*",$username.' ');
+	
+	my $nameseed=numval($username) << 21;
+	my $domainseed=unpack("%32S*",$domain.' ') << 10;
+	my $courseseed=unpack("%32S*",$courseid.' ');
+	
+	my $num1=$symbchck+$symbseed+$namechck;
+	my $num2=$nameseed+$domainseed+$courseseed;
+	#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
+	#&Apache::lonxml::debug("rndseed :$num:$symb");
+	return "$num1,$num2";
+    }
+}
+
 sub rndseed_CODE_64bit {
     my ($symb,$courseid,$domain,$username)=@_;
     {
 	use integer;
-	my $symbchck=unpack("%32S*",$symb) << 16;
+	my $symbchck=unpack("%32S*",$symb.' ') << 16;
 	my $symbseed=numval($symb);
 	my $CODEseed=numval($ENV{'scantron.CODE'}) << 16;
-	my $courseseed=unpack("%32S*",$courseid);
+	my $courseseed=unpack("%32S*",$courseid.' ');
 	my $num1=$symbseed+$CODEseed;
 	my $num2=$courseseed+$symbchck;
 	#&Apache::lonxml::debug("$symbseed:$CODEseed|$courseseed:$symbchck");
@@ -4407,7 +4418,6 @@ sub mod_perl_version {
 
 sub correct_line_ends {
     my ($result)=@_;
-    &logthis("Wha $result");
     $$result =~s/\r\n/\n/mg;
     $$result =~s/\r/\n/mg;
 }
@@ -4415,16 +4425,18 @@ sub correct_line_ends {
 
 sub goodbye {
    &logthis("Starting Shut down");
-#not converted to using infrastruture
-   &logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache)));
+#not converted to using infrastruture and probably shouldn't be
    &logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache)));
-   &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
 #converted
+   &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
+   &logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache)));
    &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)));
+   &logthis(sprintf("%-20s is %s",'%courseresversioncache',scalar(%courseresversioncache)));
+   &logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache)));
    &flushcourselogs();
    &logthis("Shutting down");
    return DONE;