--- loncom/lonnet/perl/lonnet.pm 2003/04/30 21:09:55 1.366 +++ loncom/lonnet/perl/lonnet.pm 2003/07/03 19:26:21 1.386 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.366 2003/04/30 21:09:55 albertel Exp $ +# $Id: lonnet.pm,v 1.386 2003/07/03 19:26:21 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; } @@ -650,8 +700,7 @@ sub comment_access_key { if ($existing{$ckey}) { $existing{$ckey}.='; '.$logentry; # ready to assign - $logentry=$1.'; '.$logentry; - if (&put('accesskey',{$ckey=>$existing{$ckey}}, + if (&put('accesskeys',{$ckey=>$existing{$ckey}}, $cdom,$cnum) eq 'ok') { return 'ok'; } else { @@ -933,9 +982,9 @@ sub repcopy { # ------------------------------------------------ Get server side include body sub ssi_body { - my $filelink=shift; + my ($filelink,%form)=@_; my $output=($filelink=~/^http\:/?&externalssi($filelink): - &ssi($filelink)); + &ssi($filelink,%form)); $output=~s/^.*\]*\>//si; $output=~s/\<\/body\s*\>.*$//si; $output=~ @@ -1231,8 +1280,8 @@ sub get_course_adv_roles { } else { $returnhash{$key}=$username.':'.$domain; } - } - return sort %returnhash; + } + return %returnhash; } # ---------------------------------------------------------- Course ID routines @@ -1594,7 +1643,7 @@ sub tmpreset { my ($symb,$namespace,$domain,$stuname) = @_; if (!$symb) { $symb=&symbread(); - if (!$symb) { $symb= $ENV{'REQUEST_URI'}; } + if (!$symb) { $symb= $ENV{'request.url'}; } } $symb=escape($symb); @@ -2612,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'}); @@ -2632,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; @@ -2724,7 +2774,7 @@ sub modifyuser { } $uhome=&homeserver($uname,$udom,'true'); if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) { - return 'error: verify home'; + return 'error: unable verify users home machine.'; } } # End of creation of new user # ---------------------------------------------------------------------- Add ID @@ -2734,7 +2784,8 @@ sub modifyuser { if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/) && (!$forceid)) { unless ($uid eq $uidhash{$uname}) { - return 'error: mismatch '.$uidhash{$uname}.' versus '.$uid; + return 'error: user id "'.$uid.'" does not match '. + 'current user id "'.$uidhash{$uname}.'".'; } } else { &idput($udom,($uname => $uid)); @@ -2750,10 +2801,10 @@ sub modifyuser { } else { %names = @tmp; } - if ($first) { $names{'firstname'} = $first; } - if ($middle) { $names{'middlename'} = $middle; } - if ($last) { $names{'lastname'} = $last; } - if ($gene) { $names{'generation'} = $gene; } + if (defined($first)) { $names{'firstname'} = $first; } + if (defined($middle)) { $names{'middlename'} = $middle; } + if (defined($last)) { $names{'lastname'} = $last; } + if (defined($gene)) { $names{'generation'} = $gene; } my $reply = &put('environment', \%names, $udom,$uname); if ($reply ne 'ok') { return 'error: '.$reply; } &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '. @@ -3034,12 +3085,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; } @@ -3135,10 +3186,34 @@ sub courseresdata { return undef; } -# --------------------------------------------------------- Value of a Variable +# +# EXT resource caching routines +# + +sub clear_EXT_cache_status { + &delenv('cache.EXT.'); +} + +sub EXT_cache_status { + my ($target_domain,$target_user) = @_; + my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; + if (exists($ENV{$cachename}) && ($ENV{$cachename}+1800) > time) { + # We know already the user has no data + return 1; + } else { + return 0; + } +} +sub EXT_cache_set { + my ($target_domain,$target_user) = @_; + my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain; + &appenv($cachename => time); +} + +# --------------------------------------------------------- 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 @@ -3146,7 +3221,7 @@ sub EXT { my $publicuser; if (!($uname && $udom)) { (my $cursymb,$courseid,$udom,$uname,$publicuser)= - &Apache::lonxml::whichuser(); + &Apache::lonxml::whichuser($symbparm); if (!$symbparm) { $symbparm=$cursymb; } } else { $courseid=$ENV{'request.course.id'}; @@ -3223,8 +3298,9 @@ 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}; + &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'}, + [$spacequalifierrest]); + return $ENV{'form.'.$spacequalifierrest}; } elsif ($realm eq 'request') { # ------------------------------------------------------------- request.browser if ($space eq 'browser') { @@ -3255,7 +3331,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; @@ -3267,11 +3347,9 @@ sub EXT { my $courselevelm=$courseid.'.'.$mapparm; # ----------------------------------------------------------- first, check user - #most student don't have any data set, check if there is some data + #most student don\'t have any data set, check if there is some data #every thirty minutes - if (! - (exists($ENV{'cache.studentresdata'}) - && (($ENV{'cache.studentresdata'}+1800) > time))) { + if (! &EXT_cache_status($udom,$uname)) { my %resourcedata=&get('resourcedata', [$courselevelr,$courselevelm,$courselevel], $udom,$uname); @@ -3290,9 +3368,7 @@ sub EXT { $uname." at ".$udom.": ". $tmp.""); } elsif ($tmp=~/error:No such file/) { - $ENV{'cache.studentresdata'}=time; - &appenv(('cache.studentresdata'=> - $ENV{'cache.studentresdata'})); + &EXT_cache_set($udom,$uname); } elsif ($tmp =~ /^(con_lost|no_such_host)/) { return $tmp; } @@ -3578,7 +3654,13 @@ sub gettitle { unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; } return &metadata($urlsymb,'title'); } - if ($titlecache{$symb}) { return $titlecache{$symb}; } + if ($titlecache{$symb}) { + if (time < ($titlecache{$symb}[1] + 600)) { + return $titlecache{$symb}[0]; + } else { + delete($titlecache{$symb}); + } + } my ($map,$resid,$url)=split(/\_\_\_/,$symb); my $title=''; my %bighash; @@ -3590,7 +3672,7 @@ sub gettitle { } $title=~s/\&colon\;/\:/gs; if ($title) { - $titlecache{$symb}=$title; + $titlecache{$symb}=[$title,time]; return $title; } else { return &metadata($urlsymb,'title'); @@ -3764,6 +3846,10 @@ sub numval { return int($txt); } +sub latest_rnd_algorithm_id { + return '64bit'; +} + sub rndseed { my ($symb,$courseid,$domain,$username)=@_;