[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.276 and 1.293

version 1.276, 2002/08/30 18:36:03 version 1.293, 2002/10/07 20:24:38
Line 348  sub delenv { Line 348  sub delenv {
     return 'ok';      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  # ------------------------------ 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=100;      my $lowestserver=$loadpercent; 
     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 620  sub chatsend { Line 644  sub chatsend {
    &escape($newentry)),$chome);     &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  # ----------------------------- Subscribe to a resource, return URL if possible
   
 sub subscribe {  sub subscribe {
Line 628  sub subscribe { Line 676  sub subscribe {
     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;      $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
     my ($udom,$uname)=split(/\//,$author);      my ($udom,$uname)=split(/\//,$author);
     my $home=homeserver($uname,$udom);      my $home=homeserver($uname,$udom);
     if (($home eq 'no_host') || ($home eq $perlvar{'lonHostID'})) {       if ($home eq 'no_host') { 
         return 'not_found';           return 'not_found'; 
     }      }
     my $answer=reply("sub:$fname",$home);      my $answer=reply("sub:$fname",$home);
Line 659  sub repcopy { Line 707  sub repcopy {
     } elsif ($remoteurl eq 'directory') {      } elsif ($remoteurl eq 'directory') {
            return OK;             return OK;
     } else {      } 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 @parts=split(/\//,$filename);
            my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";             my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
            if ($path ne "$perlvar{'lonDocRoot'}/res") {             if ($path ne "$perlvar{'lonDocRoot'}/res") {
Line 694  sub repcopy { Line 747  sub repcopy {
                rename($transname,$filename);                 rename($transname,$filename);
                return OK;                 return OK;
            }             }
          }
     }      }
 }  }
   
Line 871  sub countacc { Line 925  sub countacc {
     my $url=&declutter(shift);      my $url=&declutter(shift);
     unless ($ENV{'request.course.id'}) { return ''; }      unless ($ENV{'request.course.id'}) { return ''; }
     $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1;      $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1;
     my $key=$processmarker.'_'.$dumpcount.'___'.$url.'___count';      my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';
     if (defined($accesshash{$key})) {      if (defined($accesshash{$key})) {
  $accesshash{$key}++;   $accesshash{$key}++;
     } else {      } else {
Line 1962  sub is_on_map { Line 2016  sub is_on_map {
     my @uriparts=split(/\//,$uri);      my @uriparts=split(/\//,$uri);
     my $filename=$uriparts[$#uriparts];      my $filename=$uriparts[$#uriparts];
     my $pathname=$uri;      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}=~      my $match=($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
        /\&$filename\:([\d\|]+)\&/);         /\&\Q$filename\E\:([\d\|]+)\&/);
     if ($match) {      if ($match) {
        return (1,$1);   return (1,$1);
    } else {      } else {
        return (0,0);   return (0,0);
    }      }
 }  }
   
 # ----------------------------------------------------------------- Define Role  # ----------------------------------------------------------------- Define Role
Line 2341  sub createcourse { Line 2396  sub createcourse {
     unless ($nonstandard) {      unless ($nonstandard) {
 # ------------------------------------------ For standard courses, make top url  # ------------------------------------------ For standard courses, make top url
         my $mapurl=&clutter($url);          my $mapurl=&clutter($url);
           if ($mapurl eq '/res/') { $mapurl=''; }
         $ENV{'form.initmap'}=(<<ENDINITMAP);          $ENV{'form.initmap'}=(<<ENDINITMAP);
 <map>  <map>
 <resource id="1" type="start"></resource>  <resource id="1" type="start"></resource>
Line 2534  sub condval { Line 2590  sub condval {
     return $result;      return $result;
 }  }
   
   # ---------------------------------------------------- Devalidate courseresdata
   
   sub devalidatecourseresdata {
       my ($coursenum,$coursedomain)=@_;
       my $hashid=$coursenum.':'.$coursedomain;
       delete $courseresdatacache{$hashid.'.time'};
   }
   
 # --------------------------------------------------- Course Resourcedata Query  # --------------------------------------------------- Course Resourcedata Query
   
 sub courseresdata {  sub courseresdata {
Line 2555  sub courseresdata { Line 2619  sub courseresdata {
  }   }
     }      }
     foreach my $item (@which) {      foreach my $item (@which) {
  if ($courseresdatacache{$hashid}->{$item}) {   if (defined($courseresdatacache{$hashid}->{$item})) {
     return $courseresdatacache{$hashid}->{$item};      return $courseresdatacache{$hashid}->{$item};
  }   }
     }      }
     return '';      return undef;
 }  }
   
 # --------------------------------------------------------- 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 2706  sub EXT { Line 2770  sub EXT {
   ($seclevelr,$seclevelm,$seclevel,    ($seclevelr,$seclevelm,$seclevel,
    $courselevelr,$courselevelm,     $courselevelr,$courselevelm,
    $courselevel));     $courselevel));
     if ($coursereply) { return $coursereply; }      if (defined($coursereply)) { return $coursereply; }
   
 # ------------------------------------------------------ third, check map parms  # ------------------------------------------------------ third, check map parms
     my %parmhash=();      my %parmhash=();
Line 2722  sub EXT { Line 2786  sub EXT {
 # --------------------------------------------- last, look in resource metadata  # --------------------------------------------- last, look in resource metadata
   
  $spacequalifierrest=~s/\./\_/;   $spacequalifierrest=~s/\./\_/;
  my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest);   my $filename;
  if ($metadata) { return $metadata; }   if (!$symbparm) { $symbparm=&symbread(); }
  $metadata=&metadata($ENV{'request.filename'},   if ($symbparm) {
     'parameter_'.$spacequalifierrest);      $filename=(split(/\_\_\_/,$symbparm))[2];
  if ($metadata) { return $metadata; }   } 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  # ------------------------------------------------------------------ Cascade up
  unless ($space eq '0') {   unless ($space eq '0') {
Line 2734  sub EXT { Line 2804  sub EXT {
     if ($id) {      if ($id) {
  my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,   my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
      $symbparm,$udom,$uname);       $symbparm,$udom,$uname);
  if ($partgeneral) { return $partgeneral; }   if (defined($partgeneral)) { return $partgeneral; }
     } else {      } else {
  my $resourcegeneral=&EXT('resource.0.'.$qualifierrest,   my $resourcegeneral=&EXT('resource.0.'.$qualifierrest,
  $symbparm,$udom,$uname);   $symbparm,$udom,$uname);
  if ($resourcegeneral) { return $resourcegeneral; }   if (defined($resourcegeneral)) { return $resourcegeneral; }
     }      }
  }   }
   
Line 2767  sub metadata { Line 2837  sub metadata {
     my ($uri,$what,$liburi,$prefix,$depthcount)=@_;      my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
   
     $uri=&declutter($uri);      $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;      my $filename=$uri;
     $uri=~s/\.meta$//;      $uri=~s/\.meta$//;
 #  #
Line 2774  sub metadata { Line 2849  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) {      unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600 && !defined($liburi)) {
 #  #
 # Is this a recursive call for a library?  # Is this a recursive call for a library?
 #  #
Line 2961  sub symbverify { Line 3036  sub symbverify {
     my $okay=0;      my $okay=0;
     if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',      if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
                             &GDBM_READER(),0640)) {                              &GDBM_READER(),0640)) {
         my $ids=$bighash{'ids_/res/'.$thisfn};          my $ids=$bighash{'ids_'.&clutter($thisfn)};
         unless ($ids) {           unless ($ids) { 
            $ids=$bighash{'ids_/'.$thisfn};             $ids=$bighash{'ids_/'.$thisfn};
         }          }
Line 3032  sub symbread { Line 3107  sub symbread {
            if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',             if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
                             &GDBM_READER(),0640)) {                              &GDBM_READER(),0640)) {
 # ---------------------------------------------- Get ID(s) for current resource  # ---------------------------------------------- Get ID(s) for current resource
               my $ids=$bighash{'ids_/res/'.$thisfn};                my $ids=$bighash{'ids_'.&clutter($thisfn)};
               unless ($ids) {                 unless ($ids) { 
                  $ids=$bighash{'ids_/'.$thisfn};                   $ids=$bighash{'ids_/'.$thisfn};
               }                }
Line 3292  BEGIN { Line 3367  BEGIN {
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
        chomp($configline);         chomp($configline);
        if (($configline) && ($configline ne $perlvar{'lonHostID'})) {         if ($configline) {
           $spareid{$configline}=1;            $spareid{$configline}=1;
        }         }
     }      }
Line 3340  BEGIN { Line 3415  BEGIN {
   
 %metacache=();  %metacache=();
   
 $processmarker=$$.'_'.time.'_'.$perlvar{'lonHostID'};  $processmarker='_'.time.'_'.$perlvar{'lonHostID'};
 $dumpcount=0;  $dumpcount=0;
   
 &logtouch();  &logtouch();
Line 3556  modify user Line 3631  modify user
   
 =item *  =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 *  =item *
   
Removed from v.1.276  
changed lines
  Added in v.1.293

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