--- loncom/lonnet/perl/lonnet.pm	2001/06/01 19:32:40	1.128
+++ loncom/lonnet/perl/lonnet.pm	2001/08/04 14:45:28	1.137
@@ -40,12 +40,27 @@
 #                    : returns hash for this symb, all args are optional
 #                      if they aren't given they will be derived from the 
 #                      current enviroment
-# eget(namesp,array) : returns hash with keys from array filled in from namesp
-# get(namesp,array)  : returns hash with keys from array filled in from namesp
-# del(namesp,array)  : deletes keys out of array from namesp
-# put(namesp,hash)   : stores hash in namesp
-# cput(namesp,hash)  : critical put
-# dump(namesp)       : dumps the complete namespace into a hash
+#
+#
+# for the next 6 functions udom and uname are optional
+#         if supplied they use udom as the domain and uname
+#         as the username for the function (supply a courseid
+#         for the uname if you want a course database)
+#         if not supplied it uses %ENV and looks at 
+#         user. attribute for the values
+#
+# eget(namesp,arrayref,udom,uname)
+#                    : returns hash with keys from array  reference filled
+#                      in from namesp (encrypts the return communication)
+# get(namesp,arrayref,udom,uname)
+#                    : returns hash with keys from array  reference filled
+#                      in from namesp
+# dump(namesp,udom,uname) : dumps the complete namespace into a hash
+# del(namesp,array,udom,uname)  : deletes keys out of array from namesp
+# put(namesp,hash,udom,uname)   : stores hash in namesp
+# cput(namesp,hash,udom,uname)  : critical put
+#
+#
 # ssi(url,hash)      : does a complete request cycle on url to localhost, posts
 #                      hash
 # coursedescription(id) : returns and caches course description for id
@@ -106,7 +121,8 @@
 # 5/26,5/28 Gerd Kortemeyer
 # 5/30 H. K. Ng
 # 6/1 Gerd Kortemeyer
-#
+# July Guy Albertelli
+# 8/4 Gerd Kortemeyer
 
 package Apache::lonnet;
 
@@ -115,7 +131,7 @@ use Apache::File;
 use LWP::UserAgent();
 use HTTP::Headers;
 use vars 
-qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache);
+qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache %packagetab);
 use IO::Socket;
 use GDBM_File;
 use Apache::Constants qw(:common :http);
@@ -668,22 +684,18 @@ sub devalidate {
     if ($cid) {
 	my $key=$ENV{'user.name'}.':'.$ENV{'user.domain'}.':';
         my $status=
-          &reply('del:'.$ENV{'course.'.$cid.'.domain'}.':'.
-                        $ENV{'course.'.$cid.'.num'}.
-	                ':nohist_calculatedsheets:'.
-                        &escape($key.'studentcalc:'),
-                        $ENV{'course.'.$cid.'.home'})
-          .' '.
-          &reply('del:'.$ENV{'user.domain'}.':'.
-                        $ENV{'user.name'}.
-		        ':nohist_calculatedsheets_'.$cid.':'.
-                        &escape($key.'assesscalc:'.$symb),
-                        $ENV{'user.home'});
+	    &del('nohist_calculatedsheet',
+		 [$key.'studentcalc'],
+		 $ENV{'course.'.$cid.'.domain'},
+		 $ENV{'course.'.$cid.'.num'})
+		.' '.
+	    &del('nohist_calculatedsheets_'.$cid,
+		 [$key.'assesscalc:'.$symb]);
         unless ($status eq 'ok ok') {
            &logthis('Could not devalidate spreadsheet '.
                     $ENV{'user.name'}.' at '.$ENV{'user.domain'}.' for '.
 		    $symb.': '.$status);
-        } 
+        }
     }
 }
 
@@ -784,22 +796,18 @@ sub coursedescription {
     $courseid=~s/^\///;
     $courseid=~s/\_/\//g;
     my ($cdomain,$cnum)=split(/\//,$courseid);
-    my $chome=homeserver($cnum,$cdomain);
+    my $chome=&homeserver($cnum,$cdomain);
     if ($chome ne 'no_host') {
-       my $rep=reply("dump:$cdomain:$cnum:environment",$chome);
-       if ($rep ne 'con_lost') {
+       my %returnhash=&dump('environment',$cdomain,$cnum);
+       if (!exists($returnhash{'con_lost'})) {
            my $normalid=$cdomain.'_'.$cnum;
            my %envhash=();
-           my %returnhash=('home'   => $chome, 
-                           'domain' => $cdomain,
-                           'num'    => $cnum);
-           map {
-               my ($name,$value)=split(/\=/,$_);
-               $name=&unescape($name);
-               $value=&unescape($value);
-               $returnhash{$name}=$value;
+           $returnhash{'home'}= $chome;
+	   $returnhash{'domain'} = $cdomain;
+	   $returnhash{'num'} = $cnum;
+           while (my ($name,$value) = each %returnhash) {
                $envhash{'course.'.$normalid.'.'.$name}=$value;
-           } split(/\&/,$rep);
+           }
            $returnhash{'url'}='/res/'.declutter($returnhash{'url'});
            $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
 	       $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;
@@ -916,43 +924,51 @@ sub rolesinit {
 # --------------------------------------------------------------- get interface
 
 sub get {
-   my ($namespace,@storearr)=@_;
+   my ($namespace,$storearr,$udomain,$uname)=@_;
    my $items='';
    map {
        $items.=escape($_).'&';
-   } @storearr;
+   } @$storearr;
    $items=~s/\&$//;
- my $rep=reply("get:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
-                 $ENV{'user.home'});
+   if (!$udomain) { $udomain=$ENV{'user.domain'}; }
+   if (!$uname) { $uname=$ENV{'user.name'}; }
+   my $uhome=&homeserver($uname,$udomain);
+
+   my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome);
    my @pairs=split(/\&/,$rep);
    my %returnhash=();
    my $i=0;
    map {
       $returnhash{$_}=unescape($pairs[$i]);
       $i++;
-   } @storearr;
+   } @$storearr;
    return %returnhash;
 }
 
 # --------------------------------------------------------------- del interface
 
 sub del {
-   my ($namespace,@storearr)=@_;
+   my ($namespace,$storearr,$udomain,$uname)=@_;
    my $items='';
    map {
        $items.=escape($_).'&';
-   } @storearr;
+   } @$storearr;
    $items=~s/\&$//;
-   return reply("del:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
-                 $ENV{'user.home'});
+   if (!$udomain) { $udomain=$ENV{'user.domain'}; }
+   if (!$uname) { $uname=$ENV{'user.name'}; }
+   my $uhome=&homeserver($uname,$udomain);
+
+   return &reply("del:$udomain:$uname:$namespace:$items",$uhome);
 }
 
 # -------------------------------------------------------------- dump interface
 
 sub dump {
-   my $namespace=shift;
-   my $rep=reply("dump:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace",
-                $ENV{'user.home'});
+   my ($namespace,$udomain,$uname)=@_;
+   if (!$udomain) { $udomain=$ENV{'user.domain'}; }
+   if (!$uname) { $uname=$ENV{'user.name'}; }
+   my $uhome=&homeserver($uname,$udomain);
+   my $rep=reply("dump:$udomain:$uname:$namespace",$uhome);
    my @pairs=split(/\&/,$rep);
    my %returnhash=();
    map {
@@ -965,48 +981,53 @@ sub dump {
 # --------------------------------------------------------------- put interface
 
 sub put {
-   my ($namespace,%storehash)=@_;
+   my ($namespace,$storehash,$udomain,$uname)=@_;
+   if (!$udomain) { $udomain=$ENV{'user.domain'}; }
+   if (!$uname) { $uname=$ENV{'user.name'}; }
+   my $uhome=&homeserver($uname,$udomain);
    my $items='';
    map {
-       $items.=escape($_).'='.escape($storehash{$_}).'&';
-   } keys %storehash;
+       $items.=&escape($_).'='.&escape($$storehash{$_}).'&';
+   } keys %$storehash;
    $items=~s/\&$//;
-   return reply("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
-                 $ENV{'user.home'});
+   return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
 }
 
 # ------------------------------------------------------ critical put interface
 
 sub cput {
-   my ($namespace,%storehash)=@_;
+   my ($namespace,$storehash,$udomain,$uname)=@_;
+   if (!$udomain) { $udomain=$ENV{'user.domain'}; }
+   if (!$uname) { $uname=$ENV{'user.name'}; }
+   my $uhome=&homeserver($uname,$udomain);
    my $items='';
    map {
-       $items.=escape($_).'='.escape($storehash{$_}).'&';
-   } keys %storehash;
+       $items.=escape($_).'='.escape($$storehash{$_}).'&';
+   } keys %$storehash;
    $items=~s/\&$//;
-   return critical
-           ("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
-                 $ENV{'user.home'});
+   return &critical("put:$udomain:$uname:$namespace:$items",$uhome);
 }
 
 # -------------------------------------------------------------- eget interface
 
 sub eget {
-   my ($namespace,@storearr)=@_;
+   my ($namespace,$storearr,$udomain,$uname)=@_;
    my $items='';
    map {
        $items.=escape($_).'&';
-   } @storearr;
+   } @$storearr;
    $items=~s/\&$//;
- my $rep=reply("eget:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
-                 $ENV{'user.home'});
+   if (!$udomain) { $udomain=$ENV{'user.domain'}; }
+   if (!$uname) { $uname=$ENV{'user.name'}; }
+   my $uhome=&homeserver($uname,$udomain);
+   my $rep=&reply("eget:$udomain:$uname:$namespace:$items",$uhome);
    my @pairs=split(/\&/,$rep);
    my %returnhash=();
    my $i=0;
    map {
       $returnhash{$_}=unescape($pairs[$i]);
       $i++;
-   } @storearr;
+   } @$storearr;
    return %returnhash;
 }
 
@@ -1415,27 +1436,20 @@ sub modifyuser {
        }
     }
 # -------------------------------------------------------------- Add names, etc
-    my $names=&reply('get:'.$udom.':'.$uname.
-                     ':environment:firstname&middlename&lastname&generation',
-                     $uhome);
-    my ($efirst,$emiddle,$elast,$egene)=split(/\&/,$names);
-    if ($first)  { $efirst  = &escape($first); }
-    if ($middle) { $emiddle = &escape($middle); }
-    if ($last)   { $elast   = &escape($last); }
-    if ($gene)   { $egene   = &escape($gene); }
-    my $reply=&reply('put:'.$udom.':'.$uname.
-           ':environment:firstname='.$efirst.
-                      '&middlename='.$emiddle.
-                        '&lastname='.$elast.
-                      '&generation='.$egene,$uhome);
-    if ($reply ne 'ok') {
-	return 'error: '.$reply;
-    }
+    my %names=&get('environment',
+		   ['firstname','middlename','lastname','generation'],
+		   $udom,$uname);
+    if ($first)  { $names{'firstname'}  = $first; }
+    if ($middle) { $names{'middlename'} = $middle; }
+    if ($last)   { $names{'lastname'}   = $last; }
+    if ($gene)   { $names{'generation'} = $gene; }
+    my $reply = &put('environment', \%names, $udom,$uname);
+    if ($reply ne 'ok') { return 'error: '.$reply; }
     &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
              $umode.', '.$first.', '.$middle.', '.
 	     $last.', '.$gene.' by '.
              $ENV{'user.name'}.' at '.$ENV{'user.domain'});
-    return 'ok'; 
+    return 'ok';
 }
 
 # -------------------------------------------------------------- Modify student
@@ -1704,7 +1718,7 @@ sub EXT {
 # ---------------------------------------------------- Any other user namespace
         } else {
             my $item=($rest)?$qualifier.'.'.$rest:$qualifier;
-            my %reply=&get($space,$item);
+            my %reply=&get($space,[$item]);
             return $reply{$item};
         }
     } elsif ($realm eq 'request') {
@@ -1747,7 +1761,7 @@ sub EXT {
 
 # ----------------------------------------------------------- first, check user
          my %resourcedata=get('resourcedata',
-                           ($courselevelr,$courselevelm,$courselevel));
+                           [$courselevelr,$courselevelm,$courselevel]);
          if (($resourcedata{$courselevelr}!~/^error\:/) &&
              ($resourcedata{$courselevelr}!~/^con_lost/)) {
 
@@ -1838,11 +1852,45 @@ sub metadata {
         my $token;
         while ($token=$parser->get_token) {
            if ($token->[0] eq 'S') {
+	     if (defined($token->[2]->{'package'})) {
+	      my $package=$token->[2]->{'package'};
+              my %thispackagekeys=();
+	      my $keyroot='';
+              if (defined($token->[2]->{'part'})) { 
+                 $keyroot.='_'.$token->[2]->{'part'}; 
+	      }
+              if (defined($token->[2]->{'id'})) { 
+                 $keyroot.='_'.$token->[2]->{'id'}; 
+	      }
+              if ($metacache{$uri.':packages'}) {
+                 $metacache{$uri.':packages'}.=','.$package.$keyroot;
+              } else {
+                 $metacache{$uri.':packages'}=$package.$keyroot;
+	      }
+              undef %thispackagekeys;
+              map {
+		  if ($_=~/^$package\&/) {
+		      my ($pack,$name,$subp)=split(/\&/,$_);
+                      my $unikey='parameter_'.$keyroot.'_'.$name;
+                      $thispackagekeys{$unikey}=1;
+                      $metacache{$uri.':'.$unikey.'.'.$subp}=$packagetab{$_};
+                  }
+              } keys %packagetab;
+              my $addpackagekeys=join(',',keys %thispackagekeys);
+              if ($metacache{$uri.':keys'}) {
+                 $metacache{$uri.':keys'}.=','.$addpackagekeys;
+              } else {
+                 $metacache{$uri.':keys'}=$addpackagekeys;
+	      }
+             } else {
 	      my $entry=$token->[1];
               my $unikey=$entry;
               if (defined($token->[2]->{'part'})) { 
                  $unikey.='_'.$token->[2]->{'part'}; 
 	      }
+              if (defined($token->[2]->{'id'})) { 
+                 $unikey.='_'.$token->[2]->{'id'}; 
+	      }
               if (defined($token->[2]->{'name'})) { 
                  $unikey.='_'.$token->[2]->{'name'}; 
 	      }
@@ -1859,7 +1907,8 @@ sub metadata {
 		      ) { $metacache{$uri.':'.$unikey}=
 			      $metacache{$uri.':'.$unikey.'.default'};
 		      }
-          }
+	    }
+	  }
        }
     }
     return $metacache{$uri.':'.$what};
@@ -2141,6 +2190,17 @@ if ($readit ne 'done') {
     }
 }
 
+# ---------------------------------------------------------- Read package table
+{
+    my $config=Apache::File->new("$perlvar{'lonTabDir'}/packages.tab");
+
+    while (my $configline=<$config>) {
+       chomp($configline);
+       my ($short,$plain)=split(/:/,$configline);
+       if ($plain ne '') { $packagetab{$short}=$plain; }
+    }
+}
+
 # ------------------------------------------------------------- Read file types
 {
     my $config=Apache::File->new("$perlvar{'lonTabDir'}/filetypes.tab");