--- loncom/lonnet/perl/lonnet.pm	2000/12/28 19:57:30	1.82
+++ loncom/lonnet/perl/lonnet.pm	2001/03/15 14:04:32	1.106
@@ -13,7 +13,7 @@
 #                      1: user needs to choose course
 #                      2: browse allowed
 # definerole(rolename,sys,dom,cou) : define a custom role rolename
-#                      set priviledges in format of lonTabs/roles.tab for
+#                      set privileges in format of lonTabs/roles.tab for
 #                      system, domain and course level, 
 # assignrole(udom,uname,url,role,end,start) : give a role to a user for the
 #                      level given by url. Optional start and end dates
@@ -81,7 +81,14 @@
 # 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 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
+# 02/27/01 Scott Harrison
+# 3/2 Gerd Kortemeyer
+# 3/15 Scott Harrison
 
 package Apache::lonnet;
 
@@ -95,6 +102,7 @@ use IO::Socket;
 use GDBM_File;
 use Apache::Constants qw(:common :http);
 use HTML::TokeParser;
+use Fcntl qw(:flock);
 
 # --------------------------------------------------------------------- Logging
 
@@ -177,6 +185,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 +248,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 +287,10 @@ sub appenv {
      foreach $newname (keys %newenv) {
 	 print $fh "$newname=$newenv{$newname}\n";
      }
+     $fh->close();
     }
+
+    $lockfh->close();
     return 'ok';
 }
 # ----------------------------------------------------- Delete from Environment
@@ -280,16 +309,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 +696,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,
@@ -680,7 +722,7 @@ sub coursedescription {
     return ();
 }
 
-# -------------------------------------------------------- Get user priviledges
+# -------------------------------------------------------- Get user privileges
 
 sub rolesinit {
     my ($domain,$username,$authhost)=@_;
@@ -754,12 +796,12 @@ sub rolesinit {
             %thesepriv=();
             map {
                 if ($_ ne '') {
-		    my ($priviledge,$restrictions)=split(/&/,$_);
+		    my ($privilege,$restrictions)=split(/&/,$_);
                     if ($restrictions eq '') {
-			$thesepriv{$priviledge}='F';
+			$thesepriv{$privilege}='F';
                     } else {
-                        if ($thesepriv{$priviledge} ne 'F') {
-			    $thesepriv{$priviledge}.=$restrictions;
+                        if ($thesepriv{$privilege} ne 'F') {
+			    $thesepriv{$privilege}.=$restrictions;
                         }
                     }
                 }
@@ -869,7 +911,7 @@ sub eget {
    return %returnhash;
 }
 
-# ------------------------------------------------- Check for a user priviledge
+# ------------------------------------------------- Check for a user privilege
 
 sub allowed {
     my ($priv,$uri)=@_;
@@ -901,8 +943,9 @@ sub allowed {
 # Course: uri itself is a course
     my $courseuri=$uri;
     $courseuri=~s/\_(\d)/\/$1/;
+    $courseuri=~s/^([^\/])/\/$1/;
 
-    if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseuri}
+    if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri}
        =~/$priv\&([^\:]*)/) {
        $thisallowed.=$1;
     }
@@ -919,7 +962,7 @@ sub allowed {
 	return $thisallowed;
     }
 #
-# Gathered so far: system, domain and course wide priviledges
+# Gathered so far: system, domain and course wide privileges
 #
 # Course: See if uri or referer is an individual resource that is part of 
 # the course
@@ -944,7 +987,7 @@ sub allowed {
                $checkreferer=0;
            }
        }
-
+       
        if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {
 	  my $refuri=$ENV{'HTTP_REFERER'};
           $refuri=~s/^http\:\/\/$ENV{'request.host'}//i;
@@ -970,7 +1013,7 @@ sub allowed {
    }
 
 #
-# Gathered now: all priviledges that could apply, and condition number
+# Gathered now: all privileges that could apply, and condition number
 # 
 #
 # Full or no access?
@@ -1002,6 +1045,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;
@@ -1139,6 +1183,13 @@ sub definerole {
   }
 }
 
+# ---------------- Make a metadata query against the network of library servers
+
+sub metadata_query {
+    my ($query)=@_;
+    my $reply=&reply("querysend:$query",'msul3');
+}
+
 # ------------------------------------------------------------------ Plain Text
 
 sub plaintext {
@@ -1165,14 +1216,23 @@ sub filedescription {
 sub assignrole {
     my ($udom,$uname,$url,$role,$end,$start)=@_;
     my $mrole;
-    $url=declutter($url);
     if ($role =~ /^cr\//) {
-	unless (&allowed('ccr',$url)) { return 'refused'; }
+	unless (&allowed('ccr',$url)) {
+           &logthis('Refused custom assignrole: '.
+             $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
+		    $ENV{'user.name'}.' at '.$ENV{'user.domain'});
+           return 'refused'; 
+        }
         $mrole='cr';
     } else {
         my $cwosec=$url;
-        $cwosec=~s/^(\w+)\/(\w+)\/.*/$1\/$2/;
-        unless (&allowed('c'.$role,$cwosec)) { return 'refused'; }
+        $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
+        unless (&allowed('c'.$role,$cwosec)) { 
+           &logthis('Refused assignrole: '.
+             $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
+		    $ENV{'user.name'}.' at '.$ENV{'user.domain'});
+           return 'refused'; 
+        }
         $mrole=$role;
     }
     my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
@@ -1292,7 +1352,7 @@ sub modifystudent {
 	return 'error: '.$reply;
     }
 # ---------------------------------------------------- Add student role to user
-    my $uurl=$cid;
+    my $uurl='/'.$cid;
     $uurl=~s/\_/\//g;
     if ($usec) {
 	$uurl.='/'.$usec;
@@ -1300,6 +1360,64 @@ sub modifystudent {
     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 {
@@ -1518,11 +1636,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}; }
@@ -1530,25 +1648,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'}.
+              $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'}.$section.'.home'});
+		   $ENV{'course.'.$ENV{'request.course.id'}.'.home'});
       if ($reply!~/^error\:/) {
 	  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='';       
@@ -1731,16 +1863,20 @@ sub numval {
 sub rndseed {
     my $symb;
     unless ($symb=&symbread()) { return time; }
-    my $symbchck=unpack("%32C*",$symb);
-    my $symbseed=numval($symb)%$symbchck;
-    my $namechck=unpack("%32C*",$ENV{'user.name'});
-    my $nameseed=numval($ENV{'user.name'})%$namechck;
-    return int( $symbseed
-	       .$nameseed
-               .unpack("%32C*",$ENV{'user.domain'})
-               .unpack("%32C*",$ENV{'request.course.id'})
-               .$namechck
-               .$symbchck);
+    { 
+      use integer;
+      my $symbchck=unpack("%32C*",$symb) << 27;
+      my $symbseed=numval($symb) << 22;
+      my $namechck=unpack("%32C*",$ENV{'user.name'}) << 17;
+      my $nameseed=numval($ENV{'user.name'}) << 12;
+      my $domainseed=unpack("%32C*",$ENV{'user.domain'}) << 7;
+      my $courseseed=unpack("%32C*",$ENV{'request.course.id'});
+      my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
+      #uncommenting these lines can break things!
+      #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
+      #&Apache::lonxml::debug("rndseed :$num:$symb");
+      return $num;
+    }
 }
 
 sub ireceipt {