--- loncom/lonnet/perl/lonnet.pm	2001/10/02 18:32:56	1.160
+++ loncom/lonnet/perl/lonnet.pm	2001/11/22 20:09:22	1.177
@@ -1,6 +1,46 @@
 # The LearningOnline Network
 # TCP networking package
 #
+# 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30,
+# 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19,
+# 11/8,11/16,11/18,11/22,11/23,12/22,
+# 01/06,01/13,02/24,02/28,02/29,
+# 03/01,03/02,03/06,03/07,03/13,
+# 04/05,05/29,05/31,06/01,
+# 06/05,06/26 Gerd Kortemeyer
+# 06/26 Ben Tyszka
+# 06/30,07/15,07/17,07/18,07/20,07/21,07/22,07/25 Gerd Kortemeyer
+# 08/14 Ben Tyszka
+# 08/22,08/28,08/31,09/01,09/02,09/04,09/05,09/25,09/28,09/30 Gerd Kortemeyer
+# 10/04 Gerd Kortemeyer
+# 10/04 Guy Albertelli
+# 10/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29, 
+# 10/30,10/31,
+# 11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25,11/27,
+# 12/02,12/12,12/13,12/14,12/28,12/29 Gerd Kortemeyer
+# 05/01/01 Guy Albertelli
+# 05/01,06/01,09/01 Gerd Kortemeyer
+# 09/01 Guy Albertelli
+# 09/01,10/01,11/01 Gerd Kortemeyer
+# YEAR=2001
+# 02/27/01 Scott Harrison
+# 3/2 Gerd Kortemeyer
+# 3/15,3/19 Scott Harrison
+# 3/19,3/20 Gerd Kortemeyer
+# 3/22,3/27,4/2,4/16,4/17 Scott Harrison
+# 5/26,5/28 Gerd Kortemeyer
+# 5/30 H. K. Ng
+# 6/1 Gerd Kortemeyer
+# July Guy Albertelli
+# 8/4,8/7,8/8,8/9,8/11,8/16,8/17,8/18,8/20,8/23,9/20,9/21,9/26,
+# 10/2 Gerd Kortemeyer
+# 10/5,10/10,11/13,11/15 Scott Harrison
+# 11/17,11/20,11/22 Gerd Kortemeyer
+#
+# $Id: lonnet.pm,v 1.177 2001/11/22 20:09:22 www Exp $
+#
+###
+
 # Functions for use by content handlers:
 #
 # metadata_query(sql-query-string,custom-metadata-regex) : 
@@ -97,38 +137,6 @@
 # metadata(file,entry): returns the metadata entry for a file. entry='keys'
 #                       returns a comma separated list of keys
 #
-# 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30,
-# 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19,
-# 11/8,11/16,11/18,11/22,11/23,12/22,
-# 01/06,01/13,02/24,02/28,02/29,
-# 03/01,03/02,03/06,03/07,03/13,
-# 04/05,05/29,05/31,06/01,
-# 06/05,06/26 Gerd Kortemeyer
-# 06/26 Ben Tyszka
-# 06/30,07/15,07/17,07/18,07/20,07/21,07/22,07/25 Gerd Kortemeyer
-# 08/14 Ben Tyszka
-# 08/22,08/28,08/31,09/01,09/02,09/04,09/05,09/25,09/28,09/30 Gerd Kortemeyer
-# 10/04 Gerd Kortemeyer
-# 10/04 Guy Albertelli
-# 10/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29, 
-# 10/30,10/31,
-# 11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25,11/27,
-# 12/02,12/12,12/13,12/14,12/28,12/29 Gerd Kortemeyer
-# 05/01/01 Guy Albertelli
-# 05/01,06/01,09/01 Gerd Kortemeyer
-# 09/01 Guy Albertelli
-# 09/01,10/01,11/01 Gerd Kortemeyer
-# 02/27/01 Scott Harrison
-# 3/2 Gerd Kortemeyer
-# 3/15,3/19 Scott Harrison
-# 3/19,3/20 Gerd Kortemeyer
-# 3/22,3/27,4/2,4/16,4/17 Scott Harrison
-# 5/26,5/28 Gerd Kortemeyer
-# 5/30 H. K. Ng
-# 6/1 Gerd Kortemeyer
-# July Guy Albertelli
-# 8/4,8/7,8/8,8/9,8/11,8/16,8/17,8/18,8/20,8/23,9/20,9/21,9/26,
-# 10/2 Gerd Kortemeyer
 
 package Apache::lonnet;
 
@@ -146,6 +154,16 @@ use Fcntl qw(:flock);
 
 # --------------------------------------------------------------------- Logging
 
+sub logtouch {
+    my $execdir=$perlvar{'lonDaemons'};
+    unless (-e "$execdir/logs/lonnet.log") {
+	my $fh=Apache::File->new(">>$execdir/logs/lonnet.log");
+	close $fh;
+    }
+    my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];
+    chown($wwwuid,$wwwgid,$execdir.'/logs/lonnet.log');
+}
+
 sub logthis {
     my $message=shift;
     my $execdir=$perlvar{'lonDaemons'};
@@ -394,6 +412,44 @@ sub spareserver {
     return $spareserver;
 }
 
+# ----------------------- Try to determine user's current authentication scheme
+
+sub queryauthenticate {
+    my ($uname,$udom)=@_;
+    if (($perlvar{'lonRole'} eq 'library') && 
+        ($udom eq $perlvar{'lonDefDomain'})) {
+	my $answer=reply("encrypt:currentauth:$udom:$uname",
+			 $perlvar{'lonHostID'});
+	unless ($answer eq 'unknown_user' or $answer eq 'refused') {
+	    if (length($answer)) {
+		return $answer;
+	    }
+	    else {
+	&logthis("User $uname at $udom lacks an authentication mechanism");
+		return 'no_host';
+	    }
+	}
+    }
+
+    my $tryserver;
+    foreach $tryserver (keys %libserv) {
+	if ($hostdom{$tryserver} eq $udom) {
+           my $answer=reply("encrypt:currentauth:$udom:$uname",$tryserver);
+	   unless ($answer eq 'unknown_user' or $answer eq 'refused') {
+	       if (length($answer)) {
+		   return $answer;
+	       }
+	       else {
+	   &logthis("User $uname at $udom lacks an authentication mechanism");
+		   return 'no_host';
+	       }
+	   }
+       }
+    }
+    &logthis("User $uname at $udom lacks an authentication mechanism");    
+    return 'no_host';
+}
+
 # --------- Try to authenticate user from domain's lib servers (first this one)
 
 sub authenticate {
@@ -842,15 +898,155 @@ sub devalidate {
     }
 }
 
+sub hash2str {
+  my (%hash)=@_;
+  my $result='';
+  map { $result.=escape($_).'='.escape($hash{$_}).'&'; } keys %hash;
+  $result=~s/\&$//;
+  return $result;
+}
+
+sub str2hash {
+  my ($string) = @_;
+  my %returnhash;
+  map {
+    my ($name,$value)=split(/\=/,$_);
+    $returnhash{&unescape($name)}=&unescape($value);
+  } split(/\&/,$string);
+  return %returnhash;
+}
+
+# -------------------------------------------------------------------Temp Store
+
+sub tmpreset {
+  my ($symb,$namespace,$domain,$stuname) = @_;
+  if (!$symb) {
+    $symb=&symbread();
+    if (!$symb) { $symb= $ENV{'REQUEST_URI'}; }
+  }
+  $symb=escape($symb);
+
+  if (!$namespace) { $namespace=$ENV{'request.state'}; }
+  $namespace=~s/\//\_/g;
+  $namespace=~s/\W//g;
+
+  #FIXME needs to do something for /pub resources
+  if (!$domain) { $domain=$ENV{'user.domain'}; }
+  if (!$stuname) { $stuname=$ENV{'user.name'}; }
+  my $path=$perlvar{'lonDaemons'}.'/tmp';
+  my %hash;
+  if (tie(%hash,'GDBM_File',
+	  $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
+	  &GDBM_WRCREAT,0640)) {
+    foreach my $key (keys %hash) {
+      if ($key=~ /:$symb:/) {
+	delete($hash{$key});
+      }
+    }
+  }
+}
+
+sub tmpstore {
+  my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
+
+  if (!$symb) {
+    $symb=&symbread();
+    if (!$symb) { $symb= $ENV{'request.url'}; }
+  }
+  $symb=escape($symb);
+
+  if (!$namespace) {
+    # I don't think we would ever want to store this for a course.
+    # it seems this will only be used if we don't have a course.
+    #$namespace=$ENV{'request.course.id'};
+    #if (!$namespace) {
+      $namespace=$ENV{'request.state'};
+    #}
+  }
+  $namespace=~s/\//\_/g;
+  $namespace=~s/\W//g;
+#FIXME needs to do something for /pub resources
+  if (!$domain) { $domain=$ENV{'user.domain'}; }
+  if (!$stuname) { $stuname=$ENV{'user.name'}; }
+  my $now=time;
+  my %hash;
+  my $path=$perlvar{'lonDaemons'}.'/tmp';
+  if (tie(%hash,'GDBM_File',
+	  $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
+	  &GDBM_WRCREAT,0640)) {
+    $hash{"version:$symb"}++;
+    my $version=$hash{"version:$symb"};
+    my $allkeys=''; 
+    foreach my $key (keys(%$storehash)) {
+      $allkeys.=$key.':';
+      $hash{"$version:$symb:$key"}=$$storehash{$key};
+    }
+    $hash{"$version:$symb:timestamp"}=$now;
+    $allkeys.='timestamp';
+    $hash{"$version:keys:$symb"}=$allkeys;
+    if (untie(%hash)) {
+      return 'ok';
+    } else {
+      return "error:$!";
+    }
+  } else {
+    return "error:$!";
+  }
+}
+
+# -----------------------------------------------------------------Temp Restore
+
+sub tmprestore {
+  my ($symb,$namespace,$domain,$stuname) = @_;
+
+  if (!$symb) {
+    $symb=&symbread();
+    if (!$symb) { $symb= $ENV{'request.url'}; }
+  }
+  $symb=escape($symb);
+
+  if (!$namespace) { $namespace=$ENV{'request.state'}; }
+  #FIXME needs to do something for /pub resources
+  if (!$domain) { $domain=$ENV{'user.domain'}; }
+  if (!$stuname) { $stuname=$ENV{'user.name'}; }
+
+  my %returnhash;
+  $namespace=~s/\//\_/g;
+  $namespace=~s/\W//g;
+  my %hash;
+  my $path=$perlvar{'lonDaemons'}.'/tmp';
+  if (tie(%hash,'GDBM_File',
+	  $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
+	  &GDBM_READER,0640)) {
+    my $version=$hash{"version:$symb"};
+    $returnhash{'version'}=$version;
+    my $scope;
+    for ($scope=1;$scope<=$version;$scope++) {
+      my $vkeys=$hash{"$scope:keys:$symb"};
+      my @keys=split(/:/,$vkeys);
+      my $key;
+      $returnhash{"$scope:keys"}=$vkeys;
+      foreach $key (@keys) {
+	$returnhash{"$scope:$key"}=$hash{"$scope:$symb:$key"};
+	$returnhash{"$key"}=$hash{"$scope:$symb:$key"};
+      }
+    }
+    if (!(untie(%hash))) {
+      return "error:$!";
+    }
+  } else {
+    return "error:$!";
+  }
+  return %returnhash;
+}
+
 # ----------------------------------------------------------------------- Store
 
 sub store {
     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
     my $home='';
 
-    if ($stuname) {
-	$home=&homeserver($stuname,$domain);
-    }
+    if ($stuname) { $home=&homeserver($stuname,$domain); }
 
     if (!$symb) { unless ($symb=&symbread()) { return ''; } }
 
@@ -875,9 +1071,7 @@ sub cstore {
     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
     my $home='';
 
-    if ($stuname) {
-	$home=&homeserver($stuname,$domain);
-    }
+    if ($stuname) { $home=&homeserver($stuname,$domain); }
 
     if (!$symb) { unless ($symb=&symbread()) { return ''; } }
 
@@ -903,9 +1097,7 @@ sub restore {
     my ($symb,$namespace,$domain,$stuname) = @_;
     my $home='';
 
-    if ($stuname) {
-	$home=&homeserver($stuname,$domain);
-    }
+    if ($stuname) { $home=&homeserver($stuname,$domain); }
 
     if (!$symb) {
       unless ($symb=escape(&symbread())) { return ''; }
@@ -1229,7 +1421,7 @@ sub allowed {
 
 # If this is generating or modifying users, exit with special codes
 
-    if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:'=~/\:$priv\:/) {
+    if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:$priv\:/) {
 	return $thisallowed;
     }
 #
@@ -1470,7 +1662,6 @@ sub definerole {
 
 sub metadata_query {
     my ($query,$custom,$customshow)=@_;
-    # need to put in a library server loop here and return a hash
     my %rhash;
     for my $server (keys %libserv) {
 	unless ($custom or $customshow) {
@@ -1545,6 +1736,20 @@ sub assignrole {
     return &reply($command,&homeserver($uname,$udom));
 }
 
+# -------------------------------------------------- Modify user authentication
+sub modifyuserauth {
+    my ($udom,$uname,$umode,$upass)=@_;
+    my $uhome=&homeserver($uname,$udom);
+    &logthis('Call to modify user authentication'.$udom.', '.$uname.', '.
+             $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'});  
+    my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.
+		     &escape($upass),$uhome);
+    unless ($reply eq 'ok') {
+	return 'error: '.$reply;
+    }   
+    return 'ok';
+}
+
 # --------------------------------------------------------------- Modify a user
 
 
@@ -2027,12 +2232,24 @@ sub EXT {
 # ---------------------------------------------------------------- Get metadata
 
 sub metadata {
-    my ($uri,$what)=@_;
+    my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
 
     $uri=&declutter($uri);
     my $filename=$uri;
     $uri=~s/\.meta$//;
-    unless ($metacache{$uri.':keys'}) {
+#
+# Is the metadata already cached?
+# Look at timestamp of caching
+# Everything is cached by the main uri, libraries are never directly cached
+#
+    unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600) {
+#
+# Is this a recursive call for a library?
+#
+        if ($liburi) {
+	    $liburi=&declutter($liburi);
+            $filename=$liburi;
+        }
         my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }
 	my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
@@ -2042,10 +2259,17 @@ sub metadata {
         while ($token=$parser->get_token) {
            if ($token->[0] eq 'S') {
 	     if (defined($token->[2]->{'package'})) {
+#
+# This is a package - get package info
+#
 	      my $package=$token->[2]->{'package'};
 	      my $keyroot='';
-              if (defined($token->[2]->{'part'})) { 
-                 $keyroot.='_'.$token->[2]->{'part'}; 
+              if ($prefix) {
+		  $keyroot.='_'.$prefix;
+              } else {
+                if (defined($token->[2]->{'part'})) { 
+                   $keyroot.='_'.$token->[2]->{'part'}; 
+	        }
 	      }
               if (defined($token->[2]->{'id'})) { 
                  $keyroot.='_'.$token->[2]->{'id'}; 
@@ -2074,14 +2298,42 @@ sub metadata {
                   }
               } keys %packagetab;
              } else {
-	      my $entry=$token->[1];
-              my $unikey=$entry;
-              if (defined($token->[2]->{'part'})) { 
-                 $unikey.='_'.$token->[2]->{'part'}; 
+#
+# This is not a package - some other kind of start tag
+# 
+              my $entry=$token->[1];
+              my $unikey;
+              if ($entry eq 'import') {
+                 $unikey='';
+              } else {
+                 $unikey=$entry;
+	      }
+              if ($prefix) {
+		  $unikey.=$prefix;
+              } else {
+                if (defined($token->[2]->{'part'})) { 
+                   $unikey.='_'.$token->[2]->{'part'}; 
+	        }
 	      }
               if (defined($token->[2]->{'id'})) { 
                  $unikey.='_'.$token->[2]->{'id'}; 
 	      }
+
+             if ($entry eq 'import') {
+#
+# Importing a library here
+#                
+		 if (defined($depthcount)) { $depthcount++; } else 
+                                           { $depthcount=0; }
+                 if ($depthcount<20) {
+		     map {
+                         $metathesekeys{$_}=1;
+		     } split(/\,/,&metadata($uri,'keys',
+                                  $parser->get_text('/import'),$unikey,
+                                  $depthcount));
+		 }
+             } else { 
+
               if (defined($token->[2]->{'name'})) { 
                  $unikey.='_'.$token->[2]->{'name'}; 
 	      }
@@ -2094,10 +2346,16 @@ sub metadata {
 		      ) { $metacache{$uri.':'.$unikey}=
 			      $metacache{$uri.':'.$unikey.'.default'};
 		      }
-	    }
+# end of not-a-package not-a-library import
+	   }
+# end of not-a-package start tag
+	  }
+# the next is the end of "start tag"
 	 }
        }
        $metacache{$uri.':keys'}=join(',',keys %metathesekeys);
+       $metacache{$uri.':cachedtimestamp'}=time;
+# this is the end of "was not already recently cached
     }
     return $metacache{$uri.':'.$what};
 }
@@ -2421,6 +2679,7 @@ unless ($readit) {
 %metacache=();
 
 $readit='done';
+&logtouch();
 &logthis('<font color=yellow>INFO: Read configuration</font>');
 }
 }