--- loncom/lonnet/perl/lonnet.pm	2001/07/26 21:40:27	1.133
+++ loncom/lonnet/perl/lonnet.pm	2001/08/16 11:25:03	1.149
@@ -42,7 +42,7 @@
 #                      current enviroment
 #
 #
-# for the next 4 functions udom and uname are optional
+# 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)
@@ -57,10 +57,10 @@
 #                      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
 #
 #
-# put(namesp,hash)   : stores hash in namesp
-# cput(namesp,hash)  : 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
@@ -121,7 +121,8 @@
 # 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 Gerd Kortemeyer
 
 package Apache::lonnet;
 
@@ -130,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);
@@ -658,6 +659,45 @@ sub log {
     return critical("log:$dom:$nam:$what",$hom);
 }
 
+# ----------------------------------------------------------- Check out an item
+
+
+sub checkout {
+    my ($symb,$tuname,$tudom,$tcrsid)=@_;
+    my $now=time;
+    my $lonhost=$perlvar{'lonHostID'};
+    my $infostr=&escape(
+                 $tuname.'&'.
+                 $tudom.'&'.
+                 $tcrsid.'&'.
+                 $symb.'&'.
+		 $now.'&'.$ENV{'REMOTE_ADDR'});
+    my $token=&reply('tmpput:'.$infostr,$lonhost);
+    if ($token=~/^error\:/) { return ''; }
+    $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;
+    $token=~tr/a-z/A-Z/;
+
+    my %infohash=('token' => $token,
+                  'checktime' => $now,
+                  'remote' => $ENV{'REMOTE_ADDR'});
+
+    unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
+       return '';
+    }    
+
+    if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
+                         &escape('Checkout '.$infostr.' - '.
+                                                 $token)) ne 'ok') {
+	return '';
+    }
+}
+
+# ------------------------------------------------------------ Check in an item
+
+sub checkin {
+    my $token=shift;
+}
+
 # --------------------------------------------- Set Expire Date for Spreadsheet
 
 sub expirespread {
@@ -895,7 +935,7 @@ sub rolesinit {
         my $author=0;
         map {
             %thesepriv=();
-            if ($_!~/^st/) { $adv=1; }
+            if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; }
             if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }
             map {
                 if ($_ ne '') {
@@ -980,28 +1020,31 @@ 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
@@ -1104,10 +1147,22 @@ sub allowed {
            }
        }
        
-       if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {
-	  my $refuri=$ENV{'HTTP_REFERER'};
-          $refuri=~s/^http\:\/\/$ENV{'request.host'}//i;
-          $refuri=&declutter($refuri);
+       if ($checkreferer) {
+	  my $refuri=$ENV{'httpref.'.$uri};
+
+            unless ($refuri) {
+                map {
+		    if ($_=~/^httpref\..*\*/) {
+			my $pattern=$_;
+                        $pattern=~s/\*/\[\^\/\]\+/g;
+                        $pattern=~s/\//\\\//g;
+                        if ($uri=~/$pattern/) {
+			    $refuri=$ENV{$_};
+                        }
+                    }
+                } keys %ENV;
+            }
+         if ($refuri) { 
           my @uriparts=split(/\//,$refuri);
           my $filename=$uriparts[$#uriparts];
           my $pathname=$refuri;
@@ -1125,6 +1180,7 @@ sub allowed {
               }
             }
           }
+        }
        }
    }
 
@@ -1432,27 +1488,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
@@ -1677,7 +1726,7 @@ sub condval {
 # --------------------------------------------------------- Value of a Variable
 
 sub EXT {
-    my $varname=shift;
+    my ($varname,$symbparm)=@_;
     unless ($varname) { return ''; }
     my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
     my $rest;
@@ -1738,8 +1787,17 @@ sub EXT {
                               $spacequalifierrest};
     } elsif ($realm eq 'resource') {
        if ($ENV{'request.course.id'}) {
+
+#	   print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
+
+
 # ----------------------------------------------------- Cascading lookup scheme
-         my $symbp=&symbread();
+         my $symbp;
+         if ($symbparm) {
+            $symbp=$symbparm;
+	 } else {
+            $symbp=&symbread();
+         }            
          my $mapp=(split(/\_\_\_/,$symbp))[0];
 
          my $symbparm=$symbp.'.'.$spacequalifierrest;
@@ -1827,6 +1885,21 @@ sub EXT {
                                          'parameter_'.$spacequalifierrest);
       if ($metadata) { return $metadata; }
 
+# ------------------------------------------------------------------ Cascade up
+
+      unless ($space eq '0') {
+          my ($part,$id)=split(/\_/,$space);
+          if ($id) {
+	      my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
+                                   $symbparm);
+              if ($partgeneral) { return $partgeneral; }
+          } else {
+              my $resourcegeneral=&EXT('resource.0.'.$qualifierrest,
+                                       $symbparm);
+              if ($resourcegeneral) { return $resourcegeneral; }
+          }
+      }
+
 # ---------------------------------------------------- Any other user namespace
     } elsif ($realm eq 'environment') {
 # ----------------------------------------------------------------- environment
@@ -1849,25 +1922,59 @@ sub metadata {
     my $filename=$uri;
     $uri=~s/\.meta$//;
     unless ($metacache{$uri.':keys'}) {
+        my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }
 	my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
         my $parser=HTML::TokeParser->new(\$metastring);
         my $token;
+        undef %metathesekeys;
         while ($token=$parser->get_token) {
            if ($token->[0] eq 'S') {
+	     if (defined($token->[2]->{'package'})) {
+	      my $package=$token->[2]->{'package'};
+	      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;
+	      }
+              map {
+		  if ($_=~/^$package\&/) {
+		      my ($pack,$name,$subp)=split(/\&/,$_);
+                      my $value=$packagetab{$_};
+		      my $part=$keyroot;
+                      $part=~s/^\_//;
+                      if ($subp eq 'display') {
+			  $value.=' [Part: '.$part.']';
+                      }
+                      my $unikey='parameter'.$keyroot.'_'.$name;
+                      $metathesekeys{$unikey}=1;
+                      $metacache{$uri.':'.$unikey.'.part'}=$part;
+                      unless 
+                       (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {
+                         $metacache{$uri.':'.$unikey.'.'.$subp}=$value;
+		      }
+                  }
+              } keys %packagetab;
+             } 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'}; 
 	      }
-              if ($metacache{$uri.':keys'}) {
-                 $metacache{$uri.':keys'}.=','.$unikey;
-              } else {
-                 $metacache{$uri.':keys'}=$unikey;
-	      }
+              $metathesekeys{$unikey}=1;
               map {
 		  $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};
               } @{$token->[3]};
@@ -1876,8 +1983,10 @@ sub metadata {
 		      ) { $metacache{$uri.':'.$unikey}=
 			      $metacache{$uri.':'.$unikey.'.default'};
 		      }
-          }
+	    }
+	 }
        }
+       $metacache{$uri.':keys'}=join(',',keys %metathesekeys);
     }
     return $metacache{$uri.':'.$what};
 }
@@ -2158,6 +2267,21 @@ 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);
+       my ($pack,$name)=split(/\&/,$short);
+       if ($plain ne '') {
+          $packagetab{$pack.'&'.$name.'&name'}=$name; 
+          $packagetab{$short}=$plain; 
+       }
+    }
+}
+
 # ------------------------------------------------------------- Read file types
 {
     my $config=Apache::File->new("$perlvar{'lonTabDir'}/filetypes.tab");