--- loncom/lonnet/perl/lonnet.pm 2000/12/29 19:28:19 1.83
+++ loncom/lonnet/perl/lonnet.pm 2001/01/09 22:12:28 1.90
@@ -82,6 +82,8 @@
# 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,12/29 Gerd Kortemeyer
+# 05/01/01 Guy Albertelli
+# 05/01,06/01,09/01 Gerd Kortemeyer
package Apache::lonnet;
@@ -95,6 +97,7 @@ use IO::Socket;
use GDBM_File;
use Apache::Constants qw(:common :http);
use HTML::TokeParser;
+use Fcntl qw(:flock);
# --------------------------------------------------------------------- Logging
@@ -177,6 +180,11 @@ sub reconlonc {
sub critical {
my ($cmd,$server)=@_;
+ unless ($hostname{$server}) {
+ &logthis("WARNING:".
+ " Critical message to unknown server ($server)");
+ return 'no_such_host';
+ }
my $answer=reply($cmd,$server);
if ($answer eq 'con_lost') {
my $pingreply=reply('ping',$server);
@@ -226,6 +234,7 @@ sub critical {
sub appenv {
my %newenv=@_;
+ my ($in,$out);
map {
if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {
&logthis("WARNING: ".
@@ -241,8 +250,17 @@ sub appenv {
unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
return 'error';
}
+ unless (flock($fh,LOCK_SH)) {
+ &logthis("WARNING: ".
+ 'Could not obtain shared lock in appenv: '.$!);
+ $fh->close();
+ return 'error: '.$!;
+ }
@oldenv=<$fh>;
+ $in=$#oldenv+1;
+ $fh->close();
}
+ &logthis("Number of elements read appenv: ".$in."from".join(" ",caller));
for (my $i=0; $i<=$#oldenv; $i++) {
chomp($oldenv[$i]);
if ($oldenv[$i] ne '') {
@@ -258,10 +276,20 @@ sub appenv {
return 'error';
}
my $newname;
- foreach $newname (keys %newenv) {
+ unless (flock($fh,LOCK_EX)) {
+ &logthis("WARNING: ".
+ 'Could not obtain exclusive lock in appenv: '.$!);
+ $fh->close();
+ return 'error: '.$!;
+ }
+ $out=0;
+ foreach $newname (sort keys %newenv) {
print $fh "$newname=$newenv{$newname}\n";
+ $out++;
}
+ $fh->close();
}
+ &logthis("Number of elements read appenv: ".$in." number out:".$out."from".join(" ",caller));
return 'ok';
}
# ----------------------------------------------------- Delete from Environment
@@ -280,16 +308,30 @@ sub delenv {
unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
return 'error';
}
+ unless (flock($fh,LOCK_SH)) {
+ &logthis("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("WARNING: ".
+ 'Could not obtain exclusive lock in delenv: '.$!);
+ $fh->close();
+ return 'error: '.$!;
+ }
map {
unless ($_=~/^$delthis/) { print $fh $_; }
} @oldenv;
+ $fh->close();
}
return 'ok';
}
@@ -1300,6 +1342,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 {