--- loncom/lonnet/perl/lonnet.pm	2003/09/15 18:43:54	1.412
+++ loncom/lonnet/perl/lonnet.pm	2003/10/06 20:38:25	1.427
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.412 2003/09/15 18:43:54 www Exp $
+# $Id: lonnet.pm,v 1.427 2003/10/06 20:38:25 www Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -76,7 +76,7 @@ qw(%perlvar %hostname %homecache %badSer
    %libserv %pr %prp %metacache %packagetab %titlecache 
    %courselogs %accesshash %userrolehash $processmarker $dumpcount 
    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache 
-   %domaindescription %domain_auth_def %domain_auth_arg_def 
+   %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def 
    %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir);
 
 use IO::Socket;
@@ -85,7 +85,9 @@ use Apache::Constants qw(:common :http);
 use HTML::LCParser;
 use Fcntl qw(:flock);
 use Apache::loncoursedata;
-
+use Apache::lonlocal;
+use Storable qw(lock_store lock_nstore lock_retrieve);
+use Time::HiRes();
 my $readit;
 
 # --------------------------------------------------------------------- Logging
@@ -584,9 +586,9 @@ sub authenticate {
 sub homeserver {
     my ($uname,$udom,$ignoreBadCache)=@_;
     my $index="$uname:$udom";
-    if ($homecache{$index}) { 
-        return "$homecache{$index}"; 
-    }
+
+    my ($result,$cached)=&is_cached(\%homecache,$index,'home',86400);
+    if (defined($cached)) { return $result; }
     my $tryserver;
     foreach $tryserver (keys %libserv) {
         next if ($ignoreBadCache ne 'true' && 
@@ -594,8 +596,7 @@ sub homeserver {
 	if ($hostdom{$tryserver} eq $udom) {
            my $answer=reply("home:$udom:$uname",$tryserver);
            if ($answer eq 'found') { 
-              $homecache{$index}=$tryserver;
-              return $tryserver; 
+	       return &do_cache(\%homecache,$index,$tryserver,'home');
            } elsif ($answer eq 'no_host') {
 	       $badServerCache{$tryserver}=1;
            }
@@ -847,8 +848,96 @@ sub getsection {
     return '-1';
 }
 
+sub devalidate_cache {
+    my ($cache,$id) = @_;
+    delete $$cache{$id.'.time'};
+    delete $$cache{$id};
+}
+
+sub is_cached {
+    my ($cache,$id,$name,$time) = @_;
+    if (!$time) { $time=300; }
+    if (!exists($$cache{$id.'.time'})) {
+	&load_cache($cache,$name);
+    }
+    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);
+	    return (undef,undef);
+	}
+    }
+    return ($$cache{$id},1);
+}
+
+sub do_cache {
+    my ($cache,$id,$value,$name) = @_;
+    $$cache{$id.'.time'}=time;
+    $$cache{$id}=$value;
+    &save_cache($cache,$name);
+    # do_cache implictly return the set value
+    $$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 usection {
     my ($udom,$unam,$courseid)=@_;
+    my $hashid="$udom:$unam:$courseid";
+    
+    my ($result,$cached)=&is_cached(\%usectioncache,$hashid,'usection');
+    if (defined($cached)) { return $result; }
     $courseid=~s/\_/\//g;
     $courseid=~s/^(\w)/\/$1/;
     foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
@@ -867,10 +956,12 @@ sub usection {
             if ($end) {
                 if ($now>$end) { $notactive=1; }
             } 
-            unless ($notactive) { return $section; }
+            unless ($notactive) {
+		return &do_cache(\%usectioncache,$hashid,$section,'usection');
+	    }
         }
     }
-    return '-1';
+    return &do_cache(\%usectioncache,$hashid,'-1','usection');
 }
 
 # ------------------------------------- Read an entry from a user's environment
@@ -2186,27 +2277,7 @@ sub currentdump {
        return if ($tmp[0] =~ /^(error:|no_such_host)/);
        my %hash = @tmp;
        @tmp=();
-       # Code ripped from lond, essentially.  The only difference
-       # here is the unescaping done by lonnet::dump().  Conceivably
-       # we might run in to problems with parameter names =~ /^v\./
-       while (my ($key,$value) = each(%hash)) {
-           my ($v,$symb,$param) = split(/:/,$key);
-           next if ($v eq 'version' || $symb eq 'keys');
-           next if (exists($returnhash{$symb}) &&
-                    exists($returnhash{$symb}->{$param}) &&
-                    $returnhash{$symb}->{'v.'.$param} > $v);
-           $returnhash{$symb}->{$param}=$value;
-           $returnhash{$symb}->{'v.'.$param}=$v;
-       }
-       #
-       # Remove all of the keys in the hashes which keep track of
-       # the version of the parameter.
-       while (my ($symb,$param_hash) = each(%returnhash)) {
-           # use a foreach because we are going to delete from the hash.
-           foreach my $key (keys(%$param_hash)) {
-               delete($param_hash->{$key}) if ($key =~ /^v\./);
-           }
-       }
+       %returnhash = %{&convert_dump_to_currentdump(\%hash)};
    } else {
        my @pairs=split(/\&/,$rep);
        foreach (@pairs) {
@@ -2219,6 +2290,33 @@ sub currentdump {
    return %returnhash;
 }
 
+sub convert_dump_to_currentdump{
+    my %hash = %{shift()};
+    my %returnhash;
+    # Code ripped from lond, essentially.  The only difference
+    # here is the unescaping done by lonnet::dump().  Conceivably
+    # we might run in to problems with parameter names =~ /^v\./
+    while (my ($key,$value) = each(%hash)) {
+        my ($v,$symb,$param) = split(/:/,$key);
+        next if ($v eq 'version' || $symb eq 'keys');
+        next if (exists($returnhash{$symb}) &&
+                 exists($returnhash{$symb}->{$param}) &&
+                 $returnhash{$symb}->{'v.'.$param} > $v);
+        $returnhash{$symb}->{$param}=$value;
+        $returnhash{$symb}->{'v.'.$param}=$v;
+    }
+    #
+    # Remove all of the keys in the hashes which keep track of
+    # the version of the parameter.
+    while (my ($symb,$param_hash) = each(%returnhash)) {
+        # use a foreach because we are going to delete from the hash.
+        foreach my $key (keys(%$param_hash)) {
+            delete($param_hash->{$key}) if ($key =~ /^v\./);
+        }
+    }
+    return \%returnhash;
+}
+
 # --------------------------------------------------------------- put interface
 
 sub put {
@@ -2606,8 +2704,36 @@ sub is_on_map {
     if ($match) {
 	return (1,$1);
     } else {
-	return (0,0);
+	my ($name,$ext)=($filename=~/^(.+)\.(\w+)$/);
+        $ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
+	       /\&(\Q$name\E\.\d+\.$ext)\:([\d\|]+)\&/;
+	return (0,$2,$pathname.'/'.$1);
+    }
+}
+
+# --------------------------------------------------------- Get symb from alias
+
+sub get_symb_from_alias {
+    my $symb=shift;
+    my ($map,$resid,$url)=&decode_symb($symb);
+# Already is a symb
+    if ($url) { return $symb; }
+# Must be an alias
+    my $aliassymb='';
+    my %bighash;
+    if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
+                            &GDBM_READER(),0640)) {
+        my $rid=$bighash{'mapalias_'.$symb};
+	if ($rid) {
+	    my ($mapid,$resid)=split(/\./,$rid);
+	    $aliassymb=
+		&declutter($bighash{'map_id_'.$mapid}).
+		'___'.$resid.'___'.
+		&declutter($bighash{'src_'.$rid});
+	}
+        untie %bighash;
     }
+    return $aliassymb;
 }
 
 # ----------------------------------------------------------------- Define Role
@@ -2736,7 +2862,7 @@ sub userlog_query {
 
 sub plaintext {
     my $short=shift;
-    return $prp{$short};
+    return &mt($prp{$short});
 }
 
 # ----------------------------------------------------------------- Assign Role
@@ -3264,7 +3390,7 @@ sub condval {
 sub devalidatecourseresdata {
     my ($coursenum,$coursedomain)=@_;
     my $hashid=$coursenum.':'.$coursedomain;
-    delete $courseresdatacache{$hashid.'.time'};
+    &devalidate_cache(\%courseresdatacache,$hashid);
 }
 
 # --------------------------------------------------- Course Resourcedata Query
@@ -3273,25 +3399,23 @@ sub courseresdata {
     my ($coursenum,$coursedomain,@which)=@_;
     my $coursehom=&homeserver($coursenum,$coursedomain);
     my $hashid=$coursenum.':'.$coursedomain;
-    my $dodump=0;
-    if (!defined($courseresdatacache{$hashid.'.time'})) {
-	$dodump=1;
-    } else {
-	if (time-$courseresdatacache{$hashid.'.time'}>300) { $dodump=1; }
-    }
-    if ($dodump) {
+    my ($result,$cached)=&is_cached(\%courseresdatacache,$hashid,'courseres');
+    unless (defined($cached)) {
 	my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum);
+	$result=\%dumpreply;
 	my ($tmp) = keys(%dumpreply);
 	if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
-	    $courseresdatacache{$hashid.'.time'}=time;
-	    $courseresdatacache{$hashid}=\%dumpreply;
+	    &do_cache(\%courseresdatacache,$hashid,$result,'courseres');
 	} elsif ($tmp =~ /^(con_lost|no_such_host)/) {
 	    return $tmp;
+	} elsif ($tmp =~ /^(error)/) {
+	    $result=undef;
+	    &do_cache(\%courseresdatacache,$hashid,$result,'courseres');
 	}
     }
     foreach my $item (@which) {
-	if (defined($courseresdatacache{$hashid}->{$item})) {
-	    return $courseresdatacache{$hashid}->{$item};
+	if (defined($result->{$item})) {
+	    return $result->{$item};
 	}
     }
     return undef;
@@ -3330,6 +3454,9 @@ sub EXT {
     #get real user name/domain, courseid and symb
     my $courseid;
     my $publicuser;
+    if ($symbparm) {
+	$symbparm=&get_symb_from_alias($symbparm);
+    }
     if (!($uname && $udom)) {
       (my $cursymb,$courseid,$udom,$uname,$publicuser)=
 	  &Apache::lonxml::whichuser($symbparm);
@@ -3459,19 +3586,25 @@ sub EXT {
 
 # ----------------------------------------------------------- first, check user
 	    #most student don\'t have any data set, check if there is some data
-            #every thirty minutes
 	    if (! &EXT_cache_status($udom,$uname)) {
-		my %resourcedata=&get('resourcedata',
-				      [$courselevelr,$courselevelm,$courselevel],
-				      $udom,$uname);
-		my ($tmp)=keys(%resourcedata);
+		my $hashid="$udom:$uname";
+		my ($result,$cached)=&is_cached(\%userresdatacache,$hashid,
+						'userres');
+		if (!defined($cached)) { 
+		    my %resourcedata=&get('resourcedata',
+					  [$courselevelr,$courselevelm,
+					   $courselevel],$udom,$uname);
+		    $result=\%resourcedata;
+		    &do_cache(\%userresdatacache,$hashid,$result,'userres');
+		}
+		my ($tmp)=keys(%$result);
 		if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {
-		    if ($resourcedata{$courselevelr}) {
-			return $resourcedata{$courselevelr}; }
-		    if ($resourcedata{$courselevelm}) {
-			return $resourcedata{$courselevelm}; }
-		    if ($resourcedata{$courselevel}) {
-			return $resourcedata{$courselevel}; }
+		    if ($$result{$courselevelr}) {
+			return $$result{$courselevelr}; }
+		    if ($$result{$courselevelm}) {
+			return $$result{$courselevelm}; }
+		    if ($$result{$courselevel}) {
+			return $$result{$courselevel}; }
 		} else {
 		    if ($tmp!~/No such file/) {
 			&logthis("<font color=blue>WARNING:".
@@ -3587,11 +3720,11 @@ sub add_prefix_and_part {
 
 sub metadata {
     my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
-
     $uri=&declutter($uri);
     # if it is a non metadata possible uri return quickly
     if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) ||
-        ($uri =~ m|/$|) || ($uri =~ m|/.meta$|)) {
+        ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
+	($uri =~ m|home/[^/]+/public_html/|)) {
 	return '';
     }
     my $filename=$uri;
@@ -3780,13 +3913,8 @@ sub gettitle {
 	unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; }
         return &metadata($urlsymb,'title'); 
     }
-    if ($titlecache{$symb}) {
-	if (time < ($titlecache{$symb}[1] + 600)) {
-	    return $titlecache{$symb}[0];
-	} else {
-	    delete($titlecache{$symb});
-	}
-    }
+    my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);
+    if (defined($cached)) { return $result; }
     my ($map,$resid,$url)=&decode_symb($symb);
     my $title='';
     my %bighash;
@@ -3798,8 +3926,7 @@ sub gettitle {
     }
     $title=~s/\&colon\;/\:/gs;
     if ($title) {
-        $titlecache{$symb}=[$title,time];
-        return $title;
+        return &do_cache(\%titlecache,$symb,$title,'title');
     } else {
 	return &metadata($urlsymb,'title');
     }
@@ -3879,7 +4006,18 @@ sub symbclean {
 # ---------------------------------------------- Split symb to find map and url
 
 sub decode_symb {
-    return split(/\_\_\_/,shift);
+    my ($map,$resid,$url)=split(/\_\_\_/,shift);
+    return (&fixversion($map),$resid,&fixversion($url));
+}
+
+sub fixversion {
+    my $fn=shift;
+    if ($fn=~/^(adm|uploaded|public)/) { return $fn; }
+    my ($match,$cond,$versioned)=&is_on_map($fn);
+    unless ($match) {
+	$fn=$versioned;
+    }
+    return $fn;
 }
 
 # ------------------------------------------------------ Return symb list entry
@@ -4181,10 +4319,26 @@ sub unescape {
     return $str;
 }
 
+sub mod_perl_version {
+    if (defined($perlvar{'MODPERL2'})) {
+	return 2;
+    }
+    return 1;
+}
 # ================================================================ Main Program
 
 sub goodbye {
    &logthis("Starting Shut down");
+#not converted to using infrastruture
+   &logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache)));
+   &logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache)));
+   &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
+#converted
+   &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)));
    &flushcourselogs();
    &logthis("Shutting down");
    return DONE;