[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.430 and 1.440

version 1.430, 2003/10/12 22:02:44 version 1.440, 2003/11/01 18:34:49
Line 25 Line 25
 #  #
 # http://www.lon-capa.org/  # http://www.lon-capa.org/
 #  #
 # 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30,  
 # 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19,  
 # 11/8,11/16,11/18,11/22,11/23,12/22,  
 # 01/06,01/13,02/24,02/28,02/29,  
 # 03/01,03/02,03/06,03/07,03/13,  
 # 04/05,05/29,05/31,06/01,  
 # 06/05,06/26 Gerd Kortemeyer  
 # 06/26 Ben Tyszka  
 # 06/30,07/15,07/17,07/18,07/20,07/21,07/22,07/25 Gerd Kortemeyer  
 # 08/14 Ben Tyszka  
 # 08/22,08/28,08/31,09/01,09/02,09/04,09/05,09/25,09/28,09/30 Gerd Kortemeyer  
 # 10/04 Gerd Kortemeyer  
 # 10/04 Guy Albertelli  
 # 10/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29,   
 # 10/30,10/31,  
 # 11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25,11/27,  
 # 12/02,12/12,12/13,12/14,12/28,12/29 Gerd Kortemeyer  
 # 05/01/01 Guy Albertelli  
 # 05/01,06/01,09/01 Gerd Kortemeyer  
 # 09/01 Guy Albertelli  
 # 09/01,10/01,11/01 Gerd Kortemeyer  
 # YEAR=2001  
 # 3/2 Gerd Kortemeyer  
 # 3/19,3/20 Gerd Kortemeyer  
 # 5/26,5/28 Gerd Kortemeyer  
 # 5/30 H. K. Ng  
 # 6/1 Gerd Kortemeyer  
 # July Guy Albertelli  
 # 8/4,8/7,8/8,8/9,8/11,8/16,8/17,8/18,8/20,8/23,9/20,9/21,9/26,  
 # 10/2 Gerd Kortemeyer  
 # 11/17,11/20,11/22,11/29 Gerd Kortemeyer  
 # 12/5 Matthew Hall  
 # 12/5 Guy Albertelli  
 # 12/6,12/7,12/12 Gerd Kortemeyer  
 # 12/21,12/22,12/27,12/28 Gerd Kortemeyer  
 # YEAR=2002  
 # 1/4,2/4,2/7 Gerd Kortemeyer  
 #  
 ###  ###
   
 package Apache::lonnet;  package Apache::lonnet;
Line 73  use LWP::UserAgent(); Line 35  use LWP::UserAgent();
 use HTTP::Headers;  use HTTP::Headers;
 use vars   use vars 
 qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom   qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom 
    %libserv %pr %prp %metacache %packagetab %titlecache      %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache
    %courselogs %accesshash %userrolehash $processmarker $dumpcount      %courselogs %accesshash %userrolehash $processmarker $dumpcount 
    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache      %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache 
    %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def      %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def 
Line 274  sub transfer_profile_to_env { Line 236  sub transfer_profile_to_env {
  $idf->close();   $idf->close();
     }      }
     my $envi;      my $envi;
       my %Remove;
     for ($envi=0;$envi<=$#profile;$envi++) {      for ($envi=0;$envi<=$#profile;$envi++) {
  chomp($profile[$envi]);   chomp($profile[$envi]);
  my ($envname,$envvalue)=split(/=/,$profile[$envi]);   my ($envname,$envvalue)=split(/=/,$profile[$envi]);
  $ENV{$envname} = $envvalue;   $ENV{$envname} = $envvalue;
           if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
               if ($time < time-300) {
                   $Remove{$key}++;
               }
           }
       }
       foreach my $expired_key (keys(%Remove)) {
           &delenv($expired_key);
     }      }
     $ENV{'user.environment'} = "$lonidsdir/$handle.id";      $ENV{'user.environment'} = "$lonidsdir/$handle.id";
 }  }
Line 396  sub userload { Line 367  sub userload {
  while ($filename=readdir(LONIDS)) {   while ($filename=readdir(LONIDS)) {
     if ($filename eq '.' || $filename eq '..') {next;}      if ($filename eq '.' || $filename eq '..') {next;}
     my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];      my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
     if ($curtime-$mtime < 3600) { $numusers++; }      if ($curtime-$mtime < 1800) { $numusers++; }
  }   }
  closedir(LONIDS);   closedir(LONIDS);
     }      }
Line 860  sub devalidate_cache { Line 831  sub devalidate_cache {
  delete($hash{$id});   delete($hash{$id});
  delete($hash{$id.'.time'});   delete($hash{$id.'.time'});
     } else {      } else {
  &logthis("Unable to tie hash");   &logthis("Unable to tie hash (devalidate cache): $name");
     }      }
     untie(%hash);      untie(%hash);
     flock(DB,LOCK_UN);      flock(DB,LOCK_UN);
Line 878  sub is_cached { Line 849  sub is_cached {
  return (undef,undef);   return (undef,undef);
     } else {      } else {
  if (time-($$cache{$id.'.time'})>$time) {   if (time-($$cache{$id.'.time'})>$time) {
 #    &logthis("Devailidating $id - ".time-($$cache{$id.'.time'}));  #    &logthis("Devalidating $id - ".time-($$cache{$id.'.time'}));
     &devalidate_cache($cache,$id,$name);      &devalidate_cache($cache,$id,$name);
     return (undef,undef);      return (undef,undef);
  }   }
Line 958  sub save_cache_item { Line 929  sub save_cache_item {
  $hash{$id.'.time'}=$$cache{$id.'.time'};   $hash{$id.'.time'}=$$cache{$id.'.time'};
  $hash{$id}=freeze({'item'=>$$cache{$id}});   $hash{$id}=freeze({'item'=>$$cache{$id}});
     } else {      } else {
  &logthis("Unable to tie hash");   &logthis("Unable to tie hash (save cache item): $name");
     }      }
     untie(%hash);      untie(%hash);
     flock(DB,LOCK_UN);      flock(DB,LOCK_UN);
Line 993  sub load_cache_item { Line 964  sub load_cache_item {
     $$cache{$id.'.time'}=$hash{$id.'.time'};      $$cache{$id.'.time'}=$hash{$id.'.time'};
  }   }
     } else {      } else {
  &logthis("Unable to tie hash");   &logthis("Unable to tie hash (load cache item): $name");
     }      }
     untie(%hash);      untie(%hash);
     flock(DB,LOCK_UN);      flock(DB,LOCK_UN);
Line 1071  sub getversion { Line 1042  sub getversion {
   
 sub currentversion {  sub currentversion {
     my $fname=shift;      my $fname=shift;
       my ($result,$cached)=&is_cached(\%resversioncache,$fname,'resversion',600);
       if (defined($cached)) { return $result; }
     my $author=$fname;      my $author=$fname;
     $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);
Line 1082  sub currentversion { Line 1055  sub currentversion {
     if (($answer eq 'con_lost') || ($answer eq 'rejected')) {      if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
  return -1;   return -1;
     }      }
     return $answer;      return &do_cache(\%resversioncache,$fname,$answer,'resversion');
 }  }
   
 # ----------------------------- Subscribe to a resource, return URL if possible  # ----------------------------- Subscribe to a resource, return URL if possible
Line 2478  sub customaccess { Line 2451  sub customaccess {
   
 sub allowed {  sub allowed {
     my ($priv,$uri)=@_;      my ($priv,$uri)=@_;
       $uri=&deversion($uri);
     my $orguri=$uri;      my $orguri=$uri;
     $uri=&declutter($uri);      $uri=&declutter($uri);
   
Line 2763  sub allowed { Line 2736  sub allowed {
   
 sub is_on_map {  sub is_on_map {
     my $uri=&declutter(shift);      my $uri=&declutter(shift);
       $uri=~s/\.\d+\.(\w+)$/\.$1/;
     my @uriparts=split(/\//,$uri);      my @uriparts=split(/\//,$uri);
     my $filename=$uriparts[$#uriparts];      my $filename=$uriparts[$#uriparts];
     my $pathname=$uri;      my $pathname=$uri;
Line 2774  sub is_on_map { Line 2748  sub is_on_map {
     if ($match) {      if ($match) {
  return (1,$1);   return (1,$1);
     } else {      } else {
  my ($name,$ext)=($filename=~/^(.+)\.(\w+)$/);   return (0,0);
         $ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~  
        /\&(\Q$name\E\.\d+\.$ext)\:([\d\|]+)\&/;  
  return (0,$2,$pathname.'/'.$1);  
     }      }
 }  }
   
Line 3848  sub metadata { Line 3819  sub metadata {
  $lcmetacache{':packages'}=$package.$keyroot;   $lcmetacache{':packages'}=$package.$keyroot;
     }      }
     foreach (keys %packagetab) {      foreach (keys %packagetab) {
  if ($_=~/^$package\&/) {   my $part=$keyroot;
    $part=~s/^\_//;
    if ($_=~/^\Q$package\E\&/ || 
       $_=~/^\Q$package\E_0\&/) {
     my ($pack,$name,$subp)=split(/\&/,$_);      my ($pack,$name,$subp)=split(/\&/,$_);
     # ignore package.tab specified default values      # ignore package.tab specified default values
                             # here &package_tab_default() will fetch those                              # here &package_tab_default() will fetch those
     if ($subp eq 'default') { next; }      if ($subp eq 'default') { next; }
     my $value=$packagetab{$_};      my $value=$packagetab{$_};
     my $part=$keyroot;      my $unikey;
     $part=~s/^\_//;      if ($pack =~ /_0$/) {
    $unikey='parameter_0_'.$name;
    $part=0;
       } else {
    $unikey='parameter'.$keyroot.'_'.$name;
       }
     if ($subp eq 'display') {      if ($subp eq 'display') {
  $value.=' [Part: '.$part.']';   $value.=' [Part: '.$part.']';
     }      }
     my $unikey='parameter'.$keyroot.'_'.$name;  
     $lcmetacache{':'.$unikey.'.part'}=$part;      $lcmetacache{':'.$unikey.'.part'}=$part;
     $metathesekeys{$unikey}=1;      $metathesekeys{$unikey}=1;
     unless (defined($lcmetacache{':'.$unikey.'.'.$subp})) {      unless (defined($lcmetacache{':'.$unikey.'.'.$subp})) {
Line 4017  sub gettitle { Line 3995  sub gettitle {
   
 sub symblist {  sub symblist {
     my ($mapname,%newhash)=@_;      my ($mapname,%newhash)=@_;
     $mapname=declutter($mapname);      $mapname=&deversion(&declutter($mapname));
     my %hash;      my %hash;
     if (($ENV{'request.course.fn'}) && (%newhash)) {      if (($ENV{'request.course.fn'}) && (%newhash)) {
         if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',          if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
                       &GDBM_WRCREAT(),0640)) {                        &GDBM_WRCREAT(),0640)) {
     foreach (keys %newhash) {      foreach (keys %newhash) {
                 $hash{declutter($_)}=$mapname.'___'.$newhash{$_};                  $hash{declutter($_)}=$mapname.'___'.&deversion($newhash{$_});
             }              }
             if (untie(%hash)) {              if (untie(%hash)) {
  return 'ok';   return 'ok';
Line 4042  sub symbverify { Line 4020  sub symbverify {
     if ($thisfn=~/\.(page|sequence)$/) { return 1; }      if ($thisfn=~/\.(page|sequence)$/) { return 1; }
 # check URL part  # check URL part
     my ($map,$resid,$url)=&decode_symb($symb);      my ($map,$resid,$url)=&decode_symb($symb);
     unless (&symbclean($url) eq &symbclean($thisfn)) { return 0; }  
       unless ($url eq $thisfn) { return 0; }
   
     $symb=&symbclean($symb);      $symb=&symbclean($symb);
       $thisfn=&deversion($thisfn);
   
     my %bighash;      my %bighash;
     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_'.&clutter($thisfn)};          my $ids=$bighash{'ids_'.&clutter($thisfn)};
Line 4099  sub decode_symb { Line 4080  sub decode_symb {
 sub fixversion {  sub fixversion {
     my $fn=shift;      my $fn=shift;
     if ($fn=~/^(adm|uploaded|public)/) { return $fn; }      if ($fn=~/^(adm|uploaded|public)/) { return $fn; }
     my ($match,$cond,$versioned)=&is_on_map($fn);      my %bighash;
     unless ($match) {      my $uri=&clutter($fn);
  $fn=$versioned;      my $key=$ENV{'request.course.id'}.'_'.$uri;
     }  # is this cached?
     return $fn;      my ($result,$cached)=&is_cached(\%courseresversioncache,$key,
       'courseresversion',600);
       if (defined($cached)) { return $result; }
   # unfortunately not cached, or expired
       if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
       &GDBM_READER(),0640)) {
     if ($bighash{'version_'.$uri}) {
        my $version=$bighash{'version_'.$uri};
        unless ($version eq 'mostrecent') {
     $uri=~s/\.(\w+)$/\.$version\.$1/;
        }
     }
     untie %bighash;
       }
       return &do_cache
    (\%courseresversioncache,$key,&declutter($uri),'courseresversion');
   }
   
   sub deversion {
       my $url=shift;
       $url=~s/\.\d+\.(\w+)$/\.$1/;
       return $url;
 }  }
   
 # ------------------------------------------------------ Return symb list entry  # ------------------------------------------------------ Return symb list entry
Line 4411  sub mod_perl_version { Line 4413  sub mod_perl_version {
     }      }
     return 1;      return 1;
 }  }
   
   sub correct_line_ends {
       my ($result)=@_;
       &logthis("Wha $result");
       $$result =~s/\r\n/\n/mg;
       $$result =~s/\r/\n/mg;
   }
 # ================================================================ Main Program  # ================================================================ Main Program
   
 sub goodbye {  sub goodbye {
Line 4425  sub goodbye { Line 4434  sub goodbye {
 #1.1 only  #1.1 only
    &logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache)));     &logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache)));
    &logthis(sprintf("%-20s is %s",'%usectioncache',scalar(%usectioncache)));     &logthis(sprintf("%-20s is %s",'%usectioncache',scalar(%usectioncache)));
      &logthis(sprintf("%-20s is %s",'%courseresversioncache',scalar(%courseresversioncache)));
      &logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache)));
    &flushcourselogs();     &flushcourselogs();
    &logthis("Shutting down");     &logthis("Shutting down");
    return DONE;     return DONE;
Removed from v.1.430  
changed lines
  Added in v.1.440

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