--- 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 &currentversion(&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 *