--- loncom/lonnet/perl/lonnet.pm	2003/08/06 16:43:36	1.397
+++ loncom/lonnet/perl/lonnet.pm	2003/09/19 16:53:35	1.417
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.397 2003/08/06 16:43:36 albertel Exp $
+# $Id: lonnet.pm,v 1.417 2003/09/19 16:53:35 albertel Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -76,13 +76,16 @@ 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 $tmpdir);
+   %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def 
+   %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir);
+
 use IO::Socket;
 use GDBM_File;
 use Apache::Constants qw(:common :http);
 use HTML::LCParser;
 use Fcntl qw(:flock);
 use Apache::loncoursedata;
+use Apache::lonlocal;
 
 my $readit;
 
@@ -243,6 +246,20 @@ sub critical {
     }
     return $answer;
 }
+
+#
+# -------------- Remove all key from the env that start witha lowercase letter
+#                (Which is always a lon-capa value)
+
+sub cleanenv {
+#    unless (defined(&Apache::exists_config_define("MODPERL2"))) { return; }
+#    unless (&Apache::exists_config_define("MODPERL2")) { return; }
+    foreach my $key (keys(%ENV)) {
+	if ($key =~ /^[a-z]/) {
+	    delete($ENV{$key});
+	}
+    }
+}
  
 # ------------------------------------------- Transfer profile into environment
 
@@ -377,8 +394,8 @@ sub userload {
 	my $curtime=time;
 	while ($filename=readdir(LONIDS)) {
 	    if ($filename eq '.' || $filename eq '..') {next;}
-	    my ($atime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[8];
-	    if ($curtime-$atime < 3600) { $numusers++; }
+	    my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
+	    if ($curtime-$mtime < 3600) { $numusers++; }
 	}
 	closedir(LONIDS);
     }
@@ -424,15 +441,27 @@ sub spareserver {
     my $lowestserver=$loadpercent > $userloadpercent?
 	             $loadpercent :  $userloadpercent;
     foreach $tryserver (keys %spareid) {
-       my $loadans=reply('load',$tryserver);
-       my $userloadans=reply('userload',$tryserver);
-       if ($userloadans !~ /\d/) { $userloadans=0; }
-       my $answer=$loadans > $userloadans?
-                  $loadans :  $userloadans;
-       if (($answer =~ /\d/) && ($answer<$lowestserver)) {
-	   $spareserver="http://$hostname{$tryserver}";
-           $lowestserver=$answer;
-       }
+	my $loadans=reply('load',$tryserver);
+	my $userloadans=reply('userload',$tryserver);
+	if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
+	    next; #didn't get a number from the server
+	}
+	my $answer;
+	if ($loadans =~ /\d/) {
+	    if ($userloadans =~ /\d/) {
+		#both are numbers, pick the bigger one
+		$answer=$loadans > $userloadans?
+		    $loadans :  $userloadans;
+	    } else {
+		$answer = $loadans;
+	    }
+	} else {
+	    $answer = $userloadans;
+	}
+	if (($answer =~ /\d/) && ($answer<$lowestserver)) {
+	    $spareserver="http://$hostname{$tryserver}";
+	    $lowestserver=$answer;
+	}
     }
     return $spareserver;
 }
@@ -819,8 +848,38 @@ sub getsection {
     return '-1';
 }
 
+sub devalidate_cache {
+    my ($cache,$id) = @_;
+    delete $$cache{$id.'.time'};
+    delete $$cache{$id};
+}
+
+sub is_cached {
+    my ($cache,$id,$time) = @_;
+    if (!exists($$cache{$id.'.time'})) {
+	return (undef,undef);
+    } else {
+	if (time-$$cache{$id.'.time'}>$time) {
+	    &devalidate_cache($cache,$id);
+	    return (undef,undef);
+	}
+    }
+    return ($$cache{$id},1);
+}
+
+sub do_cache {
+    my ($cache,$id,$value) = @_;
+    $$cache{$id.'.time'}=time;
+    # do_cache implictly return the set value
+    $$cache{$id}=$value;
+}
+
 sub usection {
     my ($udom,$unam,$courseid)=@_;
+    my $hashid="$udom:$unam:$courseid";
+    
+    my ($result,$cached)=&is_cached(\%usectioncache,$hashid,300);
+    if (defined($cached)) { return $result; }
     $courseid=~s/\_/\//g;
     $courseid=~s/^(\w)/\/$1/;
     foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
@@ -839,10 +898,12 @@ sub usection {
             if ($end) {
                 if ($now>$end) { $notactive=1; }
             } 
-            unless ($notactive) { return $section; }
+            unless ($notactive) {
+		return &do_cache(\%usectioncache,$hashid,$section);
+	    }
         }
     }
-    return '-1';
+    return &do_cache(\%usectioncache,$hashid,'-1');
 }
 
 # ------------------------------------- Read an entry from a user's environment
@@ -1216,7 +1277,7 @@ sub courseacclog {
     my $fnsymb=shift;
     unless ($ENV{'request.course.id'}) { return ''; }
     my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'};
-    if ($fnsymb=~/(problem|exam|quiz|assess|survey|form)$/) {
+    if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|page)$/) {
         $what.=':POST';
 	foreach (keys %ENV) {
             if ($_=~/^form\.(.*)/) {
@@ -1284,6 +1345,53 @@ sub get_course_adv_roles {
     return %returnhash;
 }
 
+sub get_my_roles {
+    my ($uname,$udom)=@_;
+    unless (defined($uname)) { $uname=$ENV{'user.name'}; }
+    unless (defined($udom)) { $udom=$ENV{'user.domain'}; }
+    my %dumphash=
+            &dump('nohist_userroles',$udom,$uname);
+    my %returnhash=();
+    my $now=time;
+    foreach (keys %dumphash) {
+	my ($tend,$tstart)=split(/\:/,$dumphash{$_});
+        if (($tstart) && ($tstart<0)) { next; }
+        if (($tend) && ($tend<$now)) { next; }
+        if (($tstart) && ($now<$tstart)) { next; }
+        my ($role,$username,$domain,$section)=split(/\:/,$_);
+	$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
+     }
+    return %returnhash;
+}
+
+# ----------------------------------------------------- Frontpage Announcements
+#
+#
+
+sub postannounce {
+    my ($server,$text)=@_;
+    unless (&allowed('psa',$hostdom{$server})) { return 'refused'; }
+    unless ($text=~/\w/) { $text=''; }
+    return &reply('setannounce:'.&escape($text),$server);
+}
+
+sub getannounce {
+    if (my $fh=Apache::File->new($perlvar{'lonDocRoot'}.'/announcement.txt')) {
+	my $announcement='';
+	while (<$fh>) { $announcement .=$_; }
+	$fh->close();
+	if ($announcement=~/\w/) { 
+	    return 
+   '<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'.
+   '<tr><td bgcolor="#FFFFFF"><pre>'.$announcement.'</pre></td></tr></table>'; 
+	} else {
+	    return '';
+	}
+    } else {
+	return '';
+    }
+}
+
 # ---------------------------------------------------------- Course ID routines
 # Deal with domain's nohist_courseid.db files
 #
@@ -2077,6 +2185,21 @@ sub dump {
    return %returnhash;
 }
 
+# -------------------------------------------------------------- keys interface
+
+sub getkeys {
+   my ($namespace,$udomain,$uname)=@_;
+   if (!$udomain) { $udomain=$ENV{'user.domain'}; }
+   if (!$uname) { $uname=$ENV{'user.name'}; }
+   my $uhome=&homeserver($uname,$udomain);
+   my $rep=reply("keys:$udomain:$uname:$namespace",$uhome);
+   my @keyarray=();
+   foreach (split(/\&/,$rep)) {
+      push (@keyarray,&unescape($_));
+   }
+   return @keyarray;
+}
+
 # --------------------------------------------------------------- currentdump
 sub currentdump {
    my ($courseid,$sdom,$sname)=@_;
@@ -2209,6 +2332,9 @@ sub customaccess {
             $access=($effect eq 'allow');
             last;
         }
+	if ($realm eq '' && $role eq '') {
+            $access=($effect eq 'allow');
+	}
     }
     return $access;
 }
@@ -2221,6 +2347,7 @@ sub allowed {
     my $orguri=$uri;
     $uri=&declutter($uri);
 
+    if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; }
 # Free bre access to adm and meta resources
 
     if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) {
@@ -2512,7 +2639,10 @@ 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);
     }
 }
 
@@ -2642,7 +2772,7 @@ sub userlog_query {
 
 sub plaintext {
     my $short=shift;
-    return $prp{$short};
+    return &mt($prp{$short});
 }
 
 # ----------------------------------------------------------------- Assign Role
@@ -2746,7 +2876,8 @@ sub modifyuser {
              ' in domain '.$ENV{'request.role.domain'});
     my $uhome=&homeserver($uname,$udom,'true');
 # ----------------------------------------------------------------- Create User
-    if (($uhome eq 'no_host') && ($umode) && ($upass)) {
+    if (($uhome eq 'no_host') && 
+	(($umode && $upass) || ($umode eq 'localauth'))) {
         my $unhome='';
         if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) { 
             $unhome = $desiredhome;
@@ -3086,6 +3217,13 @@ sub dirlist {
 # when it was last modified.  It will also return an error of -1
 # if an error occurs
 
+##
+## FIXME: This subroutine assumes its caller knows something about the
+## directory structure of the home server for the student ($root).
+## Not a good assumption to make.  Since this is for looking up files
+## in user directories, the full path should be constructed by lond, not
+## whatever machine we request data from.
+##
 sub GetFileTimestamp {
     my ($studentDomain,$studentName,$filename,$root)=@_;
     $studentDomain=~s/\W//g;
@@ -3171,25 +3309,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,300);
+    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);
 	} elsif ($tmp =~ /^(con_lost|no_such_host)/) {
 	    return $tmp;
+	} elsif ($tmp =~ /^(error)/) {
+	    $result=undef;
+	    &do_cache(\%courseresdatacache,$hashid,$result);
 	}
     }
     foreach my $item (@which) {
-	if (defined($courseresdatacache{$hashid}->{$item})) {
-	    return $courseresdatacache{$hashid}->{$item};
+	if (defined($result->{$item})) {
+	    return $result->{$item};
 	}
     }
     return undef;
@@ -3331,7 +3467,7 @@ sub EXT {
 # ----------------------------------------------------- Cascading lookup scheme
 	    if (!$symbparm) { $symbparm=&symbread(); }
 	    my $symbp=$symbparm;
-	    my $mapp=(split(/\_\_\_/,$symbp))[0];
+	    my $mapp=(&decode_symb($symbp))[0];
 
 	    my $symbparm=$symbp.'.'.$spacequalifierrest;
 	    my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
@@ -3410,7 +3546,7 @@ sub EXT {
 	my $filename;
 	if (!$symbparm) { $symbparm=&symbread(); }
 	if ($symbparm) {
-	    $filename=(split(/\_\_\_/,$symbparm))[2];
+	    $filename=(&decode_symb($symbparm))[2];
 	} else {
 	    $filename=$ENV{'request.filename'};
 	}
@@ -3506,14 +3642,15 @@ sub metadata {
         if ($liburi) {
 	    $liburi=&declutter($liburi);
             $filename=$liburi;
-        }
+        } else {
+	    delete($metacache{$uri.':packages'});
+	}
         my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }
 	my $metastring=&getfile(&filelocation('',&clutter($filename)));
         my $parser=HTML::LCParser->new(\$metastring);
         my $token;
         undef %metathesekeys;
-	delete($metacache{$uri.':packages'});
         while ($token=$parser->get_token) {
 	    if ($token->[0] eq 'S') {
 		if (defined($token->[2]->{'package'})) {
@@ -3684,7 +3821,7 @@ sub gettitle {
 	    delete($titlecache{$symb});
 	}
     }
-    my ($map,$resid,$url)=split(/\_\_\_/,$symb);
+    my ($map,$resid,$url)=&decode_symb($symb);
     my $title='';
     my %bighash;
     if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
@@ -3730,7 +3867,7 @@ sub symbverify {
 # direct jump to resource in page or to a sequence - will construct own symbs
     if ($thisfn=~/\.(page|sequence)$/) { return 1; }
 # check URL part
-    my ($map,$resid,$url)=split(/\_\_\_/,$symb);
+    my ($map,$resid,$url)=&decode_symb($symb);
     unless (&symbclean($url) eq &symbclean($thisfn)) { return 0; }
 
     $symb=&symbclean($symb);
@@ -3773,6 +3910,23 @@ sub symbclean {
     return $symb;
 }
 
+# ---------------------------------------------- Split symb to find map and url
+
+sub decode_symb {
+    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
 
 sub symbread {
@@ -4072,6 +4226,12 @@ sub unescape {
     return $str;
 }
 
+sub mod_perl_version {
+    if (defined($perlvar{'MODPERL2'})) {
+	return 2;
+    }
+    return 1;
+}
 # ================================================================ Main Program
 
 sub goodbye {
@@ -4119,11 +4279,16 @@ BEGIN {
            next if (/^(\#|\s*$)/);
 #           next if /^\#/;
            chomp;
-           my ($domain, $domain_description, $def_auth, $def_auth_arg)
-               = split(/:/,$_,4);
-           $domain_auth_def{$domain}=$def_auth;
+           my ($domain, $domain_description, $def_auth, $def_auth_arg,
+	       $def_lang, $city, $longi, $lati) = split(/:/,$_);
+	   $domain_auth_def{$domain}=$def_auth;
            $domain_auth_arg_def{$domain}=$def_auth_arg;
-           $domaindescription{$domain}=$domain_description;
+	   $domaindescription{$domain}=$domain_description;
+	   $domain_lang_def{$domain}=$def_lang;
+	   $domain_city{$domain}=$city;
+	   $domain_longi{$domain}=$longi;
+	   $domain_lati{$domain}=$lati;
+
 #          &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");
 #          &logthis("Domain.tab: $domain ".$domaindescription{$domain} );
        }