version 1.669, 2005/10/27 19:47:39
|
version 1.676, 2005/11/15 18:30:41
|
Line 49 use Apache::Constants qw(:common :http);
|
Line 49 use Apache::Constants qw(:common :http);
|
use HTML::LCParser; |
use HTML::LCParser; |
use HTML::Parser; |
use HTML::Parser; |
use Fcntl qw(:flock); |
use Fcntl qw(:flock); |
use Apache::lonlocal; |
|
use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze); |
use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze); |
use Time::HiRes qw( gettimeofday tv_interval ); |
use Time::HiRes qw( gettimeofday tv_interval ); |
use Cache::Memcached; |
use Cache::Memcached; |
|
use Digest::MD5; |
|
|
my $readit; |
my $readit; |
my $max_connection_retries = 10; # Or some such value. |
my $max_connection_retries = 10; # Or some such value. |
|
|
Line 166 sub reply {
|
Line 167 sub reply {
|
unless (defined($hostname{$server})) { return 'no_such_host'; } |
unless (defined($hostname{$server})) { return 'no_such_host'; } |
my $answer=subreply($cmd,$server); |
my $answer=subreply($cmd,$server); |
if (($answer=~/^refused/) || ($answer=~/^rejected/)) { |
if (($answer=~/^refused/) || ($answer=~/^rejected/)) { |
&logthis("<font color=blue>WARNING:". |
&logthis("<font color=\"blue\">WARNING:". |
" $cmd to $server returned $answer</font>"); |
" $cmd to $server returned $answer</font>"); |
} |
} |
return $answer; |
return $answer; |
Line 190 sub reconlonc {
|
Line 191 sub reconlonc {
|
sleep 5; |
sleep 5; |
if (-e "$peerfile") { return; } |
if (-e "$peerfile") { return; } |
&logthis( |
&logthis( |
"<font color=blue>WARNING: $peerfile still not there, giving up</font>"); |
"<font color=\"blue\">WARNING: $peerfile still not there, giving up</font>"); |
} else { |
} else { |
&logthis( |
&logthis( |
"<font color=blue>WARNING:". |
"<font color=\"blue\">WARNING:". |
" lonc at pid $loncpid not responding, giving up</font>"); |
" lonc at pid $loncpid not responding, giving up</font>"); |
} |
} |
} else { |
} else { |
&logthis('<font color=blue>WARNING: lonc not running, giving up</font>'); |
&logthis('<font color="blue">WARNING: lonc not running, giving up</font>'); |
} |
} |
} |
} |
|
|
Line 206 sub reconlonc {
|
Line 207 sub reconlonc {
|
sub critical { |
sub critical { |
my ($cmd,$server)=@_; |
my ($cmd,$server)=@_; |
unless ($hostname{$server}) { |
unless ($hostname{$server}) { |
&logthis("<font color=blue>WARNING:". |
&logthis("<font color=\"blue\">WARNING:". |
" Critical message to unknown server ($server)</font>"); |
" Critical message to unknown server ($server)</font>"); |
return 'no_such_host'; |
return 'no_such_host'; |
} |
} |
Line 240 sub critical {
|
Line 241 sub critical {
|
} |
} |
chomp($wcmd); |
chomp($wcmd); |
if ($wcmd eq $cmd) { |
if ($wcmd eq $cmd) { |
&logthis("<font color=blue>WARNING: ". |
&logthis("<font color=\"blue\">WARNING: ". |
"Connection buffer $dfilename: $cmd</font>"); |
"Connection buffer $dfilename: $cmd</font>"); |
&logperm("D:$server:$cmd"); |
&logperm("D:$server:$cmd"); |
return 'con_delayed'; |
return 'con_delayed'; |
} else { |
} else { |
&logthis("<font color=red>CRITICAL:" |
&logthis("<font color=\"red\">CRITICAL:" |
." Critical connection failed: $server $cmd</font>"); |
." Critical connection failed: $server $cmd</font>"); |
&logperm("F:$server:$cmd"); |
&logperm("F:$server:$cmd"); |
return 'con_failed'; |
return 'con_failed'; |
Line 290 sub appenv {
|
Line 291 sub appenv {
|
my %newenv=@_; |
my %newenv=@_; |
foreach (keys %newenv) { |
foreach (keys %newenv) { |
if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) { |
if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) { |
&logthis("<font color=blue>WARNING: ". |
&logthis("<font color=\"blue\">WARNING: ". |
"Attempt to modify environment ".$_." to ".$newenv{$_} |
"Attempt to modify environment ".$_." to ".$newenv{$_} |
.'</font>'); |
.'</font>'); |
delete($newenv{$_}); |
delete($newenv{$_}); |
Line 304 sub appenv {
|
Line 305 sub appenv {
|
return 'error: '.$!; |
return 'error: '.$!; |
} |
} |
unless (flock($lockfh,LOCK_EX)) { |
unless (flock($lockfh,LOCK_EX)) { |
&logthis("<font color=blue>WARNING: ". |
&logthis("<font color=\"blue\">WARNING: ". |
'Could not obtain exclusive lock in appenv: '.$!); |
'Could not obtain exclusive lock in appenv: '.$!); |
close($lockfh); |
close($lockfh); |
return 'error: '.$!; |
return 'error: '.$!; |
Line 349 sub delenv {
|
Line 350 sub delenv {
|
my $delthis=shift; |
my $delthis=shift; |
my %newenv=(); |
my %newenv=(); |
if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { |
if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { |
&logthis("<font color=blue>WARNING: ". |
&logthis("<font color=\"blue\">WARNING: ". |
"Attempt to delete from environment ".$delthis); |
"Attempt to delete from environment ".$delthis); |
return 'error'; |
return 'error'; |
} |
} |
Line 360 sub delenv {
|
Line 361 sub delenv {
|
return 'error'; |
return 'error'; |
} |
} |
unless (flock($fh,LOCK_SH)) { |
unless (flock($fh,LOCK_SH)) { |
&logthis("<font color=blue>WARNING: ". |
&logthis("<font color=\"blue\">WARNING: ". |
'Could not obtain shared lock in delenv: '.$!); |
'Could not obtain shared lock in delenv: '.$!); |
close($fh); |
close($fh); |
return 'error: '.$!; |
return 'error: '.$!; |
Line 374 sub delenv {
|
Line 375 sub delenv {
|
return 'error'; |
return 'error'; |
} |
} |
unless (flock($fh,LOCK_EX)) { |
unless (flock($fh,LOCK_EX)) { |
&logthis("<font color=blue>WARNING: ". |
&logthis("<font color=\"blue\">WARNING: ". |
'Could not obtain exclusive lock in delenv: '.$!); |
'Could not obtain exclusive lock in delenv: '.$!); |
close($fh); |
close($fh); |
return 'error: '.$!; |
return 'error: '.$!; |
Line 443 sub overloaderror {
|
Line 444 sub overloaderror {
|
# ------------------------------ Find server with least workload from spare.tab |
# ------------------------------ Find server with least workload from spare.tab |
|
|
sub spareserver { |
sub spareserver { |
my ($loadpercent,$userloadpercent) = @_; |
my ($loadpercent,$userloadpercent,$want_server_name) = @_; |
my $tryserver; |
my $tryserver; |
my $spareserver=''; |
my $spareserver=''; |
if ($userloadpercent !~ /\d/) { $userloadpercent=0; } |
if ($userloadpercent !~ /\d/) { $userloadpercent=0; } |
my $lowestserver=$loadpercent > $userloadpercent? |
my $lowestserver=$loadpercent > $userloadpercent? |
$loadpercent : $userloadpercent; |
$loadpercent : $userloadpercent; |
foreach $tryserver (keys %spareid) { |
foreach $tryserver (keys(%spareid)) { |
my $loadans=reply('load',$tryserver); |
my $loadans=&reply('load',$tryserver); |
my $userloadans=reply('userload',$tryserver); |
my $userloadans=&reply('userload',$tryserver); |
if ($loadans !~ /\d/ && $userloadans !~ /\d/) { |
if ($loadans !~ /\d/ && $userloadans !~ /\d/) { |
next; #didn't get a number from the server |
next; #didn't get a number from the server |
} |
} |
Line 468 sub spareserver {
|
Line 469 sub spareserver {
|
$answer = $userloadans; |
$answer = $userloadans; |
} |
} |
if (($answer =~ /\d/) && ($answer<$lowestserver)) { |
if (($answer =~ /\d/) && ($answer<$lowestserver)) { |
$spareserver="http://$hostname{$tryserver}"; |
if ($want_server_name) { |
|
$spareserver=$tryserver; |
|
} else { |
|
$spareserver="http://$hostname{$tryserver}"; |
|
} |
$lowestserver=$answer; |
$lowestserver=$answer; |
} |
} |
} |
} |
Line 1060 sub repcopy {
|
Line 1065 sub repcopy {
|
if ($response->is_error()) { |
if ($response->is_error()) { |
unlink($transname); |
unlink($transname); |
my $message=$response->status_line; |
my $message=$response->status_line; |
&logthis("<font color=blue>WARNING:" |
&logthis("<font color=\"blue\">WARNING:" |
." LWP get: $message: $filename</font>"); |
." LWP get: $message: $filename</font>"); |
return 'unavailable'; |
return 'unavailable'; |
} else { |
} else { |
Line 1070 sub repcopy {
|
Line 1075 sub repcopy {
|
if ($mresponse->is_error()) { |
if ($mresponse->is_error()) { |
unlink($filename.'.meta'); |
unlink($filename.'.meta'); |
&logthis( |
&logthis( |
"<font color=yellow>INFO: No metadata: $filename</font>"); |
"<font color=\"yellow\">INFO: No metadata: $filename</font>"); |
} |
} |
} |
} |
rename($transname,$filename); |
rename($transname,$filename); |
Line 1538 sub flushcourselogs {
|
Line 1543 sub flushcourselogs {
|
} else { |
} else { |
&logthis('Failed to flush log buffer for '.$crsid); |
&logthis('Failed to flush log buffer for '.$crsid); |
if (length($courselogs{$crsid})>40000) { |
if (length($courselogs{$crsid})>40000) { |
&logthis("<font color=blue>WARNING: Buffer for ".$crsid. |
&logthis("<font color=\"blue\">WARNING: Buffer for ".$crsid. |
" exceeded maximum size, deleting.</font>"); |
" exceeded maximum size, deleting.</font>"); |
delete $courselogs{$crsid}; |
delete $courselogs{$crsid}; |
} |
} |
Line 1949 sub checkout {
|
Line 1954 sub checkout {
|
$now.'&'.$ENV{'REMOTE_ADDR'}); |
$now.'&'.$ENV{'REMOTE_ADDR'}); |
my $token=&reply('tmpput:'.$infostr,$lonhost); |
my $token=&reply('tmpput:'.$infostr,$lonhost); |
if ($token=~/^error\:/) { |
if ($token=~/^error\:/) { |
&logthis("<font color=blue>WARNING: ". |
&logthis("<font color=\"blue\">WARNING: ". |
"Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb. |
"Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb. |
"</font>"); |
"</font>"); |
return ''; |
return ''; |
Line 1965 sub checkout {
|
Line 1970 sub checkout {
|
unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') { |
unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') { |
return ''; |
return ''; |
} else { |
} else { |
&logthis("<font color=blue>WARNING: ". |
&logthis("<font color=\"blue\">WARNING: ". |
"Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb. |
"Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb. |
"</font>"); |
"</font>"); |
} |
} |
Line 1975 sub checkout {
|
Line 1980 sub checkout {
|
$token)) ne 'ok') { |
$token)) ne 'ok') { |
return ''; |
return ''; |
} else { |
} else { |
&logthis("<font color=blue>WARNING: ". |
&logthis("<font color=\"blue\">WARNING: ". |
"Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb. |
"Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb. |
"</font>"); |
"</font>"); |
} |
} |
Line 3102 sub allowed {
|
Line 3107 sub allowed {
|
# not allowing 'edit' access (editupload) to uploaded course docs |
# not allowing 'edit' access (editupload) to uploaded course docs |
if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) { |
if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) { |
$thisallowed=''; |
$thisallowed=''; |
my $refuri=$env{'httpref.'.$orguri}; |
my ($match)=&is_on_map($uri); |
if ($refuri) { |
if ($match) { |
if ($refuri =~ m|^/adm/|) { |
if ($env{'user.priv.'.$env{'request.role'}.'./'} |
$thisallowed='F'; |
=~/\Q$priv\E\&([^\:]*)/) { |
} else { |
$thisallowed.=$1; |
$refuri=&declutter($refuri); |
} |
my ($match) = &is_on_map($refuri); |
} else { |
if ($match) { |
my $refuri=$env{'httpref.'.$orguri}; |
|
if ($refuri) { |
|
if ($refuri =~ m|^/adm/|) { |
$thisallowed='F'; |
$thisallowed='F'; |
|
} else { |
|
$refuri=&declutter($refuri); |
|
my ($match) = &is_on_map($refuri); |
|
if ($match) { |
|
$thisallowed='F'; |
|
} |
} |
} |
} |
} |
} |
} |
} |
} |
|
|
# Full access at system, domain or course-wide level? Exit. |
# Full access at system, domain or course-wide level? Exit. |
Line 3281 sub allowed {
|
Line 3294 sub allowed {
|
my $unamedom=$env{'user.name'}.':'.$env{'user.domain'}; |
my $unamedom=$env{'user.name'}.':'.$env{'user.domain'}; |
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'} |
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'} |
=~/\Q$rolecode\E/) { |
=~/\Q$rolecode\E/) { |
&log($env{'user.domain'},$env{'user.name'},$env{'user.host'}, |
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. |
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. |
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. |
$env{'request.course.id'}); |
$env{'request.course.id'}); |
return ''; |
return ''; |
Line 3289 sub allowed {
|
Line 3302 sub allowed {
|
|
|
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'} |
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'} |
=~/\Q$unamedom\E/) { |
=~/\Q$unamedom\E/) { |
&log($env{'user.domain'},$env{'user.name'},$env{'user.host'}, |
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}. |
'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. |
'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. |
$env{'request.course.id'}); |
$env{'request.course.id'}); |
return ''; |
return ''; |
Line 3301 sub allowed {
|
Line 3314 sub allowed {
|
if ($thisallowed=~/R/) { |
if ($thisallowed=~/R/) { |
my $rolecode=(split(/\./,$env{'request.role'}))[0]; |
my $rolecode=(split(/\./,$env{'request.role'}))[0]; |
if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) { |
if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) { |
&log($env{'user.domain'},$env{'user.name'},$env{'user.host'}, |
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. |
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); |
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); |
return ''; |
return ''; |
} |
} |
} |
} |
Line 3644 sub auto_instcode_format {
|
Line 3657 sub auto_instcode_format {
|
|
|
sub plaintext { |
sub plaintext { |
my $short=shift; |
my $short=shift; |
return &mt($prp{$short}); |
return &Apache::lonlocal::mt($prp{$short}); |
} |
} |
|
|
# ----------------------------------------------------------------- Assign Role |
# ----------------------------------------------------------------- Assign Role |
Line 3962 sub createcourse {
|
Line 3975 sub createcourse {
|
return 'refused'; |
return 'refused'; |
} |
} |
# ------------------------------------------------------------------- Create ID |
# ------------------------------------------------------------------- Create ID |
my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)). |
my $uname=int(1+rand(9)). |
|
('a'..'z','A'..'Z','0'..'9')[int(rand(62))]. |
|
substr($$.time,0,5).unpack("H8",pack("I32",time)). |
unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; |
unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; |
# ----------------------------------------------- Make sure that does not exist |
# ----------------------------------------------- Make sure that does not exist |
my $uhome=&homeserver($uname,$udom,'true'); |
my $uhome=&homeserver($uname,$udom,'true'); |
Line 4470 sub get_userresdata {
|
Line 4485 sub get_userresdata {
|
} |
} |
#error 2 occurs when the .db doesn't exist |
#error 2 occurs when the .db doesn't exist |
if ($tmp!~/error: 2 /) { |
if ($tmp!~/error: 2 /) { |
&logthis("<font color=blue>WARNING:". |
&logthis("<font color=\"blue\">WARNING:". |
" Trying to get resource data for ". |
" Trying to get resource data for ". |
$uname." at ".$udom.": ". |
$uname." at ".$udom.": ". |
$tmp."</font>"); |
$tmp."</font>"); |
Line 4624 sub EXT {
|
Line 4639 sub EXT {
|
# ------------------------------------------------------------- request.browser |
# ------------------------------------------------------------- request.browser |
if ($space eq 'browser') { |
if ($space eq 'browser') { |
if ($qualifier eq 'textremote') { |
if ($qualifier eq 'textremote') { |
if (&mt('textual_remote_display') eq 'on') { |
if (&Apache::lonlocal::mt('textual_remote_display') eq 'on') { |
return 1; |
return 1; |
} else { |
} else { |
return 0; |
return 0; |
Line 5365 sub numval3 {
|
Line 5380 sub numval3 {
|
return $total; |
return $total; |
} |
} |
|
|
|
sub digest { |
|
my ($data)=@_; |
|
my $digest=&Digest::MD5::md5($data); |
|
my ($a,$b,$c,$d)=unpack("iiii",$digest); |
|
my ($e,$f); |
|
{ |
|
use integer; |
|
$e=($a+$b); |
|
$f=($c+$d); |
|
if ($_64bit) { |
|
$e=(($e<<32)>>32); |
|
$f=(($f<<32)>>32); |
|
} |
|
} |
|
if (wantarray) { |
|
return ($e,$f); |
|
} else { |
|
my $g; |
|
{ |
|
use integer; |
|
$g=($e+$f); |
|
if ($_64bit) { |
|
$g=(($g<<32)>>32); |
|
} |
|
} |
|
return $g; |
|
} |
|
} |
|
|
sub latest_rnd_algorithm_id { |
sub latest_rnd_algorithm_id { |
return '64bit4'; |
return '64bit5'; |
} |
} |
|
|
sub get_rand_alg { |
sub get_rand_alg { |
Line 5406 sub rndseed {
|
Line 5450 sub rndseed {
|
if (!$username) { $username=$wusername } |
if (!$username) { $username=$wusername } |
my $which=&get_rand_alg(); |
my $which=&get_rand_alg(); |
if (defined(&getCODE())) { |
if (defined(&getCODE())) { |
if ($which eq '64bit4') { |
if ($which eq '64bit5') { |
|
return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username); |
|
} elsif ($which eq '64bit4') { |
return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username); |
return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username); |
} else { |
} else { |
return &rndseed_CODE_64bit($symb,$courseid,$domain,$username); |
return &rndseed_CODE_64bit($symb,$courseid,$domain,$username); |
} |
} |
|
} elsif ($which eq '64bit5') { |
|
return &rndseed_64bit5($symb,$courseid,$domain,$username); |
} elsif ($which eq '64bit4') { |
} elsif ($which eq '64bit4') { |
return &rndseed_64bit4($symb,$courseid,$domain,$username); |
return &rndseed_64bit4($symb,$courseid,$domain,$username); |
} elsif ($which eq '64bit3') { |
} elsif ($which eq '64bit3') { |
Line 5533 sub rndseed_64bit4 {
|
Line 5581 sub rndseed_64bit4 {
|
} |
} |
} |
} |
|
|
|
sub rndseed_64bit5 { |
|
my ($symb,$courseid,$domain,$username)=@_; |
|
my ($num1,$num2)=&digest("$symb,$courseid,$domain,$username"); |
|
return "$num1:$num2"; |
|
} |
|
|
sub rndseed_CODE_64bit { |
sub rndseed_CODE_64bit { |
my ($symb,$courseid,$domain,$username)=@_; |
my ($symb,$courseid,$domain,$username)=@_; |
{ |
{ |
Line 5571 sub rndseed_CODE_64bit4 {
|
Line 5625 sub rndseed_CODE_64bit4 {
|
} |
} |
} |
} |
|
|
|
sub rndseed_CODE_64bit5 { |
|
my ($symb,$courseid,$domain,$username)=@_; |
|
my $code = &getCODE(); |
|
my ($num1,$num2)=&digest("$symb,$courseid,$code"); |
|
return "$num1:$num2"; |
|
} |
|
|
sub setup_random_from_rndseed { |
sub setup_random_from_rndseed { |
my ($rndseed)=@_; |
my ($rndseed)=@_; |
if ($rndseed =~/([,:])/) { |
if ($rndseed =~/([,:])/) { |
Line 6114 $processmarker='_'.time.'_'.$perlvar{'lo
|
Line 6175 $processmarker='_'.time.'_'.$perlvar{'lo
|
$dumpcount=0; |
$dumpcount=0; |
|
|
&logtouch(); |
&logtouch(); |
&logthis('<font color=yellow>INFO: Read configuration</font>'); |
&logthis('<font color="yellow">INFO: Read configuration</font>'); |
$readit=1; |
$readit=1; |
{ |
{ |
use integer; |
use integer; |