--- loncom/lonnet/perl/lonnet.pm	2004/07/22 22:12:06	1.523
+++ loncom/lonnet/perl/lonnet.pm	2004/11/06 20:53:40	1.523.2.10
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.523 2004/07/22 22:12:06 raeburn Exp $
+# $Id: lonnet.pm,v 1.523.2.10 2004/11/06 20:53:40 albertel Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -50,8 +50,9 @@ use Fcntl qw(:flock);
 use Apache::loncoursedata;
 use Apache::lonlocal;
 use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw);
-use Time::HiRes();
+use Time::HiRes qw( gettimeofday tv_interval );
 my $readit;
+my $_64bit=0;
 
 =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 ($@) {
@@ -1047,6 +1099,7 @@ sub currentversion {
 sub subscribe {
     my $fname=shift;
     if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return ''; }
+    $fname=~s/[\n\r]//g;
     my $author=$fname;
     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
     my ($udom,$uname)=split(/\//,$author);
@@ -1067,6 +1120,7 @@ sub repcopy {
     my $filename=shift;
     $filename=~s/\/+/\//g;
     if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; }
+    $filename=~s/[\n\r]//g;
     my $transname="$filename.in.transfer";
     if ((-e $filename) || (-e $transname)) { return OK; }
     my $remoteurl=subscribe($filename);
@@ -3079,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);
     }
@@ -3095,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'}) {
@@ -3994,11 +4060,14 @@ sub EXT {
 
 	my $section;
 	if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) {
+	    if (!$symbparm) { $symbparm=&symbread(); }
+	}
+	if ($symbparm && defined($courseid) && 
+	    $courseid eq $ENV{'request.course.id'}) {
 
 	    #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
 
 # ----------------------------------------------------- Cascading lookup scheme
-	    if (!$symbparm) { $symbparm=&symbread(); }
 	    my $symbp=$symbparm;
 	    my $mapp=(&decode_symb($symbp))[0];
 
@@ -4009,11 +4078,11 @@ sub EXT {
 		($ENV{'user.domain'} eq $udom)) {
 		$section=$ENV{'request.course.sec'};
 	    } else {
-                if (! defined($usection)) {
-                    $section=&usection($udom,$uname,$courseid);
-                } else {
-                    $section = $usection;
-                }
+		if (! defined($usection)) {
+		    $section=&usection($udom,$uname,$courseid);
+		} else {
+		    $section = $usection;
+		}
 	    }
 
 	    my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
@@ -4051,7 +4120,7 @@ sub EXT {
 				 $uname." at ".$udom.": ".
 				 $tmp."</font>");
 		    } elsif ($tmp=~/error: 2 /) {
-                        &EXT_cache_set($udom,$uname);
+			&EXT_cache_set($udom,$uname);
 		    } elsif ($tmp =~ /^(con_lost|no_such_host)/) {
 			return $tmp;
 		    }
@@ -4061,10 +4130,10 @@ sub EXT {
 # -------------------------------------------------------- second, check course
 
 	    my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'},
-					  $ENV{'course.'.$courseid.'.domain'},
-					  ($seclevelr,$seclevelm,$seclevel,
-					   $courselevelr,$courselevelm,
-					   $courselevel));
+					   $ENV{'course.'.$courseid.'.domain'},
+					   ($seclevelr,$seclevelm,$seclevel,
+					    $courselevelr,$courselevelm,
+					    $courselevel));
 	    if (defined($coursereply)) { return $coursereply; }
 
 # ------------------------------------------------------ third, check map parms
@@ -4197,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;
@@ -4562,14 +4633,20 @@ sub deversion {
 
 sub symbread {
     my ($thisfn,$donotrecurse)=@_;
+    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'}) { return &symbclean($ENV{'request.symb'}); }
+        if ($ENV{'request.symb'}) {
+	    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)) { return &symbclean($thisfn); }
+	if (&symbverify($thisfn,$1)) {
+	    return $ENV{$cache_str}=&symbclean($thisfn);
+	}
     }
     $thisfn=declutter($thisfn);
     my %hash;
@@ -4590,7 +4667,7 @@ sub symbread {
            unless ($syval=~/\_\d+$/) {
 	       unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {
                   &appenv('request.ambiguous' => $thisfn);
-                  return '';
+		  return $ENV{$cache_str}='';
                }    
                $syval.=$1;
 	   }
@@ -4637,11 +4714,11 @@ sub symbread {
            }
         }
         if ($syval) {
-           return &symbclean($syval.'___'.$thisfn); 
+	    return $ENV{$cache_str}=&symbclean($syval.'___'.$thisfn);
         }
     }
     &appenv('request.ambiguous' => $thisfn);
-    return '';
+    return $ENV{$cache_str}='';
 }
 
 # ---------------------------------------------------------- Return random seed
@@ -4655,6 +4732,7 @@ sub numval {
     $txt=~tr/U-Z/0-5/;
     $txt=~tr/u-z/0-5/;
     $txt=~s/\D//g;
+    if ($_64bit) { if ($total > 2**32) { return -1; } }
     return int($txt);
 }
 
@@ -4670,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);
 }
 
@@ -4686,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;
@@ -4731,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;
     }
 }
@@ -4751,6 +4837,8 @@ 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); }
+	if ($_64bit) { $num2=(($num2<<32)>>32); }
 	return "$num1,$num2";
     }
 }
@@ -4773,6 +4861,8 @@ 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); }
+	if ($_64bit) { $num2=(($num2<<32)>>32); }
 	return "$num1,$num2";
     }
 }
@@ -4795,6 +4885,8 @@ sub rndseed_64bit3 {
 	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); }
+	if ($_64bit) { $num2=(($num2<<32)>>32); }
 	return "$num1:$num2";
     }
 }
@@ -4812,6 +4904,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";
     }
 }
@@ -5153,6 +5247,11 @@ sub goodbye {
 }
 
 BEGIN {
+    {
+	use integer;
+	my $test=(2**32)+1;
+	if ($test != 0) { $_64bit=1; }
+    }
 # ----------------------------------- Read loncapa.conf and loncapa_apache.conf
     unless ($readit) {
 {