version 1.82, 2000/12/28 19:57:30
|
version 1.91, 2001/01/09 22:27:07
|
Line 81
|
Line 81
|
# 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/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, |
# 10/30,10/31, |
# 11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25,11/27, |
# 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 |
|
|
package Apache::lonnet; |
package Apache::lonnet; |
|
|
Line 95 use IO::Socket;
|
Line 97 use IO::Socket;
|
use GDBM_File; |
use GDBM_File; |
use Apache::Constants qw(:common :http); |
use Apache::Constants qw(:common :http); |
use HTML::TokeParser; |
use HTML::TokeParser; |
|
use Fcntl qw(:flock); |
|
|
# --------------------------------------------------------------------- Logging |
# --------------------------------------------------------------------- Logging |
|
|
Line 177 sub reconlonc {
|
Line 180 sub reconlonc {
|
|
|
sub critical { |
sub critical { |
my ($cmd,$server)=@_; |
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); |
my $answer=reply($cmd,$server); |
if ($answer eq 'con_lost') { |
if ($answer eq 'con_lost') { |
my $pingreply=reply('ping',$server); |
my $pingreply=reply('ping',$server); |
Line 226 sub critical {
|
Line 234 sub critical {
|
|
|
sub appenv { |
sub appenv { |
my %newenv=@_; |
my %newenv=@_; |
|
my ($in,$out); |
map { |
map { |
if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) { |
if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) { |
&logthis("<font color=blue>WARNING: ". |
&logthis("<font color=blue>WARNING: ". |
Line 241 sub appenv {
|
Line 250 sub appenv {
|
unless ($fh=Apache::File->new("$ENV{'user.environment'}")) { |
unless ($fh=Apache::File->new("$ENV{'user.environment'}")) { |
return 'error'; |
return 'error'; |
} |
} |
|
unless (flock($fh,LOCK_SH)) { |
|
&logthis("<font color=blue>WARNING: ". |
|
'Could not obtain shared lock in appenv: '.$!); |
|
$fh->close(); |
|
return 'error: '.$!; |
|
} |
|
&logthis("<font color=green>appenv LOCK_SH gotten"); |
@oldenv=<$fh>; |
@oldenv=<$fh>; |
|
$in=$#oldenv+1; |
|
&logthis("<font color=green>appenv LOCK_SH to be closed"); |
|
$fh->close(); |
} |
} |
|
&logthis("<font color=green>Number of elements read appenv: ".$in."from".join(" ",caller)); |
for (my $i=0; $i<=$#oldenv; $i++) { |
for (my $i=0; $i<=$#oldenv; $i++) { |
chomp($oldenv[$i]); |
chomp($oldenv[$i]); |
if ($oldenv[$i] ne '') { |
if ($oldenv[$i] ne '') { |
Line 258 sub appenv {
|
Line 278 sub appenv {
|
return 'error'; |
return 'error'; |
} |
} |
my $newname; |
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: '.$!; |
|
} |
|
&logthis("<font color=green>appenv LOCK_EX gotten"); |
|
$out=0; |
|
foreach $newname (sort keys %newenv) { |
print $fh "$newname=$newenv{$newname}\n"; |
print $fh "$newname=$newenv{$newname}\n"; |
|
$out++; |
} |
} |
|
&logthis("<font color=green>appenv LOCK_EX to be closed"); |
|
$fh->close(); |
} |
} |
|
&logthis("<font color=green>Number of elements read appenv: ".$in." number out:".$out."from".join(" ",caller)); |
return 'ok'; |
return 'ok'; |
} |
} |
# ----------------------------------------------------- Delete from Environment |
# ----------------------------------------------------- Delete from Environment |
Line 280 sub delenv {
|
Line 312 sub delenv {
|
unless ($fh=Apache::File->new("$ENV{'user.environment'}")) { |
unless ($fh=Apache::File->new("$ENV{'user.environment'}")) { |
return 'error'; |
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>; |
@oldenv=<$fh>; |
|
$fh->close(); |
} |
} |
{ |
{ |
my $fh; |
my $fh; |
unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) { |
unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) { |
return 'error'; |
return 'error'; |
} |
} |
|
unless (flock($fh,LOCK_EX)) { |
|
&logthis("<font color=blue>WARNING: ". |
|
'Could not obtain exclusive lock in delenv: '.$!); |
|
$fh->close(); |
|
return 'error: '.$!; |
|
} |
map { |
map { |
unless ($_=~/^$delthis/) { print $fh $_; } |
unless ($_=~/^$delthis/) { print $fh $_; } |
} @oldenv; |
} @oldenv; |
|
$fh->close(); |
} |
} |
return 'ok'; |
return 'ok'; |
} |
} |
Line 901 sub allowed {
|
Line 947 sub allowed {
|
# Course: uri itself is a course |
# Course: uri itself is a course |
my $courseuri=$uri; |
my $courseuri=$uri; |
$courseuri=~s/\_(\d)/\/$1/; |
$courseuri=~s/\_(\d)/\/$1/; |
|
$courseuri=~s/^([^\/])/\/$1/; |
|
|
if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseuri} |
if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri} |
=~/$priv\&([^\:]*)/) { |
=~/$priv\&([^\:]*)/) { |
$thisallowed.=$1; |
$thisallowed.=$1; |
} |
} |
Line 944 sub allowed {
|
Line 991 sub allowed {
|
$checkreferer=0; |
$checkreferer=0; |
} |
} |
} |
} |
|
|
if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) { |
if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) { |
my $refuri=$ENV{'HTTP_REFERER'}; |
my $refuri=$ENV{'HTTP_REFERER'}; |
$refuri=~s/^http\:\/\/$ENV{'request.host'}//i; |
$refuri=~s/^http\:\/\/$ENV{'request.host'}//i; |
Line 1165 sub filedescription {
|
Line 1212 sub filedescription {
|
sub assignrole { |
sub assignrole { |
my ($udom,$uname,$url,$role,$end,$start)=@_; |
my ($udom,$uname,$url,$role,$end,$start)=@_; |
my $mrole; |
my $mrole; |
$url=declutter($url); |
|
if ($role =~ /^cr\//) { |
if ($role =~ /^cr\//) { |
unless (&allowed('ccr',$url)) { return 'refused'; } |
unless (&allowed('ccr',$url)) { return 'refused'; } |
$mrole='cr'; |
$mrole='cr'; |
} else { |
} else { |
my $cwosec=$url; |
my $cwosec=$url; |
$cwosec=~s/^(\w+)\/(\w+)\/.*/$1\/$2/; |
$cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/; |
unless (&allowed('c'.$role,$cwosec)) { return 'refused'; } |
unless (&allowed('c'.$role,$cwosec)) { return 'refused'; } |
$mrole=$role; |
$mrole=$role; |
} |
} |
Line 1292 sub modifystudent {
|
Line 1338 sub modifystudent {
|
return 'error: '.$reply; |
return 'error: '.$reply; |
} |
} |
# ---------------------------------------------------- Add student role to user |
# ---------------------------------------------------- Add student role to user |
my $uurl=$cid; |
my $uurl='/'.$cid; |
$uurl=~s/\_/\//g; |
$uurl=~s/\_/\//g; |
if ($usec) { |
if ($usec) { |
$uurl.='/'.$usec; |
$uurl.='/'.$usec; |
Line 1300 sub modifystudent {
|
Line 1346 sub modifystudent {
|
return &assignrole($udom,$uname,$uurl,'st',$end,$start); |
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 |
# ---------------------------------------------------------- Assign Custom Role |
|
|
sub assigncustomrole { |
sub assigncustomrole { |