--- loncom/lonnet/perl/lonnet.pm	2004/10/12 20:37:04	1.545.2.3
+++ loncom/lonnet/perl/lonnet.pm	2004/10/06 09:48:39	1.550
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.545.2.3 2004/10/12 20:37:04 albertel Exp $
+# $Id: lonnet.pm,v 1.550 2004/10/06 09:48:39 foxr Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -36,7 +36,7 @@ use HTTP::Date;
 # use Date::Parse;
 use vars 
 qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom 
-   %libserv %pr %prp $metacache %packagetab %titlecache %courseresversioncache %resversioncache
+   %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache
    %courselogs %accesshash %userrolehash $processmarker $dumpcount 
    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache 
    %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def 
@@ -51,8 +51,8 @@ use Apache::loncoursedata;
 use Apache::lonlocal;
 use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw);
 use Time::HiRes qw( gettimeofday tv_interval );
-use Cache::Memcached;
 my $readit;
+my $max_connection_retries = 10;     # Or some such value.
 
 =pod
 
@@ -117,14 +117,40 @@ sub logperm {
 sub subreply {
     my ($cmd,$server)=@_;
     my $peerfile="$perlvar{'lonSockDir'}/$server";
-    my $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
-                                     Type    => SOCK_STREAM,
-                                     Timeout => 10)
-       or return "con_lost";
-    print $client "$cmd\n";
-    my $answer=<$client>;
-    if (!$answer) { $answer="con_lost"; }
-    chomp($answer);
+    #
+    #  With loncnew process trimming, there's a timing hole between lonc server
+    #  process exit and the master server picking up the listen on the AF_UNIX
+    #  socket.  In that time interval, a lock file will exist:
+
+    my $lockfile=$peerfile.".lock";
+    while (-e $lockfile) {	# Need to wait for the lockfile to disappear.
+	sleep(1);
+    }
+    # At this point, either a loncnew parent is listening or an old lonc
+    # or loncnew child is listening so we can connect or everything's dead.
+    #
+    #   We'll give the connection a few tries before abandoning it.  If
+    #   connection is not possible, we'll con_lost back to the client.
+    #   
+    my $client;
+    for (my $retries = 0; $retries < $max_connection_retries; $retries++) {
+	$client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
+				      Type    => SOCK_STREAM,
+				      Timeout => 10);
+	if($client) {
+	    last;		# Connected!
+	}
+	sleep(1);		# Try again later if failed connection.
+    }
+    my $answer;
+    if ($client) {
+	print $client "$cmd\n";
+	$answer=<$client>;
+	if (!$answer) { $answer="con_lost"; }
+	chomp($answer);
+    } else {
+	$answer = 'con_lost';	# Failed connection.
+    }
     return $answer;
 }
 
@@ -796,11 +822,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;
         }
@@ -822,7 +848,7 @@ sub getsection {
 }
 
 
-my $disk_caching_disabled=1;
+my $disk_caching_disabled=0;
 
 sub devalidate_cache {
     my ($cache,$id,$name) = @_;
@@ -874,7 +900,7 @@ sub is_cached {
 #			&logthis("Upping $mtime - ".$$cache{$id.'.time'}.
 #				 "$id because of $filename");
 		    } else {
-#			&logthis("Devalidating $filename $id - ".(time-($$cache{$id.'.time'})));
+			&logthis("Devalidating $filename $id - ".(time-($$cache{$id.'.time'})));
 			&devalidate_cache($cache,$id,$name);
 			return (undef,undef);
 		    }
@@ -1009,52 +1035,6 @@ EVALBLOCK
 #    &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime));
 }
 
-sub devalidate_cache_new {
-    my ($cache,$name,$id) = @_;
-    if (0) { &Apache::lonnet::logthis("deleting $name:$id"); }
-    $cache->delete(&escape($name.':'.$id));
-}
-
-my $lastone;
-my $lastname;
-sub is_cached_new {
-    my ($cache,$name,$id,$debug) = @_;
-    $debug=0;
-    $id=&escape($name.':'.$id);
-    if ($lastname eq $id) {
-	if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $lastone <= $lastname "); }
-	return ($lastone,1);
-    }
-    undef($lastone);
-    undef($lastname);
-    my $value = $cache->get($id);
-    if (!(defined($value))) {
-	if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }
-	return (undef,undef);
-    }
-    $lastname=$id;
-    if ($value eq '__undef__') {
-	if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); }
-	return (undef,1);
-    }
-    if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }
-    $lastone=$value;
-    return ($value,1);
-}
-
-sub do_cache_new {
-    my ($cache,$name,$id,$value,$time,$debug) = @_;
-    $debug=0;
-    $id=&escape($name.':'.$id);
-    my $setvalue=$value;
-    if (!defined($setvalue)) {
-	$setvalue='__undef__';
-    }
-    if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }
-    $cache->set($id,$setvalue,300);
-    return $value;
-}
-
 sub usection {
     my ($udom,$unam,$courseid)=@_;
     my $hashid="$udom:$unam:$courseid";
@@ -2253,6 +2233,7 @@ sub tmprestore {
 }
 
 # ----------------------------------------------------------------------- Store
+
 sub store {
     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
     my $home='';
@@ -2266,6 +2247,7 @@ sub store {
     if (!$stuname) { $stuname=$ENV{'user.name'}; }
 
     &devalidate($symb,$stuname,$domain);
+
     $symb=escape($symb);
     if (!$namespace) { 
        unless ($namespace=$ENV{'request.course.id'}) { 
@@ -2301,6 +2283,7 @@ sub cstore {
     if (!$stuname) { $stuname=$ENV{'user.name'}; }
 
     &devalidate($symb,$stuname,$domain);
+
     $symb=escape($symb);
     if (!$namespace) { 
        unless ($namespace=$ENV{'request.course.id'}) { 
@@ -2343,7 +2326,6 @@ sub restore {
     if (!$domain) { $domain=$ENV{'user.domain'}; }
     if (!$stuname) { $stuname=$ENV{'user.name'}; }
     if (!$home) { $home=$ENV{'user.home'}; }
-
     my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");
 
     my %returnhash=();
@@ -2830,12 +2812,14 @@ sub allowed {
     }
 
 # Free bre access to user's own portfolio contents
-    $uri=~m:([^/]+)/([^/]+)/([^/]+)/([^/]+)/:;
-    if (('uploaded' eq $1)&&($ENV{'user.name'} eq $3) && ($ENV{'user.domain'} eq $2) && ('portfolio' eq $4)) {
+    my ($space,$domain,$name,$dir)=split('/',$uri);
+    if (('uploaded' eq $space) && ($ENV{'user.name'} eq $name) && 
+	($ENV{'user.domain'} eq $domain) && ('portfolio' eq $dir)) {
         return 'F';
     }
 
 # Free bre to public access
+
     if ($priv eq 'bre') {
         my $copyright=&metadata($uri,'copyright');
 	if (($copyright eq 'public') && (!$ENV{'request.course.id'})) { 
@@ -3235,8 +3219,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);
     }
@@ -3254,8 +3240,13 @@ sub fetch_enrollment_query {
         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);
+        &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$ENV{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
     } else {
         my @responses = split/:/,$reply;
         if ($homeserver eq $perlvar{'lonHostID'}) {
@@ -4301,7 +4292,6 @@ sub add_prefix_and_part {
 
 # ---------------------------------------------------------------- Get metadata
 
-my %metaentry;
 sub metadata {
     my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
     $uri=&declutter($uri);
@@ -4321,29 +4311,28 @@ sub metadata {
 # Everything is cached by the main uri, libraries are never directly cached
 #
     if (!defined($liburi)) {
-	my ($result,$cached)=&is_cached_new($metacache,'meta',$uri);
+	my ($result,$cached)=&is_cached(\%metacache,$uri,'meta');
 	if (defined($cached)) { return $result->{':'.$what}; }
     }
     {
 #
 # Is this a recursive call for a library?
 #
-#	if (! exists($metacache{$uri})) {
-#	    $metacache{$uri}={};
-#	}
+	if (! exists($metacache{$uri})) {
+	    $metacache{$uri}={};
+	}
         if ($liburi) {
 	    $liburi=&declutter($liburi);
             $filename=$liburi;
         } else {
-	    &devalidate_cache_new($metacache,'meta',$uri);
-	    undef(%metaentry);
+	    &devalidate_cache(\%metacache,$uri,'meta');
 	}
         my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }
 	my $metastring;
 	if ($uri !~ m|^uploaded/|) {
 	    my $file=&filelocation('',&clutter($filename));
-	    #push(@{$metaentry{$uri.'.file'}},$file);
+	    push(@{$metacache{$uri.'.file'}},$file);
 	    $metastring=&getfile($file);
 	}
         my $parser=HTML::LCParser->new(\$metastring);
@@ -4360,10 +4349,10 @@ sub metadata {
 		    if (defined($token->[2]->{'id'})) { 
 			$keyroot.='_'.$token->[2]->{'id'}; 
 		    }
-		    if ($metaentry{':packages'}) {
-			$metaentry{':packages'}.=','.$package.$keyroot;
+		    if ($metacache{$uri}->{':packages'}) {
+			$metacache{$uri}->{':packages'}.=','.$package.$keyroot;
 		    } else {
-			$metaentry{':packages'}=$package.$keyroot;
+			$metacache{$uri}->{':packages'}=$package.$keyroot;
 		    }
 		    foreach (keys %packagetab) {
 			my $part=$keyroot;
@@ -4385,14 +4374,14 @@ sub metadata {
 			    if ($subp eq 'display') {
 				$value.=' [Part: '.$part.']';
 			    }
-			    $metaentry{':'.$unikey.'.part'}=$part;
+			    $metacache{$uri}->{':'.$unikey.'.part'}=$part;
 			    $metathesekeys{$unikey}=1;
-			    unless (defined($metaentry{':'.$unikey.'.'.$subp})) {
-				$metaentry{':'.$unikey.'.'.$subp}=$value;
+			    unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) {
+				$metacache{$uri}->{':'.$unikey.'.'.$subp}=$value;
 			    }
-			    if (defined($metaentry{':'.$unikey.'.default'})) {
-				$metaentry{':'.$unikey}=
-				    $metaentry{':'.$unikey.'.default'};
+			    if (defined($metacache{$uri}->{':'.$unikey.'.default'})) {
+				$metacache{$uri}->{':'.$unikey}=
+				    $metacache{$uri}->{':'.$unikey.'.default'};
 			    }
 			}
 		    }
@@ -4425,7 +4414,7 @@ sub metadata {
 			    foreach (sort(split(/\,/,&metadata($uri,'keys',
 							       $location,$unikey,
 							       $depthcount+1)))) {
-				$metaentry{':'.$_}=$metaentry{':'.$_};
+				$metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_};
 				$metathesekeys{$_}=1;
 			    }
 			}
@@ -4436,18 +4425,18 @@ sub metadata {
 			}
 			$metathesekeys{$unikey}=1;
 			foreach (@{$token->[3]}) {
-			    $metaentry{':'.$unikey.'.'.$_}=$token->[2]->{$_};
+			    $metacache{$uri}->{':'.$unikey.'.'.$_}=$token->[2]->{$_};
 			}
 			my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
-			my $default=$metaentry{':'.$unikey.'.default'};
+			my $default=$metacache{$uri}->{':'.$unikey.'.default'};
 			if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) {
 		 # only ws inside the tag, and not in default, so use default
 		 # as value
-			    $metaentry{':'.$unikey}=$default;
+			    $metacache{$uri}->{':'.$unikey}=$default;
 			} else {
 		  # either something interesting inside the tag or default
                   # uninteresting
-			    $metaentry{':'.$unikey}=$internaltext;
+			    $metacache{$uri}->{':'.$unikey}=$internaltext;
 			}
 # end of not-a-package not-a-library import
 		    }
@@ -4464,7 +4453,7 @@ sub metadata {
 	    &metadata_create_package_def($uri,$key,'extension_'.$extension,
 					 \%metathesekeys);
 	}
-	if (!exists($metaentry{':packages'})) {
+	if (!exists($metacache{$uri}->{':packages'})) {
 	    foreach my $key (sort(keys(%packagetab))) {
 		#no specific packages well let's get default then
 		if ($key!~/^default&/) { next; }
@@ -4473,31 +4462,31 @@ sub metadata {
 	    }
 	}
 # are there custom rights to evaluate
-	if ($metaentry{':copyright'} eq 'custom') {
+	if ($metacache{$uri}->{':copyright'} eq 'custom') {
 
     #
     # Importing a rights file here
     #
 	    unless ($depthcount) {
-		my $location=$metaentry{':customdistributionfile'};
+		my $location=$metacache{$uri}->{':customdistributionfile'};
 		my $dir=$filename;
 		$dir=~s|[^/]*$||;
 		$location=&filelocation($dir,$location);
 		foreach (sort(split(/\,/,&metadata($uri,'keys',
 						   $location,'_rights',
 						   $depthcount+1)))) {
-		    #$metaentry{':'.$_}=$metacache{$uri}->{':'.$_};
+		    $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_};
 		    $metathesekeys{$_}=1;
 		}
 	    }
 	}
-	$metaentry{':keys'}=join(',',keys %metathesekeys);
-	&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
-	$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
-	&do_cache_new($metacache,'meta',$uri,\%metaentry);
+	$metacache{$uri}->{':keys'}=join(',',keys %metathesekeys);
+	&metadata_generate_part0(\%metathesekeys,$metacache{$uri},$uri);
+	$metacache{$uri}->{':allpossiblekeys'}=join(',',keys %metathesekeys);
+	&do_cache(\%metacache,$uri,$metacache{$uri},'meta');
 # this is the end of "was not already recently cached
     }
-    return $metaentry{':'.$what};
+    return $metacache{$uri}->{':'.$what};
 }
 
 sub metadata_create_package_def {
@@ -4505,22 +4494,22 @@ sub metadata_create_package_def {
     my ($pack,$name,$subp)=split(/\&/,$key);
     if ($subp eq 'default') { next; }
     
-    if (defined($metaentry{':packages'})) {
-	$metaentry{':packages'}.=','.$package;
+    if (defined($metacache{$uri}->{':packages'})) {
+	$metacache{$uri}->{':packages'}.=','.$package;
     } else {
-	$metaentry{':packages'}=$package;
+	$metacache{$uri}->{':packages'}=$package;
     }
     my $value=$packagetab{$key};
     my $unikey;
     $unikey='parameter_0_'.$name;
-    $metaentry{':'.$unikey.'.part'}=0;
+    $metacache{$uri}->{':'.$unikey.'.part'}=0;
     $$metathesekeys{$unikey}=1;
-    unless (defined($metaentry{':'.$unikey.'.'.$subp})) {
-	$metaentry{':'.$unikey.'.'.$subp}=$value;
+    unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) {
+	$metacache{$uri}->{':'.$unikey.'.'.$subp}=$value;
     }
-    if (defined($metaentry{':'.$unikey.'.default'})) {
-	$metaentry{':'.$unikey}=
-	    $metaentry{':'.$unikey.'.default'};
+    if (defined($metacache{$uri}->{':'.$unikey.'.default'})) {
+	$metacache{$uri}->{':'.$unikey}=
+	    $metacache{$uri}->{':'.$unikey.'.default'};
     }
 }
 
@@ -5303,7 +5292,7 @@ sub goodbye {
 #not converted to using infrastruture and probably shouldn't be
    &logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache)));
 #converted
-#   &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
+   &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)));
@@ -5456,7 +5445,7 @@ BEGIN {
 
 }
 
-$metacache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']});
+%metacache=();
 
 $processmarker='_'.time.'_'.$perlvar{'lonHostID'};
 $dumpcount=0;