[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.268

version 1.267.4.7, 2002/09/17 20:01:30 version 1.268, 2002/08/17 18:23:27
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 2138  sub modifyuserauth { Line 2137  sub modifyuserauth {
     my $uhome=&homeserver($uname,$udom);      my $uhome=&homeserver($uname,$udom);
     unless (&allowed('mau',$udom)) { return 'refused'; }      unless (&allowed('mau',$udom)) { return 'refused'; }
     &logthis('Call to modify user authentication '.$udom.', '.$uname.', '.      &logthis('Call to modify user authentication '.$udom.', '.$uname.', '.
              $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}.               $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'});  
              ' in domain '.$ENV{'request.role.domain'});    
     my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.      my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.
      &escape($upass),$uhome);       &escape($upass),$uhome);
     &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'},      &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'},
Line 2170  sub modifyuser { Line 2168  sub modifyuser {
      $last.', '.$gene.'(forceid: '.$forceid.')'.       $last.', '.$gene.'(forceid: '.$forceid.')'.
              (defined($desiredhome) ? ' desiredhome = '.$desiredhome :               (defined($desiredhome) ? ' desiredhome = '.$desiredhome :
                                      ' desiredhome not specified').                                        ' desiredhome not specified'). 
              ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'}.               ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'});
              ' in domain '.$ENV{'request.role.domain'});  
     my $uhome=&homeserver($uname,$udom,'true');      my $uhome=&homeserver($uname,$udom,'true');
 # ----------------------------------------------------------------- Create User  # ----------------------------------------------------------------- Create User
     if (($uhome eq 'no_host') && ($umode) && ($upass)) {      if (($uhome eq 'no_host') && ($umode) && ($upass)) {
Line 2431  sub dirlist { Line 2428  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 2511  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 2668  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 2720  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 2743  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 2801  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 2831  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 3171  sub declutter { Line 3135  sub declutter {
     return $thisfn;      return $thisfn;
 }  }
   
   # ------------------------------------------------------------- Clutter up URLs
   
   sub clutter {
       my $thisfn='/'.&declutter(shift);
       unless ($thisfn=~/^\/(uploaded|adm)\//) { $thisfn='/res'.$thisfn; }
       return $thisfn;
   }
   
 # -------------------------------------------------------- Escape Special Chars  # -------------------------------------------------------- Escape Special Chars
   
 sub escape {  sub escape {
Line 3248  BEGIN { Line 3220  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.268

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