version 1.84, 2000/12/29 21:52:19
|
version 1.94, 2001/01/10 22:55:52
|
Line 82
|
Line 82
|
# 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,12/29 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 Gerd Kortemeyer |
|
|
package Apache::lonnet; |
package Apache::lonnet; |
|
|
Line 95 use IO::Socket;
|
Line 99 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 182 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 241 sub appenv {
|
Line 251 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: '.$!; |
|
} |
@oldenv=<$fh>; |
@oldenv=<$fh>; |
|
$fh->close(); |
} |
} |
for (my $i=0; $i<=$#oldenv; $i++) { |
for (my $i=0; $i<=$#oldenv; $i++) { |
chomp($oldenv[$i]); |
chomp($oldenv[$i]); |
Line 258 sub appenv {
|
Line 275 sub appenv {
|
return 'error'; |
return 'error'; |
} |
} |
my $newname; |
my $newname; |
|
unless (flock($fh,LOCK_EX)) { |
|
&logthis("<font color=blue>WARNING: ". |
|
'Could not obtain exclusive lock in appenv: '.$!); |
|
$fh->close(); |
|
return 'error: '.$!; |
|
} |
foreach $newname (keys %newenv) { |
foreach $newname (keys %newenv) { |
print $fh "$newname=$newenv{$newname}\n"; |
print $fh "$newname=$newenv{$newname}\n"; |
} |
} |
|
$fh->close(); |
} |
} |
return 'ok'; |
return 'ok'; |
} |
} |
Line 280 sub delenv {
|
Line 304 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 1003 sub allowed {
|
Line 1041 sub allowed {
|
if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) { |
if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) { |
my $courseid=$2; |
my $courseid=$2; |
my $roleid=$1.'.'.$2; |
my $roleid=$1.'.'.$2; |
|
$courseid=~s/^\///; |
my $expiretime=600; |
my $expiretime=600; |
if ($ENV{'request.role'} eq $roleid) { |
if ($ENV{'request.role'} eq $roleid) { |
$expiretime=120; |
$expiretime=120; |
Line 1325 sub createcourse {
|
Line 1364 sub createcourse {
|
my ($udom,$description,$url)=@_; |
my ($udom,$description,$url)=@_; |
$url=&declutter($url); |
$url=&declutter($url); |
my $cid=''; |
my $cid=''; |
unless ($cid=$ENV{'request.course.id'}) { |
|
return 'not_in_class'; |
|
} |
|
unless (&allowed('ccc',$ENV{'user.domain'})) { |
unless (&allowed('ccc',$ENV{'user.domain'})) { |
return 'refused'; |
return 'refused'; |
} |
} |
Line 1583 sub EXT {
|
Line 1619 sub EXT {
|
# ----------------------------------------------------------- first, check user |
# ----------------------------------------------------------- first, check user |
my %resourcedata=get('resourcedata', |
my %resourcedata=get('resourcedata', |
($courselevelr,$courselevelm,$courselevel)); |
($courselevelr,$courselevelm,$courselevel)); |
if ($resourcedata{$courselevelr}!~/^error\:/) { |
if (($resourcedata{$courselevelr}!~/^error\:/) && |
|
($resourcedata{$courselevelr}!~/^con_lost/)) { |
|
|
if ($resourcedata{$courselevelr}) { |
if ($resourcedata{$courselevelr}) { |
return $resourcedata{$courselevelr}; } |
return $resourcedata{$courselevelr}; } |
Line 1591 sub EXT {
|
Line 1628 sub EXT {
|
return $resourcedata{$courselevelm}; } |
return $resourcedata{$courselevelm}; } |
if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; } |
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 |
# -------------------------------------------------------- second, check course |
my $section=''; |
my $section=''; |
Line 1609 sub EXT {
|
Line 1653 sub EXT {
|
if ($_) { return &unescape($_); } |
if ($_) { return &unescape($_); } |
} split(/\&/,$reply); |
} split(/\&/,$reply); |
} |
} |
|
if (($reply=~/^con_lost/) || ($reply=~/^error\:/)) { |
|
&logthis("<font color=blue>WARNING:". |
|
" Getting ".$reply." asking for ".$varname." from ". |
|
$ENV{'course.'.$ENV{'request.course.id'}.$section.'.home'}. |
|
"</font>"); |
|
} |
# ------------------------------------------------------ third, check map parms |
# ------------------------------------------------------ third, check map parms |
my %parmhash=(); |
my %parmhash=(); |
my $thisparm=''; |
my $thisparm=''; |