--- loncom/lonnet/perl/lonnet.pm 2002/09/03 01:29:35 1.267.4.5
+++ loncom/lonnet/perl/lonnet.pm 2002/10/07 13:50:36 1.292
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.267.4.5 2002/09/03 01:29:35 albertel Exp $
+# $Id: lonnet.pm,v 1.292 2002/10/07 13:50:36 www 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)) {
@@ -620,6 +644,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 +676,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 +707,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 +747,7 @@ sub repcopy {
rename($transname,$filename);
return OK;
}
+ }
}
}
@@ -761,6 +815,12 @@ sub userfileupload {
$docudom=$ENV{'user.domain'};
$docuhome=$ENV{'user.home'};
}
+ return
+ &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);
+}
+
+sub finishuserfileupload {
+ my ($docuname,$docudom,$docuhome,$formname,$fname)=@_;
my $path=$docudom.'/'.$docuname.'/';
my $filepath=$perlvar{'lonDocRoot'};
my @parts=split(/\//,$filepath.'/userfiles/'.$path);
@@ -865,7 +925,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 {
@@ -1435,7 +1495,7 @@ sub coursedescription {
while (my ($name,$value) = each %returnhash) {
$envhash{'course.'.$normalid.'.'.$name}=$value;
}
- $returnhash{'url'}='/res/'.declutter($returnhash{'url'});
+ $returnhash{'url'}=&clutter($returnhash{'url'});
$returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
$ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;
$envhash{'course.'.$normalid.'.last_cache'}=time;
@@ -1563,6 +1623,9 @@ sub get {
my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome);
my @pairs=split(/\&/,$rep);
+ if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {
+ return @pairs;
+ }
my %returnhash=();
my $i=0;
foreach (@$storearr) {
@@ -1953,14 +2016,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
@@ -2295,7 +2359,7 @@ sub writecoursepref {
# ---------------------------------------------------------- Make/modify course
sub createcourse {
- my ($udom,$description,$url,$course_server)=@_;
+ my ($udom,$description,$url,$course_server,$nonstandard)=@_;
$url=&declutter($url);
my $cid='';
unless (&allowed('ccc',$udom)) {
@@ -2327,9 +2391,29 @@ sub createcourse {
if (($uhome eq '') || ($uhome eq 'no_host')) {
return 'error: no such course';
}
+# ----------------------------------------------------------------- Course made
+ my $topurl=$url;
+ unless ($nonstandard) {
+# ------------------------------------------ For standard courses, make top url
+ my $mapurl=&clutter($url);
+ if ($mapurl eq '/res/') { $mapurl=''; }
+ $ENV{'form.initmap'}=(<<ENDINITMAP);
+<map>
+<resource id="1" type="start"></resource>
+<resource id="2" src="$mapurl"></resource>
+<resource id="3" type="finish"></resource>
+<link index="1" from="1" to="2"></link>
+<link index="2" from="2" to="3"></link>
+</map>
+ENDINITMAP
+ $topurl=&declutter(
+ &finishuserfileupload($uname,$udom,$uhome,'initmap','default.sequence')
+ );
+ }
+# ----------------------------------------------------------- Write preferences
&writecoursepref($udom.'_'.$uname,
('description' => $description,
- 'url' => $url));
+ 'url' => $topurl));
return '/'.$udom.'/'.$uname;
}
@@ -2506,6 +2590,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 {
@@ -2527,17 +2619,17 @@ 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
sub EXT {
- my ($varname,$symbparm,$udom,$uname)=@_;
+ my ($varname,$symbparm,$udom,$uname,)=@_;
unless ($varname) { return ''; }
@@ -2678,7 +2770,7 @@ sub EXT {
($seclevelr,$seclevelm,$seclevel,
$courselevelr,$courselevelm,
$courselevel));
- if ($coursereply) { return $coursereply; }
+ if (defined($coursereply)) { return $coursereply; }
# ------------------------------------------------------ third, check map parms
my %parmhash=();
@@ -2694,11 +2786,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') {
@@ -2706,11 +2804,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; }
}
}
@@ -2739,6 +2837,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$//;
#
@@ -2933,7 +3036,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};
}
@@ -3004,7 +3107,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};
}
@@ -3111,13 +3214,24 @@ sub receipt {
# ------------------------------------------------------------ Serves up a file
# returns either the contents of the file or a -1
sub getfile {
- my $file=shift;
+ my $file=shift;
+ if ($file=~/^\/*uploaded\//) { # user file
+ my $ua=new LWP::UserAgent;
+ my $request=new HTTP::Request('GET',&tokenwrapper($file));
+ my $response=$ua->request($request);
+ if ($response->is_success()) {
+ return $response->content;
+ } else {
+ return -1;
+ }
+ } else { # normal file from res space
&repcopy($file);
if (! -e $file ) { return -1; };
my $fh=Apache::File->new($file);
my $a='';
while (<$fh>) { $a .=$_; }
- return $a
+ return $a;
+ }
}
sub filelocation {
@@ -3127,6 +3241,8 @@ sub filelocation {
if ($file=~m:^/~:) { # is a contruction space reference
$location = $file;
$location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
+ } elsif ($file=~/^\/*uploaded/) { # is an uploaded file
+ $location=$file;
} else {
$file=~s/^$perlvar{'lonDocRoot'}//;
$file=~s:^/*res::;
@@ -3164,6 +3280,16 @@ sub declutter {
return $thisfn;
}
+# ------------------------------------------------------------- Clutter up URLs
+
+sub clutter {
+ my $thisfn='/'.&declutter(shift);
+ unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv)\//) {
+ $thisfn='/res'.$thisfn;
+ }
+ return $thisfn;
+}
+
# -------------------------------------------------------- Escape Special Chars
sub escape {
@@ -3241,7 +3367,7 @@ BEGIN {
while (my $configline=<$config>) {
chomp($configline);
- if (($configline) && ($configline ne $perlvar{'lonHostID'})) {
+ if ($configline) {
$spareid{$configline}=1;
}
}
@@ -3289,7 +3415,7 @@ BEGIN {
%metacache=();
-$processmarker=$$.'_'.time.'_'.$perlvar{'lonHostID'};
+$processmarker='_'.time.'_'.$perlvar{'lonHostID'};
$dumpcount=0;
&logtouch();
@@ -3505,7 +3631,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 *