--- loncom/lonnet/perl/lonnet.pm	2000/12/14 21:44:06	1.81
+++ loncom/lonnet/perl/lonnet.pm	2001/01/09 23:04:15	1.92
@@ -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,12/12,12/13,12/14 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 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);
@@ -241,7 +251,14 @@ sub appenv {
      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 appenv: '.$!);
+         $fh->close();
+         return 'error: '.$!;
+     }
      @oldenv=<$fh>;
+     $fh->close();
     }
     for (my $i=0; $i<=$#oldenv; $i++) {
         chomp($oldenv[$i]);
@@ -258,9 +275,16 @@ sub appenv {
 	return 'error';
      }
      my $newname;
-     foreach $newname (keys %newenv) {
+     unless (flock($fh,LOCK_EX)) {
+         &logthis("<font color=blue>WARNING: ".
+                  'Could not obtain exclusive lock in appenv: '.$!);
+         $fh->close();
+         return 'error: '.$!;
+     }
+     foreach $newname (sort keys %newenv) {
 	 print $fh "$newname=$newenv{$newname}\n";
      }
+     $fh->close();
     }
     return 'ok';
 }
@@ -280,16 +304,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';
 }
@@ -901,8 +939,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;
     }
@@ -944,7 +983,7 @@ sub allowed {
                $checkreferer=0;
            }
        }
-
+       
        if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {
 	  my $refuri=$ENV{'HTTP_REFERER'};
           $refuri=~s/^http\:\/\/$ENV{'request.host'}//i;
@@ -1002,6 +1041,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;
@@ -1165,12 +1205,13 @@ 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'; }
         $mrole='cr';
     } else {
-        unless (&allowed('c'.$role,$url)) { 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'}:".
@@ -1290,7 +1331,7 @@ sub modifystudent {
 	return 'error: '.$reply;
     }
 # ---------------------------------------------------- Add student role to user
-    my $uurl=$cid;
+    my $uurl='/'.$cid;
     $uurl=~s/\_/\//g;
     if ($usec) {
 	$uurl.='/'.$usec;
@@ -1298,6 +1339,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 {