[BACK]Return to lonnet.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / lonnet / perl

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.267.4.7 and 1.273

version 1.267.4.7, 2002/09/17 20:01:30 version 1.273, 2002/08/23 21:31:09
Line 351  sub delenv { Line 351  sub delenv {
 # ------------------------------ Find server with least workload from spare.tab  # ------------------------------ Find server with least workload from spare.tab
   
 sub spareserver {  sub spareserver {
     my $loadpercent = shift;  
     my $tryserver;      my $tryserver;
     my $spareserver='';      my $spareserver='';
     my $lowestserver=$loadpercent;       my $lowestserver=100;
     foreach $tryserver (keys %spareid) {      foreach $tryserver (keys %spareid) {
        my $answer=reply('load',$tryserver);         my $answer=reply('load',$tryserver);
        if (($answer =~ /\d/) && ($answer<$lowestserver)) {         if (($answer =~ /\d/) && ($answer<$lowestserver)) {
Line 762  sub userfileupload { Line 761  sub userfileupload {
         $docudom=$ENV{'user.domain'};          $docudom=$ENV{'user.domain'};
         $docuhome=$ENV{'user.home'};          $docuhome=$ENV{'user.home'};
     }      }
       return 
           &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);
   }
   
   sub finishuserfileupload {
       my ($docuname,$docudom,$docuhome,$formname,$fname)=@_;
     my $path=$docudom.'/'.$docuname.'/';      my $path=$docudom.'/'.$docuname.'/';
     my $filepath=$perlvar{'lonDocRoot'};      my $filepath=$perlvar{'lonDocRoot'};
     my @parts=split(/\//,$filepath.'/userfiles/'.$path);      my @parts=split(/\//,$filepath.'/userfiles/'.$path);
Line 1436  sub coursedescription { Line 1441  sub coursedescription {
            while (my ($name,$value) = each %returnhash) {             while (my ($name,$value) = each %returnhash) {
                $envhash{'course.'.$normalid.'.'.$name}=$value;                 $envhash{'course.'.$normalid.'.'.$name}=$value;
            }             }
            $returnhash{'url'}='/res/'.declutter($returnhash{'url'});             $returnhash{'url'}=&clutter($returnhash{'url'});
            $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.             $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
        $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;         $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;
            $envhash{'course.'.$normalid.'.last_cache'}=time;             $envhash{'course.'.$normalid.'.last_cache'}=time;
Line 1564  sub get { Line 1569  sub get {
   
    my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome);     my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome);
    my @pairs=split(/\&/,$rep);     my @pairs=split(/\&/,$rep);
      if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {
        return @pairs;
      }
    my %returnhash=();     my %returnhash=();
    my $i=0;     my $i=0;
    foreach (@$storearr) {     foreach (@$storearr) {
Line 2296  sub writecoursepref { Line 2304  sub writecoursepref {
 # ---------------------------------------------------------- Make/modify course  # ---------------------------------------------------------- Make/modify course
   
 sub createcourse {  sub createcourse {
     my ($udom,$description,$url,$course_server)=@_;      my ($udom,$description,$url,$course_server,$nonstandard)=@_;
     $url=&declutter($url);      $url=&declutter($url);
     my $cid='';      my $cid='';
     unless (&allowed('ccc',$udom)) {      unless (&allowed('ccc',$udom)) {
Line 2328  sub createcourse { Line 2336  sub createcourse {
     if (($uhome eq '') || ($uhome eq 'no_host')) {       if (($uhome eq '') || ($uhome eq 'no_host')) { 
  return 'error: no such course';   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);
   <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,      &writecoursepref($udom.'_'.$uname,
                      ('description' => $description,                       ('description' => $description,
                       'url'         => $url));                        'url'         => $topurl));
     return '/'.$udom.'/'.$uname;      return '/'.$udom.'/'.$uname;
 }  }
   
Line 2431  sub dirlist { Line 2458  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  # -------------------------------------------------------- Value of a Condition
   
 sub directcondval {  sub directcondval {
Line 2538  sub courseresdata { Line 2541  sub courseresdata {
 # --------------------------------------------------------- Value of a Variable  # --------------------------------------------------------- Value of a Variable
   
 sub EXT {  sub EXT {
     my ($varname,$symbparm,$udom,$uname,)=@_;      my ($varname,$symbparm,$udom,$uname)=@_;
   
     unless ($varname) { return ''; }      unless ($varname) { return ''; }
   
Line 2695  sub EXT { Line 2698  sub EXT {
 # --------------------------------------------- last, look in resource metadata  # --------------------------------------------- last, look in resource metadata
   
  $spacequalifierrest=~s/\./\_/;   $spacequalifierrest=~s/\./\_/;
  my $filename;   my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest);
  if (!$symbparm) { $symbparm=&symbread(); }  
  if ($symbparm) {  
     $filename=(split(/\_\_\_/,$symbparm))[2];  
  } else {  
     $filename=$ENV{'request.filename'};  
  }  
  my $metadata=&metadata($filename,$spacequalifierrest);  
  if ($metadata) { return $metadata; }   if ($metadata) { return $metadata; }
  $metadata=&metadata($filename,'parameter_'.$spacequalifierrest);   $metadata=&metadata($ENV{'request.filename'},
       'parameter_'.$spacequalifierrest);
  if ($metadata) { return $metadata; }   if ($metadata) { return $metadata; }
   
 # ------------------------------------------------------------------ Cascade up  # ------------------------------------------------------------------ Cascade up
Line 2753  sub metadata { Line 2750  sub metadata {
 # Look at timestamp of caching  # Look at timestamp of caching
 # Everything is cached by the main uri, libraries are never directly cached  # 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?  # Is this a recursive call for a library?
 #  #
Line 2776  sub metadata { Line 2773  sub metadata {
       my $package=$token->[2]->{'package'};        my $package=$token->[2]->{'package'};
       my $keyroot='';        my $keyroot='';
               if ($prefix) {                if ($prefix) {
   $keyroot.=$prefix;    $keyroot.='_'.$prefix;
               } else {                } else {
                 if (defined($token->[2]->{'part'})) {                   if (defined($token->[2]->{'part'})) { 
                    $keyroot.='_'.$token->[2]->{'part'};                      $keyroot.='_'.$token->[2]->{'part'}; 
Line 2834  sub metadata { Line 2831  sub metadata {
 #  #
 # Importing a library here  # Importing a library here
 #                  #                
    if (defined($depthcount)) { $depthcount++; } else 
                                              { $depthcount=0; }
                  if ($depthcount<20) {                   if ($depthcount<20) {
      my $location=$parser->get_text('/import');       foreach (split(/\,/,&metadata($uri,'keys',
      my $dir=$filename;                                    $parser->get_text('/import'),$unikey,
      $dir=~s|[^/]*$||;                                    $depthcount))) {
      $location=&filelocation($dir,$location);  
      foreach (sort(split(/\,/,&metadata($uri,'keys',  
  $location,$unikey,  
  $depthcount+1)))) {  
                          $metathesekeys{$_}=1;                           $metathesekeys{$_}=1;
      }       }
  }   }
Line 2866  sub metadata { Line 2861  sub metadata {
 # the next is the end of "start tag"  # the next is the end of "start tag"
  }   }
        }         }
        $metacache{$uri.':keys'}=join(',',keys %metathesekeys);  
  &metadata_generate_part0(\%metathesekeys,\%metacache,$uri);   &metadata_generate_part0(\%metathesekeys,\%metacache,$uri);
        $metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys);         $metacache{$uri.':keys'}=join(',',keys %metathesekeys);
        $metacache{$uri.':cachedtimestamp'}=time;         $metacache{$uri.':cachedtimestamp'}=time;
 # this is the end of "was not already recently cached  # this is the end of "was not already recently cached
     }      }
Line 3118  sub receipt { Line 3112  sub receipt {
 # ------------------------------------------------------------ Serves up a file  # ------------------------------------------------------------ Serves up a file
 # returns either the contents of the file or a -1  # returns either the contents of the file or a -1
 sub getfile {  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);    &repcopy($file);
   if (! -e $file ) { return -1; };    if (! -e $file ) { return -1; };
   my $fh=Apache::File->new($file);    my $fh=Apache::File->new($file);
   my $a='';    my $a='';
   while (<$fh>) { $a .=$_; }    while (<$fh>) { $a .=$_; }
   return $a    return $a;
    }
 }  }
   
 sub filelocation {  sub filelocation {
Line 3134  sub filelocation { Line 3139  sub filelocation {
   if ($file=~m:^/~:) { # is a contruction space reference    if ($file=~m:^/~:) { # is a contruction space reference
     $location = $file;      $location = $file;
     $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;      $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
     } elsif ($file=~/^\/*uploaded/) { # is an uploaded file
       $location=$file;
   } else {    } else {
     $file=~s/^$perlvar{'lonDocRoot'}//;      $file=~s/^$perlvar{'lonDocRoot'}//;
     $file=~s:^/*res::;      $file=~s:^/*res::;
Line 3171  sub declutter { Line 3178  sub declutter {
     return $thisfn;      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  # -------------------------------------------------------- Escape Special Chars
   
 sub escape {  sub escape {
Line 3248  BEGIN { Line 3265  BEGIN {
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
        chomp($configline);         chomp($configline);
        if ($configline) {         if (($configline) && ($configline ne $perlvar{'lonHostID'})) {
           $spareid{$configline}=1;            $spareid{$configline}=1;
        }         }
     }      }
Removed from v.1.267.4.7  
changed lines
  Added in v.1.273

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>