--- loncom/lonnet/perl/lonnet.pm	2000/11/27 23:10:18	1.72
+++ loncom/lonnet/perl/lonnet.pm	2000/12/29 21:52:19	1.84
@@ -45,7 +45,8 @@
 # EXT(name)          : value of a variable
 # symblist(map,hash) : Updates symbolic storage links
 # symbread([filename]) : returns the data handle (filename optional)
-# rndseed()          : returns a random seed  
+# rndseed()          : returns a random seed 
+# receipt()          : returns a receipt to be given out to users 
 # getfile(filename)  : returns the contents of filename, or a -1 if it can't
 #                      be found, replicates and subscribes to the file
 # filelocation(dir,file) : returns a farily clean absolute reference to file 
@@ -61,6 +62,8 @@
 #                      an array of IDs
 # idrget(domain,array): returns hash with IDs for usernames (name=>id,...) for
 #                       an array of names
+# 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,
@@ -77,7 +80,8 @@
 # 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 Gerd Kortemeyer
+# 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
 
 package Apache::lonnet;
 
@@ -380,7 +384,7 @@ sub idget {
           $idlist=~tr/A-Z/a-z/; 
 	  my $reply=&reply("idget:$udom:".$idlist,$tryserver);
           my @answer=();
-          if ($reply ne 'con_lost') {
+          if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {
 	      @answer=split(/\&/,$reply);
           }                    ;
           my $i;
@@ -629,9 +633,12 @@ sub restore {
 	my ($name,$value)=split(/\=/,$_);
         $returnhash{&unescape($name)}=&unescape($value);
     } split(/\&/,$answer);
-    map {
-        $returnhash{$_}=$returnhash{$returnhash{'version'}.':'.$_};
-    } split(/\:/,$returnhash{$returnhash{'version'}.':keys'});
+    my $version;
+    for ($version=1;$version<=$returnhash{'version'};$version++) {
+       map {
+          $returnhash{$_}=$returnhash{$version.':'.$_};
+       } split(/\:/,$returnhash{$version.':keys'});
+    }
     return %returnhash;
 }
 
@@ -894,7 +901,9 @@ sub allowed {
 # Course: uri itself is a course
     my $courseuri=$uri;
     $courseuri=~s/\_(\d)/\/$1/;
-    if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseuri}
+    $courseuri=~s/^([^\/])/\/$1/;
+
+    if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri}
        =~/$priv\&([^\:]*)/) {
        $thisallowed.=$1;
     }
@@ -936,7 +945,7 @@ sub allowed {
                $checkreferer=0;
            }
        }
-
+       
        if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {
 	  my $refuri=$ENV{'HTTP_REFERER'};
           $refuri=~s/^http\:\/\/$ENV{'request.host'}//i;
@@ -1147,7 +1156,7 @@ sub fileembstyle {
 
 # ------------------------------------------------------------ Description Text
 
-sub filedecription {
+sub filedescription {
     my $ending=shift;
     return $fd{$ending};
 }
@@ -1157,29 +1166,201 @@ sub filedecription {
 sub assignrole {
     my ($udom,$uname,$url,$role,$end,$start)=@_;
     my $mrole;
-    $url=declutter($url);
     if ($role =~ /^cr\//) {
-        unless ($url=~/\.course$/) { return 'invalid'; }
-	unless (allowed('ccr',$url)) { return 'refused'; }
+	unless (&allowed('ccr',$url)) { return 'refused'; }
         $mrole='cr';
     } else {
-        unless (($url=~/\.course$/) || ($url=~/\/$/)) { return 'invalid'; }
-        unless (allowed('c'+$role)) { return 'refused'; }
+        my $cwosec=$url;
+        $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
+        unless (&allowed('c'.$role,$cwosec)) { return 'refused'; }
         $mrole=$role;
     }
     my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
                 "$udom:$uname:$url".'_'."$mrole=$role";
-    if ($end) { $command.='_$end'; }
+    if ($end) { $command.='_'.$end; }
     if ($start) {
 	if ($end) { 
-           $command.='_$start'; 
+           $command.='_'.$start; 
         } else {
-           $command.='_0_$start';
+           $command.='_0_'.$start;
         }
     }
     return &reply($command,&homeserver($uname,$udom));
 }
 
+# --------------------------------------------------------------- Modify a user
+
+
+sub modifyuser {
+    my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene)=@_;
+    &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
+             $umode.', '.$first.', '.$middle.', '.
+	     $last.', '.$gene.' by '.
+             $ENV{'user.name'}.' at '.$ENV{'user.domain'});  
+    my $uhome=&homeserver($uname,$udom);
+# ----------------------------------------------------------------- Create User
+    if (($uhome eq 'no_host') && ($umode) && ($upass)) {
+        my $unhome='';
+	if ($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) {
+	    $unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
+        } else {
+            my $tryserver;
+            my $loadm=10000000;
+            foreach $tryserver (keys %libserv) {
+	       if ($hostdom{$tryserver} eq $udom) {
+                  my $answer=reply('load',$tryserver);
+                  if (($answer=~/\d+/) && ($answer<$loadm)) {
+		      $loadm=$answer;
+                      $unhome=$tryserver;
+                  }
+	       }
+	    }
+        }
+        if (($unhome eq '') || ($unhome eq 'no_host')) {
+	    return 'error: find home';
+        }
+        my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'.
+                         &escape($upass),$unhome);
+	unless ($reply eq 'ok') {
+            return 'error: '.$reply;
+        }   
+        $uhome=&homeserver($uname,$udom);
+        if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {
+	    return 'error: verify home';
+        }
+    }
+# ---------------------------------------------------------------------- Add ID
+    if ($uid) {
+       $uid=~tr/A-Z/a-z/;
+       my %uidhash=&idrget($udom,$uname);
+       if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/)) {
+	  unless ($uid eq $uidhash{$uname}) {
+	      return 'error: mismatch '.$uidhash{$uname}.' versus '.$uid;
+          }
+       } else {
+	  &idput($udom,($uname => $uid));
+       }
+    }
+# -------------------------------------------------------------- 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;
+    }
+    &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
+             $umode.', '.$first.', '.$middle.', '.
+	     $last.', '.$gene.' by '.
+             $ENV{'user.name'}.' at '.$ENV{'user.domain'});
+    return 'ok'; 
+}
+
+# -------------------------------------------------------------- Modify student
+
+sub modifystudent {
+    my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
+        $end,$start)=@_;
+    my $cid='';
+    unless ($cid=$ENV{'request.course.id'}) {
+	return 'not_in_class';
+    }
+# --------------------------------------------------------------- Make the user
+    my $reply=&modifyuser
+	($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene);
+    unless ($reply eq 'ok') { return $reply; }
+    my $uhome=&homeserver($uname,$udom);
+    if (($uhome eq '') || ($uhome eq 'no_host')) { 
+	return 'error: no such user';
+    }
+# -------------------------------------------------- Add student to course list
+    my $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'.
+	              $ENV{'course.'.$cid.'.num'}.':classlist:'.
+                      &escape($uname.':'.$udom).'='.
+                      &escape($end.':'.$start),
+	              $ENV{'course.'.$cid.'.home'});
+    unless (($reply eq 'ok') || ($reply eq 'delayed')) {
+	return 'error: '.$reply;
+    }
+# ---------------------------------------------------- Add student role to user
+    my $uurl='/'.$cid;
+    $uurl=~s/\_/\//g;
+    if ($usec) {
+	$uurl.='/'.$usec;
+    }
+    return &assignrole($udom,$uname,$uurl,'st',$end,$start);
+}
+
+# ------------------------------------------------- Write to course preferences
+
+sub writecoursepref {
+    my ($courseid,%prefs)=@_;
+    $courseid=~s/^\///;
+    $courseid=~s/\_/\//g;
+    my ($cdomain,$cnum)=split(/\//,$courseid);
+    my $chome=homeserver($cnum,$cdomain);
+    if (($chome eq '') || ($chome eq 'no_host')) { 
+	return 'error: no such course';
+    }
+    my $cstring='';
+    map {
+	$cstring.=escape($_).'='.escape($prefs{$_}).'&';
+    } keys %prefs;
+    $cstring=~s/\&$//;
+    return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome);
+}
+
+# ---------------------------------------------------------- Make/modify course
+
+sub createcourse {
+    my ($udom,$description,$url)=@_;
+    $url=&declutter($url);
+    my $cid='';
+    unless ($cid=$ENV{'request.course.id'}) {
+	return 'not_in_class';
+    }
+    unless (&allowed('ccc',$ENV{'user.domain'})) {
+        return 'refused';
+    }
+    unless ($udom eq $ENV{'user.domain'}) {
+        return 'refused';
+    }
+# ------------------------------------------------------------------- Create ID
+   my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
+       unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
+# ----------------------------------------------- Make sure that does not exist
+   my $uhome=&homeserver($uname,$udom);
+   unless (($uhome eq '') || ($uhome eq 'no_host')) {
+       $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
+        unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
+       $uhome=&homeserver($uname,$udom);       
+       unless (($uhome eq '') || ($uhome eq 'no_host')) {
+           return 'error: unable to generate unique course-ID';
+       } 
+   }
+# ------------------------------------------------------------- Make the course
+    my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
+                      $ENV{'user.home'});
+    unless ($reply eq 'ok') { return 'error: '.$reply; }
+    my $uhome=&homeserver($uname,$udom);
+    if (($uhome eq '') || ($uhome eq 'no_host')) { 
+	return 'error: no such course';
+    }
+    &writecoursepref($udom.'_'.$uname,
+                     ('description' => $description,
+                      'url'         => $url));
+    return '/'.$udom.'/'.$uname;
+}
+
 # ---------------------------------------------------------- Assign Custom Role
 
 sub assigncustomrole {
@@ -1419,26 +1600,14 @@ sub EXT {
         my $reply=&reply('get:'.
               $ENV{'course.'.$ENV{'request.course.id'}.$section.'.domain'}.':'.
               $ENV{'course.'.$ENV{'request.course.id'}.$section.'.num'}.
-              ':resourcedata:'.
- escape($seclevelr).':'.escape($seclevelm).':'.escape($seclevel).':'.
- escape($courselevelr).':'.escape($courselevelm).':'.escape($courselevel),
+	      ':resourcedata:'.
+   &escape($seclevelr).'&'.&escape($seclevelm).'&'.&escape($seclevel).'&'.
+   &escape($courselevelr).'&'.&escape($courselevelm).'&'.&escape($courselevel),
 		   $ENV{'course.'.$ENV{'request.course.id'}.$section.'.home'});
       if ($reply!~/^error\:/) {
-        map {
-           my ($name,$value)=split(/\=/,$_);
-           $resourcedata{unescape($name)}=unescape($value);  
-        } split(/\&/,$reply);
-
-       if ($resourcedata{$seclevelr}) { return $resourcedata{$seclevelr}; }
-       if ($resourcedata{$seclevelm}) { return $resourcedata{$seclevelm}; }  
-       if ($resourcedata{$seclevel}) { return $resourcedata{$seclevel}; }
-
-       if ($resourcedata{$courselevelr}) { 
-          return $resourcedata{$courselevelr}; }
-       if ($resourcedata{$courselevelm}) { 
-          return $resourcedata{$courselevelm}; }
-       if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }
-
+	  map {
+	      if ($_) { return &unescape($_); }
+          } split(/\&/,$reply);
       }
 
 # ------------------------------------------------------ third, check map parms
@@ -1454,8 +1623,12 @@ sub EXT {
      
 # --------------------------------------------- last, look in resource metadata
 
+      $spacequalifierrest=~s/\./\_/;
       my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest);
       if ($metadata) { return $metadata; }
+      $metadata=&metadata($ENV{'request.filename'},
+                                         'parameter_'.$spacequalifierrest);
+      if ($metadata) { return $metadata; }
 
 # ---------------------------------------------------- Any other user namespace
     } elsif ($realm eq 'environment') {
@@ -1474,10 +1647,13 @@ sub EXT {
 
 sub metadata {
     my ($uri,$what)=@_;
+
     $uri=&declutter($uri);
-    unless ($uri=~/\.meta$/) { $uri.='.meta'; }
+    my $filename=$uri;
+    $uri=~s/\.meta$//;
     unless ($metacache{$uri.':keys'}) {
-	my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$uri);
+        unless ($filename=~/\.meta$/) { $filename.='.meta'; }
+	my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
         my $parser=HTML::TokeParser->new(\$metastring);
         my $token;
         while ($token=$parser->get_token) {
@@ -1498,7 +1674,11 @@ sub metadata {
               map {
 		  $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};
               } @{$token->[3]};
-              $metacache{$uri.':'.$unikey}=$parser->get_text('/'.$entry);
+              unless (
+                 $metacache{$uri.':'.$unikey}=$parser->get_text('/'.$entry)
+		      ) { $metacache{$uri.':'.$unikey}=
+			      $metacache{$uri.':'.$unikey.'.default'};
+		      }
           }
        }
     }
@@ -1624,6 +1804,27 @@ sub rndseed {
                .$symbchck);
 }
 
+sub ireceipt {
+    my ($funame,$fudom,$fucourseid,$fusymb)=@_;
+    my $cuname=unpack("%32C*",$funame);
+    my $cudom=unpack("%32C*",$fudom);
+    my $cucourseid=unpack("%32C*",$fucourseid);
+    my $cusymb=unpack("%32C*",$fusymb);
+    my $cunique=unpack("%32C*",$perlvar{'lonReceipt'});
+    return unpack("%32C*",$perlvar{'lonHostID'}).'-'.
+           ($cunique%$cuname+
+            $cunique%$cudom+
+            $cusymb%$cuname+
+            $cusymb%$cudom+
+            $cucourseid%$cuname+
+            $cucourseid%$cudom);
+}
+
+sub receipt {
+    return &ireceipt($ENV{'user.name'},$ENV{'user.domain'},
+                     $ENV{'request.course.id'},&symbread());
+}
+  
 # ------------------------------------------------------------ Serves up a file
 # returns either the contents of the file or a -1
 sub getfile {