--- loncom/lonnet/perl/lonnet.pm	2000/12/06 20:32:52	1.77
+++ loncom/lonnet/perl/lonnet.pm	2001/01/11 11:11:27	1.97
@@ -81,7 +81,11 @@
 # 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 Gerd Kortemeyer
+# 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
 
 package Apache::lonnet;
 
@@ -95,6 +99,7 @@ use IO::Socket;
 use GDBM_File;
 use Apache::Constants qw(:common :http);
 use HTML::TokeParser;
+use Fcntl qw(:flock);
 
 # --------------------------------------------------------------------- Logging
 
@@ -177,6 +182,11 @@ sub reconlonc {
 
 sub critical {
     my ($cmd,$server)=@_;
+    unless ($hostname{$server}) {
+        &logthis("<font color=blue>WARNING:".
+               " Critical message to unknown server ($server)</font>");
+        return 'no_such_host';
+    }
     my $answer=reply($cmd,$server);
     if ($answer eq 'con_lost') {
         my $pingreply=reply('ping',$server);
@@ -235,13 +245,26 @@ sub appenv {
             $ENV{$_}=$newenv{$_};
         }
     } keys %newenv;
+
+    my $lockfh;
+    unless ($lockfh=Apache::File->new("$ENV{'user.environment'}")) {
+       return 'error: '.$!;
+    }
+    unless (flock($lockfh,LOCK_EX)) {
+         &logthis("<font color=blue>WARNING: ".
+                  'Could not obtain exclusive lock in appenv: '.$!);
+         $lockfh->close();
+         return 'error: '.$!;
+    }
+
     my @oldenv;
     {
      my $fh;
      unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
-	return 'error';
+	return 'error: '.$!;
      }
      @oldenv=<$fh>;
+     $fh->close();
     }
     for (my $i=0; $i<=$#oldenv; $i++) {
         chomp($oldenv[$i]);
@@ -261,7 +284,10 @@ sub appenv {
      foreach $newname (keys %newenv) {
 	 print $fh "$newname=$newenv{$newname}\n";
      }
+     $fh->close();
     }
+
+    $lockfh->close();
     return 'ok';
 }
 # ----------------------------------------------------- Delete from Environment
@@ -280,16 +306,30 @@ sub delenv {
      unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
 	return 'error';
      }
+     unless (flock($fh,LOCK_SH)) {
+         &logthis("<font color=blue>WARNING: ".
+                  'Could not obtain shared lock in delenv: '.$!);
+         $fh->close();
+         return 'error: '.$!;
+     }
      @oldenv=<$fh>;
+     $fh->close();
     }
     {
      my $fh;
      unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) {
 	return 'error';
      }
+     unless (flock($fh,LOCK_EX)) {
+         &logthis("<font color=blue>WARNING: ".
+                  'Could not obtain exclusive lock in delenv: '.$!);
+         $fh->close();
+         return 'error: '.$!;
+     }
      map {
 	 unless ($_=~/^$delthis/) { print $fh $_; }
      } @oldenv;
+     $fh->close();
     }
     return 'ok';
 }
@@ -653,8 +693,7 @@ sub coursedescription {
     if ($chome ne 'no_host') {
        my $rep=reply("dump:$cdomain:$cnum:environment",$chome);
        if ($rep ne 'con_lost') {
-           my $normalid=$courseid;
-           $normalid=~s/\//\_/g;
+           my $normalid=$cdomain.'_'.$cnum;
            my %envhash=();
            my %returnhash=('home'   => $chome, 
                            'domain' => $cdomain,
@@ -901,7 +940,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;
     }
@@ -943,7 +984,7 @@ sub allowed {
                $checkreferer=0;
            }
        }
-
+       
        if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {
 	  my $refuri=$ENV{'HTTP_REFERER'};
           $refuri=~s/^http\:\/\/$ENV{'request.host'}//i;
@@ -1001,6 +1042,7 @@ sub allowed {
            if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
                my $courseid=$2;
                my $roleid=$1.'.'.$2;
+               $courseid=~s/^\///;
                my $expiretime=600;
                if ($ENV{'request.role'} eq $roleid) {
 		  $expiretime=120;
@@ -1164,29 +1206,198 @@ sub filedescription {
 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 (&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 {
@@ -1405,11 +1616,11 @@ sub EXT {
        my $courselevelm=
             $ENV{'request.course.id'}.'.'.$mapparm;
 
-
 # ----------------------------------------------------------- first, check user
       my %resourcedata=get('resourcedata',
                            ($courselevelr,$courselevelm,$courselevel));
-      if ($resourcedata{$courselevelr}!~/^error\:/) {
+      if (($resourcedata{$courselevelr}!~/^error\:/) &&
+          ($resourcedata{$courselevelr}!~/^con_lost/)) {
 
        if ($resourcedata{$courselevelr}) { 
           return $resourcedata{$courselevelr}; }
@@ -1417,37 +1628,39 @@ sub EXT {
           return $resourcedata{$courselevelm}; }
        if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }
 
+      } else {
+	  if ($resourcedata{$courselevelr}!~/No such file/) {
+	    &logthis("<font color=blue>WARNING:".
+		   " Trying to get resource data for ".$ENV{'user.name'}." at "
+                   .$ENV{'user.domain'}.": ".$resourcedata{$courselevelr}.
+                 "</font>");
+	  }
       }
+
 # -------------------------------------------------------- second, check course
-        my $section='';
-        if ($ENV{'request.course.sec'}) {
-	    $section='_'.$ENV{'request.course.sec'};
-        }
+
         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),
-		   $ENV{'course.'.$ENV{'request.course.id'}.$section.'.home'});
+              $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.
+              $ENV{'course.'.$ENV{'request.course.id'}.'.num'}.
+	      ':resourcedata:'.
+   &escape($seclevelr).'&'.&escape($seclevelm).'&'.&escape($seclevel).'&'.
+   &escape($courselevelr).'&'.&escape($courselevelm).'&'.&escape($courselevel),
+		   $ENV{'course.'.$ENV{'request.course.id'}.'.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);
+      }
+      if (($reply=~/^con_lost/) || ($reply=~/^error\:/)) {
+	  &logthis("<font color=blue>WARNING:".
+                " Getting ".$reply." asking for ".$varname." for ".
+                $ENV{'course.'.$ENV{'request.course.id'}.'.num'}.
+                ' at '.
+                $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.
+                ' from '.
+                $ENV{'course.'.$ENV{'request.course.id'}.'.home'}.
+                 "</font>");
       }
-
 # ------------------------------------------------------ third, check map parms
        my %parmhash=();
        my $thisparm='';       
@@ -1461,8 +1674,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') {
@@ -1481,6 +1698,7 @@ sub EXT {
 
 sub metadata {
     my ($uri,$what)=@_;
+
     $uri=&declutter($uri);
     my $filename=$uri;
     $uri=~s/\.meta$//;
@@ -1507,7 +1725,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'};
+		      }
           }
        }
     }