--- loncom/lonnet/perl/lonnet.pm 2002/09/16 19:42:10 1.282
+++ loncom/lonnet/perl/lonnet.pm 2002/10/10 13:06:08 1.295
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.282 2002/09/16 19:42:10 albertel Exp $
+# $Id: lonnet.pm,v 1.295 2002/10/10 13:06:08 www Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -86,6 +86,8 @@ use GDBM_File;
use Apache::Constants qw(:common :http);
use HTML::LCParser;
use Fcntl qw(:flock);
+use Apache::loncoursedata;
+
my $readit;
# --------------------------------------------------------------------- Logging
@@ -348,12 +350,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)) {
@@ -620,6 +646,30 @@ sub chatsend {
&escape($newentry)),$chome);
}
+# ------------------------------------------ Find current version of a resource
+
+sub getversion {
+ my $fname=&clutter(shift);
+ unless ($fname=~/^\/res\//) { return -1; }
+ return ¤tversion(&filelocation('',$fname));
+}
+
+sub currentversion {
+ my $fname=shift;
+ my $author=$fname;
+ $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
+ my ($udom,$uname)=split(/\//,$author);
+ my $home=homeserver($uname,$udom);
+ if ($home eq 'no_host') {
+ return -1;
+ }
+ my $answer=reply("currentversion:$fname",$home);
+ if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
+ return -1;
+ }
+ return $answer;
+}
+
# ----------------------------- Subscribe to a resource, return URL if possible
sub subscribe {
@@ -628,7 +678,7 @@ sub subscribe {
$author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
my ($udom,$uname)=split(/\//,$author);
my $home=homeserver($uname,$udom);
- if (($home eq 'no_host') || ($home eq $perlvar{'lonHostID'})) {
+ if ($home eq 'no_host') {
return 'not_found';
}
my $answer=reply("sub:$fname",$home);
@@ -659,6 +709,11 @@ sub repcopy {
} elsif ($remoteurl eq 'directory') {
return OK;
} else {
+ my $author=$filename;
+ $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
+ my ($udom,$uname)=split(/\//,$author);
+ my $home=homeserver($uname,$udom);
+ unless ($home eq $perlvar{'lonHostID'}) {
my @parts=split(/\//,$filename);
my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
if ($path ne "$perlvar{'lonDocRoot'}/res") {
@@ -694,6 +749,7 @@ sub repcopy {
rename($transname,$filename);
return OK;
}
+ }
}
}
@@ -784,13 +840,16 @@ sub finishuserfileupload {
}
# Notify homeserver to grep it
#
- if
-(&reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome) eq 'ok')
- {
+
+ my $fetchresult=
+ &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome);
+ if ($fetchresult eq 'ok') {
#
# Return the URL to it
return '/uploaded/'.$path.$fname;
} else {
+ &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$fname.
+ ' to host '.$docuhome.': '.$fetchresult);
return '/adm/notfound.html';
}
}
@@ -1962,14 +2021,15 @@ sub is_on_map {
my @uriparts=split(/\//,$uri);
my $filename=$uriparts[$#uriparts];
my $pathname=$uri;
- $pathname=~s/\/$filename$//;
+ $pathname=~s|/\Q$filename\E$||;
+ #Trying to find the conditional for the file
my $match=($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
- /\&$filename\:([\d\|]+)\&/);
+ /\&\Q$filename\E\:([\d\|]+)\&/);
if ($match) {
- return (1,$1);
- } else {
- return (0,0);
- }
+ return (1,$1);
+ } else {
+ return (0,0);
+ }
}
# ----------------------------------------------------------------- Define Role
@@ -2265,10 +2325,24 @@ sub modifystudent {
return 'error: no such user';
}
# -------------------------------------------------- Add student to course list
+ if ($first eq '' || $last eq '' || $uid eq '') {
+ # They did not supply us with enough data to enroll the student, so
+ # we need to pick up more information.
+ my %tmp = dump('environment',$udom,$uname,
+ ['firstname','middlename','lastname', 'generation','id']
+ );
+ $first = $tmp{'firstname'} if (!defined($first) || $first eq '');
+ $middle = $tmp{'middlename'} if (!defined($middle) || $middle eq '');
+ $last = $tmp{'lastname'} if (!defined($last) || $last eq '');
+ $gene = $tmp{'genename'} if (!defined($gene) || $gene eq '');
+ $uid = $tmp{'id'} if (!defined($uid) || $uid eq '');
+ }
+ my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene,
+ $first,$middle);
$reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'.
$ENV{'course.'.$cid.'.num'}.':classlist:'.
&escape($uname.':'.$udom).'='.
- &escape($end.':'.$start),
+ &escape(join(':',$end,$start,$uid,$usec,$fullname)),
$ENV{'course.'.$cid.'.home'});
unless (($reply eq 'ok') || ($reply eq 'delayed')) {
return 'error: '.$reply;
@@ -2564,11 +2638,11 @@ sub courseresdata {
}
}
foreach my $item (@which) {
- if ($courseresdatacache{$hashid}->{$item}) {
+ if (defined($courseresdatacache{$hashid}->{$item})) {
return $courseresdatacache{$hashid}->{$item};
}
}
- return '';
+ return undef;
}
# --------------------------------------------------------- Value of a Variable
@@ -2715,7 +2789,7 @@ sub EXT {
($seclevelr,$seclevelm,$seclevel,
$courselevelr,$courselevelm,
$courselevel));
- if ($coursereply) { return $coursereply; }
+ if (defined($coursereply)) { return $coursereply; }
# ------------------------------------------------------ third, check map parms
my %parmhash=();
@@ -2739,9 +2813,9 @@ sub EXT {
$filename=$ENV{'request.filename'};
}
my $metadata=&metadata($filename,$spacequalifierrest);
- if ($metadata) { return $metadata; }
+ if (defined($metadata)) { return $metadata; }
$metadata=&metadata($filename,'parameter_'.$spacequalifierrest);
- if ($metadata) { return $metadata; }
+ if (defined($metadata)) { return $metadata; }
# ------------------------------------------------------------------ Cascade up
unless ($space eq '0') {
@@ -2749,11 +2823,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; }
}
}
@@ -2782,6 +2856,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|^adm/includes|)) ||
+ ($uri =~ m|/$|) || ($uri =~ m|/.meta$|)) {
+ return '';
+ }
my $filename=$uri;
$uri=~s/\.meta$//;
#
@@ -3307,7 +3386,7 @@ BEGIN {
while (my $configline=<$config>) {
chomp($configline);
- if (($configline) && ($configline ne $perlvar{'lonHostID'})) {
+ if ($configline) {
$spareid{$configline}=1;
}
}
@@ -3571,7 +3650,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 *