--- loncom/lonnet/perl/lonnet.pm 2003/04/03 22:17:09 1.359
+++ loncom/lonnet/perl/lonnet.pm 2003/06/10 18:17:34 1.378
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.359 2003/04/03 22:17:09 albertel Exp $
+# $Id: lonnet.pm,v 1.378 2003/06/10 18:17:34 matthew Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -243,6 +243,26 @@ sub critical {
}
return $answer;
}
+
+# ------------------------------------------- Transfer profile into environment
+
+sub transfer_profile_to_env {
+ my ($lonidsdir,$handle)=@_;
+ my @profile;
+ {
+ my $idf=Apache::File->new("$lonidsdir/$handle.id");
+ flock($idf,LOCK_SH);
+ @profile=<$idf>;
+ $idf->close();
+ }
+ my $envi;
+ for ($envi=0;$envi<=$#profile;$envi++) {
+ chomp($profile[$envi]);
+ my ($envname,$envvalue)=split(/=/,$profile[$envi]);
+ $ENV{$envname} = $envvalue;
+ }
+ $ENV{'user.environment'} = "$lonidsdir/$handle.id";
+}
# ---------------------------------------------------------- Append Environment
@@ -347,6 +367,30 @@ sub delenv {
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) { $numusers++; }
+ }
+ closedir(LONIDS);
+ }
+ my $userloadpercent=0;
+ my $maxuserload=$perlvar{'lonUserLoadLim'};
+ if ($maxuserload) {
+ $userloadpercent=100*$numusers/$maxuserload;
+ }
+ $userloadpercent=sprintf("%.2f",$userloadpercent);
+ return $userloadpercent;
+}
+
# ------------------------------------------ Fight off request when overloaded
sub overloaderror {
@@ -373,17 +417,23 @@ sub overloaderror {
# ------------------------------ Find server with least workload from spare.tab
sub spareserver {
- my $loadpercent = shift;
+ my ($loadpercent,$userloadpercent) = @_;
my $tryserver;
my $spareserver='';
- my $lowestserver=$loadpercent;
+ if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
+ my $lowestserver=$loadpercent > $userloadpercent?
+ $loadpercent : $userloadpercent;
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)) {
$spareserver="http://$hostname{$tryserver}";
$lowestserver=$answer;
}
- }
+ }
return $spareserver;
}
@@ -591,7 +641,11 @@ sub idput {
# --------------------------------------------------- Assign a key to a student
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=
$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
$cnum=
@@ -599,13 +653,16 @@ sub assign_access_key {
$udom=$ENV{'user.name'} unless (defined($udom));
$uname=$ENV{'user.domain'} unless (defined($uname));
my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
- if (($existing{$ckey}=~/^\d+$/) || # has time - new key
- ($existing{$ckey} eq $uname.':'.$udom)) { # this should not happen,
+ if (($existing{$ckey}=~/^\#(.*)$/) || # - new key
+ ($existing{$ckey}=~/^$uname\:$udom\#(.*)$/)) {
+ # assigned to this person
+ # - this should not happen,
# unless something went wrong
# the first time around
# ready to assign
- } elsif (!$existing{$ckey}) {
- if (&put('accesskey',{$ckey=>$uname.':'.$udom},$cdom,$cnum) eq 'ok') {
+ $logentry=$1.'; '.$logentry;
+ if (&put('accesskey',{$ckey=>$uname.':'.$udom.'#'.$logentry},
+ $cdom,$cnum) eq 'ok') {
# key now belongs to user
my $envkey='key.'.$cdom.'_'.$cnum;
if (&put('environment',{$envkey => $ckey}) eq 'ok') {
@@ -618,6 +675,7 @@ sub assign_access_key {
} else {
return 'error: Could not assign key, try again later.';
}
+ } elsif (!$existing{$ckey}) {
# the key does not exist
return 'error: The key does not exist';
} else {
@@ -626,15 +684,43 @@ 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
sub generate_access_keys {
- my ($number,$cdom,$cnum)=@_;
+ my ($number,$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));
- unless (&allowed('ccc',$cdom)) { return 0; }
+ unless (&allowed('mky',$cdom)) { return 0; }
unless (($cdom) && ($cnum)) { return 0; }
if ($number>10000) { return 0; }
sleep(2); # make sure don't get same seed twice
@@ -650,7 +736,11 @@ sub generate_access_keys {
if ($existing{$newkey}) {
$i--;
} 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++;
}
}
@@ -671,7 +761,7 @@ sub validate_access_key {
$udom=$ENV{'user.name'} unless (defined($udom));
$uname=$ENV{'user.domain'} unless (defined($uname));
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
@@ -1149,6 +1239,14 @@ 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 {
my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
if (($trole=~/^ca/) || ($trole=~/^in/) ||
@@ -1182,8 +1280,8 @@ sub get_course_adv_roles {
} else {
$returnhash{$key}=$username.':'.$domain;
}
- }
- return sort %returnhash;
+ }
+ return %returnhash;
}
# ---------------------------------------------------------- Course ID routines
@@ -2563,7 +2661,7 @@ sub assignrole {
} else {
my $cwosec=$url;
$cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
- unless (&allowed('c'.$role,$cwosec)) {
+ unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) {
&logthis('Refused assignrole: '.
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
$ENV{'user.name'}.' at '.$ENV{'user.domain'});
@@ -2583,10 +2681,11 @@ sub assignrole {
}
# actually delete
if ($deleteflag) {
- if (&allowed('dro',$udom)) {
+ if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) {
# modify command to delete the role
$command="encrypt:rolesdel:$ENV{'user.domain'}:$ENV{'user.name'}:".
"$udom:$uname:$url".'_'."$mrole";
+ &logthis("$ENV{'user.name'} at $ENV{'user.domain'} deletes $mrole in $url for $uname at $udom");
# set start and finish to negative values for userrolelog
$start=-1;
$end=-1;
@@ -2985,12 +3084,12 @@ sub GetFileTimestamp {
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
my $proname="$studentDomain/$subdir/$studentName";
$proname .= '/'.$filename;
- my @dir = &Apache::lonnet::dirlist($proname, $studentDomain, $studentName,
- $root);
- my $fileStat = $dir[0];
+ my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain,
+ $studentName, $root);
my @stats = split('&', $fileStat);
if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
- return $stats[9];
+ # @stats contains first the filename, then the stat output
+ return $stats[10]; # so this is 10 instead of 9.
} else {
return -1;
}
@@ -3089,15 +3188,15 @@ sub courseresdata {
# --------------------------------------------------------- Value of a Variable
sub EXT {
- my ($varname,$symbparm,$udom,$uname,)=@_;
+ my ($varname,$symbparm,$udom,$uname,$usection)=@_;
unless ($varname) { return ''; }
#get real user name/domain, courseid and symb
my $courseid;
my $publicuser;
if (!($uname && $udom)) {
- (my $cursymb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
- if ($udom eq 'public' and $uname =~ /^public/) { $publicuser='1'; }
+ (my $cursymb,$courseid,$udom,$uname,$publicuser)=
+ &Apache::lonxml::whichuser($symbparm);
if (!$symbparm) { $symbparm=$cursymb; }
} else {
$courseid=$ENV{'request.course.id'};
@@ -3175,7 +3274,7 @@ sub EXT {
} elsif ($realm eq 'query') {
# ---------------------------------------------- pull stuff out of query string
&Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},[$space]);
- return $ENV{'form.'.$space};
+ return $ENV{'form.'.$spacequalifierrest};
} elsif ($realm eq 'request') {
# ------------------------------------------------------------- request.browser
if ($space eq 'browser') {
@@ -3206,7 +3305,11 @@ sub EXT {
($ENV{'user.domain'} eq $udom)) {
$section=$ENV{'request.course.sec'};
} else {
- $section=&usection($udom,$uname,$courseid);
+ if (! defined($usection)) {
+ $section=&usection($udom,$uname,$courseid);
+ } else {
+ $section = $usection;
+ }
}
my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
@@ -3363,6 +3466,7 @@ sub metadata {
my $parser=HTML::LCParser->new(\$metastring);
my $token;
undef %metathesekeys;
+ delete($metacache{$uri.':packages'});
while ($token=$parser->get_token) {
if ($token->[0] eq 'S') {
if (defined($token->[2]->{'package'})) {
@@ -3538,6 +3642,7 @@ sub gettitle {
$title=$bighash{'title_'.$mapid.'.'.$resid};
untie %bighash;
}
+ $title=~s/\&colon\;/\:/gs;
if ($title) {
$titlecache{$symb}=$title;
return $title;
@@ -3711,29 +3816,92 @@ sub numval {
$txt=~tr/u-z/0-5/;
$txt=~s/\D//g;
return int($txt);
-}
+}
+
+sub latest_rnd_algorithm_id {
+ return '64bit';
+}
sub rndseed {
my ($symb,$courseid,$domain,$username)=@_;
+
+ my ($wsymb,$wcourseid,$wdomain,$wusername)=&Apache::lonxml::whichuser();
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);
}
- if (!$courseid) { $courseid=$ENV{'request.course.id'};}
- if (!$domain) {$domain=$ENV{'user.domain'};}
- if (!$username) {$username=$ENV{'user.name'};}
+ 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("%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;
- #uncommenting these lines can break things!
- #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
- #&Apache::lonxml::debug("rndseed :$num:$symb");
- return $num;
+ 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);
}
}
@@ -3859,6 +4027,7 @@ sub goodbye {
&logthis("Starting Shut down");
&flushcourselogs();
&logthis("Shutting down");
+ return DONE;
}
BEGIN {