--- loncom/lonnet/perl/lonnet.pm 2002/09/17 20:01:30 1.267.4.7 +++ loncom/lonnet/perl/lonnet.pm 2002/08/23 21:31:09 1.273 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.267.4.7 2002/09/17 20:01:30 matthew Exp $ +# $Id: lonnet.pm,v 1.273 2002/08/23 21:31:09 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -351,10 +351,9 @@ sub delenv { # ------------------------------ Find server with least workload from spare.tab sub spareserver { - my $loadpercent = shift; my $tryserver; my $spareserver=''; - my $lowestserver=$loadpercent; + my $lowestserver=100; foreach $tryserver (keys %spareid) { my $answer=reply('load',$tryserver); if (($answer =~ /\d/) && ($answer<$lowestserver)) { @@ -762,6 +761,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); @@ -1436,7 +1441,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; @@ -1564,6 +1569,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) { @@ -2296,7 +2304,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)) { @@ -2328,9 +2336,28 @@ 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); + $ENV{'form.initmap'}=(< + + + + + + +ENDINITMAP + $topurl=&declutter( + &finishuserfileupload($uname,$udom,$uhome,'initmap','default.sequence') + ); + } +# ----------------------------------------------------------- Write preferences &writecoursepref($udom.'_'.$uname, ('description' => $description, - 'url' => $url)); + 'url' => $topurl)); return '/'.$udom.'/'.$uname; } @@ -2431,30 +2458,6 @@ sub dirlist { } } -# --------------------------------------------- GetFileTimestamp -# This function utilizes dirlist and returns the date stamp for -# when it was last modified. It will also return an error of -1 -# if an error occurs - -sub GetFileTimestamp { - my ($studentDomain,$studentName,$filename,$root)=@_; - $studentDomain=~s/\W//g; - $studentName=~s/\W//g; - my $subdir=$studentName.'__'; - $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 @stats = split('&', $fileStat); - if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { - return $stats[9]; - } else { - return -1; - } -} - # -------------------------------------------------------- Value of a Condition sub directcondval { @@ -2538,7 +2541,7 @@ sub courseresdata { # --------------------------------------------------------- Value of a Variable sub EXT { - my ($varname,$symbparm,$udom,$uname,)=@_; + my ($varname,$symbparm,$udom,$uname)=@_; unless ($varname) { return ''; } @@ -2695,16 +2698,10 @@ sub EXT { # --------------------------------------------- last, look in resource metadata $spacequalifierrest=~s/\./\_/; - my $filename; - if (!$symbparm) { $symbparm=&symbread(); } - if ($symbparm) { - $filename=(split(/\_\_\_/,$symbparm))[2]; - } else { - $filename=$ENV{'request.filename'}; - } - my $metadata=&metadata($filename,$spacequalifierrest); + my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest); if ($metadata) { return $metadata; } - $metadata=&metadata($filename,'parameter_'.$spacequalifierrest); + $metadata=&metadata($ENV{'request.filename'}, + 'parameter_'.$spacequalifierrest); if ($metadata) { return $metadata; } # ------------------------------------------------------------------ Cascade up @@ -2753,7 +2750,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 && !defined($liburi)) { + unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600) { # # Is this a recursive call for a library? # @@ -2776,7 +2773,7 @@ sub metadata { my $package=$token->[2]->{'package'}; my $keyroot=''; if ($prefix) { - $keyroot.=$prefix; + $keyroot.='_'.$prefix; } else { if (defined($token->[2]->{'part'})) { $keyroot.='_'.$token->[2]->{'part'}; @@ -2834,14 +2831,12 @@ sub metadata { # # Importing a library here # + if (defined($depthcount)) { $depthcount++; } else + { $depthcount=0; } if ($depthcount<20) { - my $location=$parser->get_text('/import'); - my $dir=$filename; - $dir=~s|[^/]*$||; - $location=&filelocation($dir,$location); - foreach (sort(split(/\,/,&metadata($uri,'keys', - $location,$unikey, - $depthcount+1)))) { + foreach (split(/\,/,&metadata($uri,'keys', + $parser->get_text('/import'),$unikey, + $depthcount))) { $metathesekeys{$_}=1; } } @@ -2866,9 +2861,8 @@ sub metadata { # the next is the end of "start tag" } } - $metacache{$uri.':keys'}=join(',',keys %metathesekeys); &metadata_generate_part0(\%metathesekeys,\%metacache,$uri); - $metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys); + $metacache{$uri.':keys'}=join(',',keys %metathesekeys); $metacache{$uri.':cachedtimestamp'}=time; # this is the end of "was not already recently cached } @@ -3118,13 +3112,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 { @@ -3134,6 +3139,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::; @@ -3171,6 +3178,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 { @@ -3248,7 +3265,7 @@ BEGIN { while (my $configline=<$config>) { chomp($configline); - if ($configline) { + if (($configline) && ($configline ne $perlvar{'lonHostID'})) { $spareid{$configline}=1; } }