version 1.364, 2003/04/22 21:00:42
|
version 1.370, 2003/05/08 21:50:54
|
Line 347 sub delenv {
|
Line 347 sub delenv {
|
return 'ok'; |
return 'ok'; |
} |
} |
|
|
|
# ------------------------------------------ Find out current server userload |
|
# there is a copy in lond |
|
sub userload { |
|
my $numusers=0; |
|
{ |
|
opendir(LONIDS,$perlvar{'lonIDsDir'}); |
|
my $filename; |
|
my $curtime=time; |
|
while ($filename=readdir(LONIDS)) { |
|
if ($filename eq '.' || $filename eq '..') {next;} |
|
my ($atime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[8]; |
|
if ($curtime-$atime < 3600) { $num_users++; } |
|
} |
|
closedir(LONIDS); |
|
} |
|
my $userloadpercent=0; |
|
my $maxuserload=$perlvar{'lonUserLoadLim'}; |
|
if ($maxuserload) { |
|
$userloadpercent=100*$num_users/$maxuserload; |
|
} |
|
return $userloadpercent; |
|
} |
|
|
# ------------------------------------------ Fight off request when overloaded |
# ------------------------------------------ Fight off request when overloaded |
|
|
sub overloaderror { |
sub overloaderror { |
Line 373 sub overloaderror {
|
Line 396 sub overloaderror {
|
# ------------------------------ Find server with least workload from spare.tab |
# ------------------------------ Find server with least workload from spare.tab |
|
|
sub spareserver { |
sub spareserver { |
my $loadpercent = shift; |
my ($loadpercent,$userloadpercent) = @_; |
my $tryserver; |
my $tryserver; |
my $spareserver=''; |
my $spareserver=''; |
my $lowestserver=$loadpercent; |
if ($userloadpercent !~ /\d/) { $userloadpercent=0; } |
|
my $lowestserver=$loadpercent > $userloadpercent? |
|
$loadpercent : $userloadpercent; |
foreach $tryserver (keys %spareid) { |
foreach $tryserver (keys %spareid) { |
my $answer=reply('load',$tryserver); |
my $loadans=reply('load',$tryserver); |
|
my $userloadans=reply('userload',$tryserver); |
|
if ($userloadans !~ /\d/) { $userloadans=0; } |
|
my $answer=$loadans > $userloadans? |
|
$loadans : $userloadans; |
if (($answer =~ /\d/) && ($answer<$lowestserver)) { |
if (($answer =~ /\d/) && ($answer<$lowestserver)) { |
$spareserver="http://$hostname{$tryserver}"; |
$spareserver="http://$hostname{$tryserver}"; |
$lowestserver=$answer; |
$lowestserver=$answer; |
} |
} |
} |
} |
return $spareserver; |
return $spareserver; |
} |
} |
|
|
Line 650 sub comment_access_key {
|
Line 679 sub comment_access_key {
|
if ($existing{$ckey}) { |
if ($existing{$ckey}) { |
$existing{$ckey}.='; '.$logentry; |
$existing{$ckey}.='; '.$logentry; |
# ready to assign |
# ready to assign |
$logentry=$1.'; '.$logentry; |
if (&put('accesskeys',{$ckey=>$existing{$ckey}}, |
if (&put('accesskey',{$ckey=>$existing{$ckey}}, |
|
$cdom,$cnum) eq 'ok') { |
$cdom,$cnum) eq 'ok') { |
return 'ok'; |
return 'ok'; |
} else { |
} else { |
Line 3412 sub metadata {
|
Line 3440 sub metadata {
|
my $parser=HTML::LCParser->new(\$metastring); |
my $parser=HTML::LCParser->new(\$metastring); |
my $token; |
my $token; |
undef %metathesekeys; |
undef %metathesekeys; |
|
delete($metacache{$uri.':packages'}); |
while ($token=$parser->get_token) { |
while ($token=$parser->get_token) { |
if ($token->[0] eq 'S') { |
if ($token->[0] eq 'S') { |
if (defined($token->[2]->{'package'})) { |
if (defined($token->[2]->{'package'})) { |
Line 3761 sub numval {
|
Line 3790 sub numval {
|
$txt=~tr/u-z/0-5/; |
$txt=~tr/u-z/0-5/; |
$txt=~s/\D//g; |
$txt=~s/\D//g; |
return int($txt); |
return int($txt); |
} |
} |
|
|
|
sub latest_rnd_algorithm_id { |
|
return '64bit'; |
|
} |
|
|
sub rndseed { |
sub rndseed { |
my ($symb,$courseid,$domain,$username)=@_; |
my ($symb,$courseid,$domain,$username)=@_; |
|
|
|
my ($wsymb,$wcourseid,$wdomain,$wusername)=&Apache::lonxml::whichuser(); |
if (!$symb) { |
if (!$symb) { |
unless ($symb=&symbread()) { return time; } |
unless ($symb=$wsymb) { return time; } |
|
} |
|
if (!$courseid) { $courseid=$wcourseid; } |
|
if (!$domain) { $domain=$wdomain; } |
|
if (!$username) { $username=$wusername } |
|
my $which=$ENV{"course.$courseid.rndseed"}; |
|
my $CODE=$ENV{'scantron.CODE'}; |
|
if (defined($CODE)) { |
|
&rndseed_CODE_64bit($symb,$courseid,$domain,$username); |
|
} elsif ($which eq '64bit') { |
|
return &rndseed_64bit($symb,$courseid,$domain,$username); |
|
} |
|
return &rndseed_32bit($symb,$courseid,$domain,$username); |
|
} |
|
|
|
sub rndseed_32bit { |
|
my ($symb,$courseid,$domain,$username)=@_; |
|
{ |
|
use integer; |
|
my $symbchck=unpack("%32C*",$symb) << 27; |
|
my $symbseed=numval($symb) << 22; |
|
my $namechck=unpack("%32C*",$username) << 17; |
|
my $nameseed=numval($username) << 12; |
|
my $domainseed=unpack("%32C*",$domain) << 7; |
|
my $courseseed=unpack("%32C*",$courseid); |
|
my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck; |
|
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
|
#&Apache::lonxml::debug("rndseed :$num:$symb"); |
|
return $num; |
|
} |
|
} |
|
|
|
sub rndseed_64bit { |
|
my ($symb,$courseid,$domain,$username)=@_; |
|
{ |
|
use integer; |
|
my $symbchck=unpack("%32S*",$symb) << 21; |
|
my $symbseed=numval($symb) << 10; |
|
my $namechck=unpack("%32S*",$username); |
|
|
|
my $nameseed=numval($username) << 21; |
|
my $domainseed=unpack("%32S*",$domain) << 10; |
|
my $courseseed=unpack("%32S*",$courseid); |
|
|
|
my $num1=$symbchck+$symbseed+$namechck; |
|
my $num2=$nameseed+$domainseed+$courseseed; |
|
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
|
#&Apache::lonxml::debug("rndseed :$num:$symb"); |
|
return "$num1,$num2"; |
} |
} |
if (!$courseid) { $courseid=$ENV{'request.course.id'};} |
} |
if (!$domain) {$domain=$ENV{'user.domain'};} |
|
if (!$username) {$username=$ENV{'user.name'};} |
sub rndseed_CODE_64bit { |
|
my ($symb,$courseid,$domain,$username)=@_; |
{ |
{ |
use integer; |
use integer; |
my $symbchck=unpack("%32C*",$symb) << 27; |
my $symbchck=unpack("%32S*",$symb) << 16; |
my $symbseed=numval($symb) << 22; |
my $symbseed=numval($symb); |
my $namechck=unpack("%32C*",$username) << 17; |
my $CODEseed=numval($ENV{'scantron.CODE'}) << 16; |
my $nameseed=numval($username) << 12; |
my $courseseed=unpack("%32S*",$courseid); |
my $domainseed=unpack("%32C*",$domain) << 7; |
my $num1=$symbseed+$CODEseed; |
my $courseseed=unpack("%32C*",$courseid); |
my $num2=$courseseed+$symbchck; |
my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck; |
#&Apache::lonxml::debug("$symbseed:$CODEseed|$courseseed:$symbchck"); |
#uncommenting these lines can break things! |
#&Apache::lonxml::debug("rndseed :$num1:$num2:$symb"); |
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
return "$num1,$num2"; |
#&Apache::lonxml::debug("rndseed :$num:$symb"); |
} |
return $num; |
} |
|
|
|
sub setup_random_from_rndseed { |
|
my ($rndseed)=@_; |
|
if ($rndseed =~/,/) { |
|
my ($num1,$num2)=split(/,/,$rndseed); |
|
&Math::Random::random_set_seed(abs($num1),abs($num2)); |
|
} else { |
|
&Math::Random::random_set_seed_from_phrase($rndseed); |
} |
} |
} |
} |
|
|