version 1.360, 2003/04/03 22:25:49
|
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 591 sub idput {
|
Line 620 sub idput {
|
# --------------------------------------------------- Assign a key to a student |
# --------------------------------------------------- Assign a key to a student |
|
|
sub assign_access_key { |
sub assign_access_key { |
my ($ckey,$cdom,$cnum,$udom,$uname)=@_; |
# |
|
# a valid key looks like uname:udom#comments |
|
# comments are being appended |
|
# |
|
my ($ckey,$cdom,$cnum,$udom,$uname,$logentry)=@_; |
$cdom= |
$cdom= |
$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); |
$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); |
$cnum= |
$cnum= |
Line 599 sub assign_access_key {
|
Line 632 sub assign_access_key {
|
$udom=$ENV{'user.name'} unless (defined($udom)); |
$udom=$ENV{'user.name'} unless (defined($udom)); |
$uname=$ENV{'user.domain'} unless (defined($uname)); |
$uname=$ENV{'user.domain'} unless (defined($uname)); |
my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); |
my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); |
if (($existing{$ckey}=~/^\d+$/) || # has time - new key |
if (($existing{$ckey}=~/^\#(.*)$/) || # - new key |
($existing{$ckey} eq $uname.':'.$udom)) { # this should not happen, |
($existing{$ckey}=~/^$uname\:$udom\#(.*)$/)) { |
|
# assigned to this person |
|
# - this should not happen, |
# unless something went wrong |
# unless something went wrong |
# the first time around |
# the first time around |
# ready to assign |
# ready to assign |
} elsif (!$existing{$ckey}) { |
$logentry=$1.'; '.$logentry; |
if (&put('accesskey',{$ckey=>$uname.':'.$udom},$cdom,$cnum) eq 'ok') { |
if (&put('accesskey',{$ckey=>$uname.':'.$udom.'#'.$logentry}, |
|
$cdom,$cnum) eq 'ok') { |
# key now belongs to user |
# key now belongs to user |
my $envkey='key.'.$cdom.'_'.$cnum; |
my $envkey='key.'.$cdom.'_'.$cnum; |
if (&put('environment',{$envkey => $ckey}) eq 'ok') { |
if (&put('environment',{$envkey => $ckey}) eq 'ok') { |
Line 618 sub assign_access_key {
|
Line 654 sub assign_access_key {
|
} else { |
} else { |
return 'error: Could not assign key, try again later.'; |
return 'error: Could not assign key, try again later.'; |
} |
} |
|
} elsif (!$existing{$ckey}) { |
# the key does not exist |
# the key does not exist |
return 'error: The key does not exist'; |
return 'error: The key does not exist'; |
} else { |
} else { |
Line 626 sub assign_access_key {
|
Line 663 sub assign_access_key {
|
} |
} |
} |
} |
|
|
|
# ------------------------------------------ put an additional comment on a key |
|
|
|
sub comment_access_key { |
|
# |
|
# a valid key looks like uname:udom#comments |
|
# comments are being appended |
|
# |
|
my ($ckey,$cdom,$cnum,$logentry)=@_; |
|
$cdom= |
|
$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); |
|
$cnum= |
|
$ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); |
|
my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); |
|
if ($existing{$ckey}) { |
|
$existing{$ckey}.='; '.$logentry; |
|
# ready to assign |
|
if (&put('accesskeys',{$ckey=>$existing{$ckey}}, |
|
$cdom,$cnum) eq 'ok') { |
|
return 'ok'; |
|
} else { |
|
return 'error: Count not store comment.'; |
|
} |
|
} else { |
|
# the key does not exist |
|
return 'error: The key does not exist'; |
|
} |
|
} |
|
|
# ------------------------------------------------------ Generate a set of keys |
# ------------------------------------------------------ Generate a set of keys |
|
|
sub generate_access_keys { |
sub generate_access_keys { |
my ($number,$cdom,$cnum)=@_; |
my ($number,$cdom,$cnum,$logentry)=@_; |
$cdom= |
$cdom= |
$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); |
$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom)); |
$cnum= |
$cnum= |
$ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); |
$ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum)); |
unless (&allowed('ccc',$cdom)) { return 0; } |
unless (&allowed('mky',$cdom)) { return 0; } |
unless (($cdom) && ($cnum)) { return 0; } |
unless (($cdom) && ($cnum)) { return 0; } |
if ($number>10000) { return 0; } |
if ($number>10000) { return 0; } |
sleep(2); # make sure don't get same seed twice |
sleep(2); # make sure don't get same seed twice |
Line 650 sub generate_access_keys {
|
Line 715 sub generate_access_keys {
|
if ($existing{$newkey}) { |
if ($existing{$newkey}) { |
$i--; |
$i--; |
} else { |
} else { |
if (&put('accesskeys',{ $newkey => time() },$cdom,$cnum) eq 'ok') { |
if (&put('accesskeys', |
|
{ $newkey => '# generated '.localtime(). |
|
' by '.$ENV{'user.name'}.'@'.$ENV{'user.domain'}. |
|
'; '.$logentry }, |
|
$cdom,$cnum) eq 'ok') { |
$total++; |
$total++; |
} |
} |
} |
} |
Line 671 sub validate_access_key {
|
Line 740 sub validate_access_key {
|
$udom=$ENV{'user.name'} unless (defined($udom)); |
$udom=$ENV{'user.name'} unless (defined($udom)); |
$uname=$ENV{'user.domain'} unless (defined($uname)); |
$uname=$ENV{'user.domain'} unless (defined($uname)); |
my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); |
my %existing=&get('accesskeys',[$ckey],$cdom,$cnum); |
return ($existing{$ckey} eq $uname.':'.$udom); |
return ($existing{$ckey}=~/^$uname\:$udom\#/); |
} |
} |
|
|
# ------------------------------------- Find the section of student in a course |
# ------------------------------------- Find the section of student in a course |
Line 1149 sub countacc {
|
Line 1218 sub countacc {
|
} |
} |
} |
} |
|
|
|
sub linklog { |
|
my ($from,$to)=@_; |
|
$from=&declutter($from); |
|
$to=&declutter($to); |
|
$accesshash{$from.'___'.$to.'___comefrom'}=1; |
|
$accesshash{$to.'___'.$from.'___goto'}=1; |
|
} |
|
|
sub userrolelog { |
sub userrolelog { |
my ($trole,$username,$domain,$area,$tstart,$tend)=@_; |
my ($trole,$username,$domain,$area,$tstart,$tend)=@_; |
if (($trole=~/^ca/) || ($trole=~/^in/) || |
if (($trole=~/^ca/) || ($trole=~/^in/) || |
Line 3363 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 3538 sub gettitle {
|
Line 3616 sub gettitle {
|
$title=$bighash{'title_'.$mapid.'.'.$resid}; |
$title=$bighash{'title_'.$mapid.'.'.$resid}; |
untie %bighash; |
untie %bighash; |
} |
} |
|
$title=~s/\&colon\;/\:/gs; |
if ($title) { |
if ($title) { |
$titlecache{$symb}=$title; |
$titlecache{$symb}=$title; |
return $title; |
return $title; |
Line 3711 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=$ENV{'request.course.id'};} |
if (!$courseid) { $courseid=$wcourseid; } |
if (!$domain) {$domain=$ENV{'user.domain'};} |
if (!$domain) { $domain=$wdomain; } |
if (!$username) {$username=$ENV{'user.name'};} |
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; |
use integer; |
my $symbchck=unpack("%32C*",$symb) << 27; |
my $symbchck=unpack("%32C*",$symb) << 27; |
my $symbseed=numval($symb) << 22; |
my $symbseed=numval($symb) << 22; |
my $namechck=unpack("%32C*",$username) << 17; |
my $namechck=unpack("%32C*",$username) << 17; |
my $nameseed=numval($username) << 12; |
my $nameseed=numval($username) << 12; |
my $domainseed=unpack("%32C*",$domain) << 7; |
my $domainseed=unpack("%32C*",$domain) << 7; |
my $courseseed=unpack("%32C*",$courseid); |
my $courseseed=unpack("%32C*",$courseid); |
my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck; |
my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck; |
#uncommenting these lines can break things! |
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
#&Apache::lonxml::debug("rndseed :$num:$symb"); |
#&Apache::lonxml::debug("rndseed :$num:$symb"); |
return $num; |
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"; |
|
} |
|
} |
|
|
|
sub rndseed_CODE_64bit { |
|
my ($symb,$courseid,$domain,$username)=@_; |
|
{ |
|
use integer; |
|
my $symbchck=unpack("%32S*",$symb) << 16; |
|
my $symbseed=numval($symb); |
|
my $CODEseed=numval($ENV{'scantron.CODE'}) << 16; |
|
my $courseseed=unpack("%32S*",$courseid); |
|
my $num1=$symbseed+$CODEseed; |
|
my $num2=$courseseed+$symbchck; |
|
#&Apache::lonxml::debug("$symbseed:$CODEseed|$courseseed:$symbchck"); |
|
#&Apache::lonxml::debug("rndseed :$num1:$num2:$symb"); |
|
return "$num1,$num2"; |
|
} |
|
} |
|
|
|
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); |
} |
} |
} |
} |
|
|
Line 3859 sub goodbye {
|
Line 4001 sub goodbye {
|
&logthis("Starting Shut down"); |
&logthis("Starting Shut down"); |
&flushcourselogs(); |
&flushcourselogs(); |
&logthis("Shutting down"); |
&logthis("Shutting down"); |
|
return DONE; |
} |
} |
|
|
BEGIN { |
BEGIN { |