--- loncom/lonnet/perl/lonnet.pm	2004/09/15 20:41:07	1.523.2.2
+++ loncom/lonnet/perl/lonnet.pm	2004/11/06 21:18:27	1.523.2.11
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.523.2.2 2004/09/15 20:41:07 albertel Exp $
+# $Id: lonnet.pm,v 1.523.2.11 2004/11/06 21:18:27 albertel Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -52,6 +52,7 @@ use Apache::lonlocal;
 use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw);
 use Time::HiRes qw( gettimeofday tv_interval );
 my $readit;
+my $_64bit;
 
 =pod
 
@@ -795,11 +796,11 @@ sub getsection {
         if ($key eq $courseid.'_st') { $section=''; }
         my ($dummy,$end,$start)=split(/\_/,&unescape($value));
         my $now=time;
-        if (defined($end) && ($now > $end)) {
+        if (defined($end) && $end && ($now > $end)) {
             $Expired{$end}=$section;
             next;
         }
-        if (defined($start) && ($now < $start)) {
+        if (defined($start) && $start && ($now < $start)) {
             $Pending{$start}=$section;
             next;
         }
@@ -826,10 +827,12 @@ my $disk_caching_disabled=1;
 sub devalidate_cache {
     my ($cache,$id,$name) = @_;
     delete $$cache{$id.'.time'};
+    delete $$cache{$id.'.file'};
     delete $$cache{$id};
-    if ($disk_caching_disabled) { return; }
+    if (1 || $disk_caching_disabled) { return; }
     my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
-    open(DB,"$filename.lock");
+    if (!-e $filename) { return; }
+    open(DB,">$filename.lock");
     flock(DB,LOCK_EX);
     my %hash;
     if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
@@ -856,16 +859,32 @@ sub is_cached {
     my ($cache,$id,$name,$time) = @_;
     if (!$time) { $time=300; }
     if (!exists($$cache{$id.'.time'})) {
-	&load_cache_item($cache,$name,$id);
+	&load_cache_item($cache,$name,$id,$time);
     }
     if (!exists($$cache{$id.'.time'})) {
 #	&logthis("Didn't find $id");
 	return (undef,undef);
     } else {
 	if (time-($$cache{$id.'.time'})>$time) {
-#	    &logthis("Devalidating $id - ".time-($$cache{$id.'.time'}));
-	    &devalidate_cache($cache,$id,$name);
-	    return (undef,undef);
+	    if (exists($$cache{$id.'.file'})) {
+		foreach my $filename (@{ $$cache{$id.'.file'} }) {
+		    my $mtime=(stat($filename))[9];
+		    #+1 is to take care of edge effects
+		    if ($mtime && (($mtime+1) < ($$cache{$id.'.time'}))) {
+#			&logthis("Upping $mtime - ".$$cache{$id.'.time'}.
+#				 "$id because of $filename");
+		    } else {
+#			&logthis("Devalidating $filename $id - ".(time-($$cache{$id.'.time'})));
+			&devalidate_cache($cache,$id,$name);
+			return (undef,undef);
+		    }
+		}
+		$$cache{$id.'.time'}=time;
+	    } else {
+#		&logthis("Devalidating $id - ".time-($$cache{$id.'.time'}));
+		&devalidate_cache($cache,$id,$name);
+		return (undef,undef);
+	    }
 	}
     }
     return ($$cache{$id},1);
@@ -881,44 +900,69 @@ sub do_cache {
     $$cache{$id};
 }
 
+my %do_save_item;
+my %do_save;
 sub save_cache_item {
     my ($cache,$name,$id)=@_;
     if ($disk_caching_disabled) { return; }
-    my $starttime=&Time::HiRes::time();
-#    &logthis("Saving :$name:$id");
-    my %hash;
-    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)) {
-	eval <<'EVALBLOCK';
-	    $hash{$id.'.time'}=$$cache{$id.'.time'};
-	    $hash{$id}=freeze({'item'=>$$cache{$id}});
+    $do_save{$name}=$cache;
+    if (!exists($do_save_item{$name})) { $do_save_item{$name}={} }
+    $do_save_item{$name}->{$id}=1;
+    return;
+}
+
+sub save_cache {
+    if ($disk_caching_disabled) { return; }
+    my ($cache,$name,$id);
+    foreach $name (keys(%do_save)) {
+	$cache=$do_save{$name};
+
+	my $starttime=&Time::HiRes::time();
+	&logthis("Saving :$name:");
+	my %hash;
+	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)) {
+	    foreach $id (keys(%{ $do_save_item{$name} })) {
+		eval <<'EVALBLOCK';
+		$hash{$id.'.time'}=$$cache{$id.'.time'};
+		$hash{$id}=freeze({'item'=>$$cache{$id}});
+		if (exists($$cache{$id.'.file'})) {
+		    $hash{$id.'.file'}=freeze({'item'=>$$cache{$id.'.file'}});
+		}
 EVALBLOCK
-        if ($@) {
-	    &logthis("<font color='red'>save_cache blew up :$@:$name</font>");
-	    unlink($filename);
-	}
-    } else {
-	if (-e $filename) {
-	    &logthis("Unable to tie hash (save cache item): $name ($!)");
-	    unlink($filename);
+                if ($@) {
+		    &logthis("<font color='red'>save_cache blew up :$@:$name</font>");
+		    unlink($filename);
+		    last;
+		}
+	    }
+	} else {
+	    if (-e $filename) {
+		&logthis("Unable to tie hash (save cache): $name ($!)");
+		unlink($filename);
+	    }
 	}
+	untie(%hash);
+	flock(DB,LOCK_UN);
+	close(DB);
+	&logthis("save_cache $name took ".(&Time::HiRes::time()-$starttime));
     }
-    untie(%hash);
-    flock(DB,LOCK_UN);
-    close(DB);
-#    &logthis("save_cache_item $name took ".(&Time::HiRes::time()-$starttime));
+    undef(%do_save);
+    undef(%do_save_item);
+
 }
 
 sub load_cache_item {
-    my ($cache,$name,$id)=@_;
+    my ($cache,$name,$id,$time)=@_;
     if ($disk_caching_disabled) { return; }
     my $starttime=&Time::HiRes::time();
 #    &logthis("Before Loading $name  for $id size is ".scalar(%$cache));
     my %hash;
     my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
-    open(DB,"$filename.lock");
+    if (!-e $filename) { return; }
+    open(DB,">$filename.lock");
     flock(DB,LOCK_SH);
     if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) {
 	eval <<'EVALBLOCK';
@@ -935,9 +979,17 @@ sub load_cache_item {
 		}
 #	    &logthis("Initial load: $count");
 	    } else {
-		my $hashref=thaw($hash{$id});
-		$$cache{$id}=$hashref->{'item'};
-		$$cache{$id.'.time'}=$hash{$id.'.time'};
+		if (($$cache{$id.'.time'}+$time) < time) {
+		    $$cache{$id.'.time'}=$hash{$id.'.time'};
+		    {
+			my $hashref=thaw($hash{$id});
+			$$cache{$id}=$hashref->{'item'};
+		    }
+		    if (exists($hash{$id.'.file'})) {
+			my $hashref=thaw($hash{$id.'.file'});
+			$$cache{$id.'.file'}=$hashref->{'item'};
+		    }
+		}
 	    }
 EVALBLOCK
         if ($@) {
@@ -3081,8 +3133,10 @@ sub log_query {
 sub fetch_enrollment_query {
     my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;
     my $homeserver;
+    my $maxtries = 1;
     if ($context eq 'automated') {
         $homeserver = $perlvar{'lonHostID'};
+        $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout
     } else {
         $homeserver = &homeserver($cnum,$dom);
     }
@@ -3097,6 +3151,16 @@ sub fetch_enrollment_query {
     my $queryid=&reply("querysend:".$query.':'.$dom.':'.$ENV{'user.name'}.':'.$cmd,$homeserver);
     unless ($queryid=~/^\Q$host\E\_/) { return 'error: '.$queryid; }
     my $reply = &get_query_reply($queryid);
+    my $tries = 1;
+    while (($reply=~/^timeout/) && ($tries < $maxtries)) {
+	$reply = &get_query_reply($queryid);
+	$tries++;
+    }
+    if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
+	&logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.
+		 $ENV{'user.name'}.' for '.$queryid.' context: '.$context.' '.
+		 $cnum.' maxtries: '.$maxtries.' tries: '.$tries);
+    }
     unless ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
         my @responses = split/:/,$reply;
         if ($homeserver eq $perlvar{'lonHostID'}) {
@@ -4202,7 +4266,9 @@ sub metadata {
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }
 	my $metastring;
 	if ($uri !~ m|^uploaded/|) {
-	    $metastring=&getfile(&filelocation('',&clutter($filename)));
+	    my $file=&filelocation('',&clutter($filename));
+	    push(@{$metacache{$uri.'.file'}},$file);
+	    $metastring=&getfile($file);
 	}
         my $parser=HTML::LCParser->new(\$metastring);
         my $token;
@@ -4567,22 +4633,19 @@ sub deversion {
 
 sub symbread {
     my ($thisfn,$donotrecurse)=@_;
-    if (defined($ENV{'request.symbread.cached'})) {
-	return $ENV{'request.symbread.cached'};
-    }
+    my $cache_str='request.symbread.cached.'.$thisfn;
+    if (defined($ENV{$cache_str})) { return $ENV{$cache_str}; }
 # no filename provided? try from environment
     unless ($thisfn) {
         if ($ENV{'request.symb'}) {
-	    $ENV{'request.symbread.cached'}=&symbclean($ENV{'request.symb'});
-	    return $ENV{'request.symbread.cached'};
+	    return $ENV{$cache_str}=&symbclean($ENV{'request.symb'});
 	}
 	$thisfn=$ENV{'request.filename'};
     }
 # is that filename actually a symb? Verify, clean, and return
     if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {
 	if (&symbverify($thisfn,$1)) {
-	    $ENV{'request.symbread.cached'}=&symbclean($thisfn);
-	    return $ENV{'request.symbread.cached'};
+	    return $ENV{$cache_str}=&symbclean($thisfn);
 	}
     }
     $thisfn=declutter($thisfn);
@@ -4604,8 +4667,7 @@ sub symbread {
            unless ($syval=~/\_\d+$/) {
 	       unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {
                   &appenv('request.ambiguous' => $thisfn);
-		  $ENV{'request.symbread.cached'}='';
-                  return '';
+		  return $ENV{$cache_str}='';
                }    
                $syval.=$1;
 	   }
@@ -4652,13 +4714,11 @@ sub symbread {
            }
         }
         if ($syval) {
-	    $ENV{'request.symbread.cached'}=&symbclean($syval.'___'.$thisfn);
-	    return $ENV{'request.symbread.cached'};
+	    return $ENV{$cache_str}=&symbclean($syval.'___'.$thisfn);
         }
     }
     &appenv('request.ambiguous' => $thisfn);
-    $ENV{'request.symbread.cached'}='';
-    return '';
+    return $ENV{$cache_str}='';
 }
 
 # ---------------------------------------------------------- Return random seed
@@ -4672,6 +4732,7 @@ sub numval {
     $txt=~tr/U-Z/0-5/;
     $txt=~tr/u-z/0-5/;
     $txt=~s/\D//g;
+    if ($_64bit) { if ($txt > 2**32) { return -1; } }
     return int($txt);
 }
 
@@ -4687,6 +4748,7 @@ sub numval2 {
     my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt);
     my $total;
     foreach my $val (@txts) { $total+=$val; }
+    if ($_64bit) { if ($total > 2**32) { return -1; } }
     return int($total);
 }
 
@@ -4703,10 +4765,16 @@ sub get_rand_alg {
     return &latest_rnd_algorithm_id();
 }
 
+sub validCODE {
+    my ($CODE)=@_;
+    if (defined($CODE) && $CODE ne '' && $CODE =~ /^\w+$/) { return 1; }
+    return 0;
+}
+
 sub getCODE {
-    if (defined($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; }
+    if (&validCODE($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; }
     if (defined($Apache::lonhomework::parsing_a_problem) &&
-	defined($Apache::lonhomework::history{'resource.CODE'})) {
+	&validCODE($Apache::lonhomework::history{'resource.CODE'})) {
 	return $Apache::lonhomework::history{'resource.CODE'};
     }
     return undef;
@@ -4748,6 +4816,7 @@ sub rndseed_32bit {
 	my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
 	#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
 	#&Apache::lonxml::debug("rndseed :$num:$symb");
+	if ($_64bit) { $num=(($num<<32)>>32); }
 	return $num;
     }
 }
@@ -4768,6 +4837,7 @@ sub rndseed_64bit {
 	my $num2=$nameseed+$domainseed+$courseseed;
 	#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
 	#&Apache::lonxml::debug("rndseed :$num:$symb");
+	if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
 	return "$num1,$num2";
     }
 }
@@ -4790,6 +4860,7 @@ sub rndseed_64bit2 {
 	my $num2=$nameseed+$domainseed+$courseseed;
 	#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
 	#&Apache::lonxml::debug("rndseed :$num:$symb");
+	if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
 	return "$num1,$num2";
     }
 }
@@ -4811,7 +4882,9 @@ sub rndseed_64bit3 {
 	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");
+	#&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit");
+	if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
+	
 	return "$num1:$num2";
     }
 }
@@ -4829,6 +4902,8 @@ sub rndseed_CODE_64bit {
 	my $num2=$CODEseed+$courseseed+$symbchck;
 	#&Apache::lonxml::debug("$symbseed:$CODEchck|$CODEseed:$courseseed:$symbchck");
 	#&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");
+	if ($_64bit) { $num1=(($num1<<32)>>32); }
+	if ($_64bit) { $num2=(($num2<<32)>>32); }
 	return "$num1:$num2";
     }
 }
@@ -5320,6 +5395,12 @@ $dumpcount=0;
 &logtouch();
 &logthis('<font color=yellow>INFO: Read configuration</font>');
 $readit=1;
+    {
+	use integer;
+	my $test=(2**32)+1;
+	if ($test != 0) { $_64bit=1; }
+	&logthis(" Detected 64bit platform ($_64bit)");
+    }
 }
 }