--- loncom/lonnet/perl/lonnet.pm 2002/08/30 18:36:03 1.276 +++ loncom/lonnet/perl/lonnet.pm 2002/10/01 07:59:33 1.288 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.276 2002/08/30 18:36:03 albertel Exp $ +# $Id: lonnet.pm,v 1.288 2002/10/01 07:59:33 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -348,12 +348,36 @@ sub delenv { return 'ok'; } +# ------------------------------------------ Fight off request when overloaded + +sub overloaderror { + my ($r,$checkserver)=@_; + unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; } + my $loadavg; + if ($checkserver eq $perlvar{'lonHostID'}) { + my $loadfile=Apache::File->new('/proc/loadavg'); + $loadavg=<$loadfile>; + $loadavg =~ s/\s.*//g; + $loadavg = 100*$loadavg/$perlvar{'lonLoadLim'}; + } else { + $loadavg=&reply('load',$checkserver); + } + my $overload=$loadavg-100; + if ($overload>0) { + $r->err_headers_out->{'Retry-After'}=$overload; + $r->log_error('Overload of '.$overload.' on '.$checkserver); + return 413; + } + return ''; +} + # ------------------------------ Find server with least workload from spare.tab sub spareserver { + my $loadpercent = shift; my $tryserver; my $spareserver=''; - my $lowestserver=100; + my $lowestserver=$loadpercent; foreach $tryserver (keys %spareid) { my $answer=reply('load',$tryserver); if (($answer =~ /\d/) && ($answer<$lowestserver)) { @@ -871,7 +895,7 @@ sub countacc { my $url=&declutter(shift); unless ($ENV{'request.course.id'}) { return ''; } $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1; - my $key=$processmarker.'_'.$dumpcount.'___'.$url.'___count'; + my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count'; if (defined($accesshash{$key})) { $accesshash{$key}++; } else { @@ -2341,6 +2365,7 @@ sub createcourse { unless ($nonstandard) { # ------------------------------------------ For standard courses, make top url my $mapurl=&clutter($url); + if ($mapurl eq '/res/') { $mapurl=''; } $ENV{'form.initmap'}=(< @@ -2534,6 +2559,14 @@ sub condval { return $result; } +# ---------------------------------------------------- Devalidate courseresdata + +sub devalidatecourseresdata { + my ($coursenum,$coursedomain)=@_; + my $hashid=$coursenum.':'.$coursedomain; + delete $courseresdatacache{$hashid.'.time'}; +} + # --------------------------------------------------- Course Resourcedata Query sub courseresdata { @@ -2555,7 +2588,7 @@ sub courseresdata { } } foreach my $item (@which) { - if ($courseresdatacache{$hashid}->{$item}) { + if (defined($courseresdatacache{$hashid}->{$item})) { return $courseresdatacache{$hashid}->{$item}; } } @@ -2565,7 +2598,7 @@ sub courseresdata { # --------------------------------------------------------- Value of a Variable sub EXT { - my ($varname,$symbparm,$udom,$uname)=@_; + my ($varname,$symbparm,$udom,$uname,)=@_; unless ($varname) { return ''; } @@ -2706,7 +2739,7 @@ sub EXT { ($seclevelr,$seclevelm,$seclevel, $courselevelr,$courselevelm, $courselevel)); - if ($coursereply) { return $coursereply; } + if (defined($coursereply)) { return $coursereply; } # ------------------------------------------------------ third, check map parms my %parmhash=(); @@ -2722,11 +2755,17 @@ sub EXT { # --------------------------------------------- last, look in resource metadata $spacequalifierrest=~s/\./\_/; - my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest); - if ($metadata) { return $metadata; } - $metadata=&metadata($ENV{'request.filename'}, - 'parameter_'.$spacequalifierrest); - if ($metadata) { return $metadata; } + my $filename; + if (!$symbparm) { $symbparm=&symbread(); } + if ($symbparm) { + $filename=(split(/\_\_\_/,$symbparm))[2]; + } else { + $filename=$ENV{'request.filename'}; + } + my $metadata=&metadata($filename,$spacequalifierrest); + if (defined($metadata)) { return $metadata; } + $metadata=&metadata($filename,'parameter_'.$spacequalifierrest); + if (defined($metadata)) { return $metadata; } # ------------------------------------------------------------------ Cascade up unless ($space eq '0') { @@ -2734,11 +2773,11 @@ sub EXT { if ($id) { my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, $symbparm,$udom,$uname); - if ($partgeneral) { return $partgeneral; } + if (defined($partgeneral)) { return $partgeneral; } } else { my $resourcegeneral=&EXT('resource.0.'.$qualifierrest, $symbparm,$udom,$uname); - if ($resourcegeneral) { return $resourcegeneral; } + if (defined($resourcegeneral)) { return $resourcegeneral; } } } @@ -2767,6 +2806,11 @@ sub metadata { my ($uri,$what,$liburi,$prefix,$depthcount)=@_; $uri=&declutter($uri); + # if it is a non metadata possible uri return quickly + if (($uri eq '') || ($uri =~ m|^/*adm/|) || ($uri =~ m|/$|) || + ($uri =~ m|/.meta$|)) { + return ''; + } my $filename=$uri; $uri=~s/\.meta$//; # @@ -2774,7 +2818,7 @@ sub metadata { # Look at timestamp of caching # Everything is cached by the main uri, libraries are never directly cached # - unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600) { + unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600 && !defined($liburi)) { # # Is this a recursive call for a library? # @@ -2961,7 +3005,7 @@ sub symbverify { my $okay=0; if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', &GDBM_READER(),0640)) { - my $ids=$bighash{'ids_/res/'.$thisfn}; + my $ids=$bighash{'ids_'.&clutter($thisfn)}; unless ($ids) { $ids=$bighash{'ids_/'.$thisfn}; } @@ -3032,7 +3076,7 @@ sub symbread { if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', &GDBM_READER(),0640)) { # ---------------------------------------------- Get ID(s) for current resource - my $ids=$bighash{'ids_/res/'.$thisfn}; + my $ids=$bighash{'ids_'.&clutter($thisfn)}; unless ($ids) { $ids=$bighash{'ids_/'.$thisfn}; } @@ -3292,7 +3336,7 @@ BEGIN { while (my $configline=<$config>) { chomp($configline); - if (($configline) && ($configline ne $perlvar{'lonHostID'})) { + if ($configline) { $spareid{$configline}=1; } } @@ -3340,7 +3384,7 @@ BEGIN { %metacache=(); -$processmarker=$$.'_'.time.'_'.$perlvar{'lonHostID'}; +$processmarker='_'.time.'_'.$perlvar{'lonHostID'}; $dumpcount=0; &logtouch(); @@ -3556,7 +3600,48 @@ modify user =item * -modifystudent($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,$end,$start) : modify student +modifystudent + +modify a students enrollment and identification information. +The course id is resolved based on the current users environment. +This means the envoking user must be a course coordinator or otherwise +associated with a course. + +This call is essentially a wrapper for lonnet::modifyuser + +Inputs: + +=over 4 + +=item B<$udom> Students loncapa domain + +=item B<$uname> Students loncapa login name + +=item B<$uid> Students id/student number + +=item B<$umode> Students authentication mode + +=item B<$upass> Students password + +=item B<$first> Students first name + +=item B<$middle> Students middle name + +=item B<$last> Students last name + +=item B<$gene> Students generation + +=item B<$usec> Students section in course + +=item B<$end> Unix time of the roles expiration + +=item B<$start> Unix time of the roles start date + +=item B<$forceid> If defined, allow $uid to be changed + +=item B<$desiredhome> server to use as home server for student + +=back =item *