[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.434 and 1.444

version 1.434, 2003/10/29 22:33:49 version 1.444, 2003/11/10 21:50:21
Line 35  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 367  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 823  sub devalidate_cache { Line 823  sub devalidate_cache {
     my ($cache,$id,$name) = @_;      my ($cache,$id,$name) = @_;
     delete $$cache{$id.'.time'};      delete $$cache{$id.'.time'};
     delete $$cache{$id};      delete $$cache{$id};
     my $filename=$perlvar{'lonDaemons'}.'/tmp/'.$name.".db";      my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
     open(DB,"$filename.lock");      open(DB,"$filename.lock");
     flock(DB,LOCK_EX);      flock(DB,LOCK_EX);
     my %hash;      my %hash;
     if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {      if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
  delete($hash{$id});   eval <<'EVALBLOCK';
  delete($hash{$id.'.time'});      delete($hash{$id});
       delete($hash{$id.'.time'});
   EVALBLOCK
           if ($@) {
       &logthis("<font color='red'>devalidate_cache blew up :$@:$name</font>");
       unlink($filename);
    }
     } else {      } else {
  &logthis("Unable to tie hash");   if (-e $filename) {
       &logthis("Unable to tie hash (devalidate cache): $name");
       unlink($filename);
    }
     }      }
     untie(%hash);      untie(%hash);
     flock(DB,LOCK_UN);      flock(DB,LOCK_UN);
Line 849  sub is_cached { Line 858  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 867  sub do_cache { Line 876  sub do_cache {
     $$cache{$id};      $$cache{$id};
 }  }
   
 sub save_cache {  
     my ($cache,$name)=@_;  
     my $starttime=&Time::HiRes::time();  
 #    &logthis("Saving :$name:");  
     eval lock_store($cache,$perlvar{'lonDaemons'}.'/tmp/'.$name.".storable");  
     if ($@) { &logthis("lock_store threw a die ".$@); }  
 #    &logthis("save_cache took ".(&Time::HiRes::time()-$starttime));  
 }  
   
 sub load_cache {  
     my ($cache,$name)=@_;  
     my $starttime=&Time::HiRes::time();  
 #    &logthis("Before Loading $name size is ".scalar(%$cache));  
     my $tmpcache;  
     eval {  
  $tmpcache=lock_retrieve($perlvar{'lonDaemons'}.'/tmp/'.$name.".storable");  
     };  
     if ($@) { &logthis("lock_retreive threw a die ".$@); return; }  
     if (!%$cache) {  
  my $count;  
  while (my ($key,$value)=each(%$tmpcache)) {   
     $count++;  
     $$cache{$key}=$value;  
  }  
 # &logthis("Initial load: $count");  
     } else {  
  my $key;  
  my $count;  
  while ($key=each(%$tmpcache)) {  
     if ($key !~/^(.*)\.time$/) { next; }  
     my $name=$1;  
     if (exists($$cache{$key})) {  
  if ($$tmpcache{$key} >= $$cache{$key}) {  
     $$cache{$key}=$$tmpcache{$key};  
     $$cache{$name}=$$tmpcache{$name};  
  } else {  
 #    &logthis("Would have overwritten $name with is set to expire at ".$$cache{$key}." with ".$$tmpcache{$key}." Whew!");  
  }  
     } else {  
  $count++;  
  $$cache{$key}=$$tmpcache{$key};  
  $$cache{$name}=$$tmpcache{$name};  
     }  
  }  
 # &logthis("Additional load: $count");  
     }  
 #    &logthis("After Loading $name size is ".scalar(%$cache));  
 #    &logthis("load_cache took ".(&Time::HiRes::time()-$starttime));  
 }  
   
 sub save_cache_item {  sub save_cache_item {
     my ($cache,$name,$id)=@_;      my ($cache,$name,$id)=@_;
     my $starttime=&Time::HiRes::time();      my $starttime=&Time::HiRes::time();
  #   &logthis("Saving :$name:$id");  #    &logthis("Saving :$name:$id");
     my %hash;      my %hash;
     my $filename=$perlvar{'lonDaemons'}.'/tmp/'.$name.".db";      my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
     open(DB,"$filename.lock");      open(DB,"$filename.lock");
     flock(DB,LOCK_EX);      flock(DB,LOCK_EX);
     if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {      if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
  $hash{$id.'.time'}=$$cache{$id.'.time'};   eval <<'EVALBLOCK';
  $hash{$id}=freeze({'item'=>$$cache{$id}});      $hash{$id.'.time'}=$$cache{$id.'.time'};
       $hash{$id}=freeze({'item'=>$$cache{$id}});
   EVALBLOCK
           if ($@) {
       &logthis("<font color='red'>save_cache blew up :$@:$name</font>");
       unlink($filename);
    }
     } else {      } else {
  &logthis("Unable to tie hash");   if (-e $filename) {
       &logthis("Unable to tie hash (save cache item): $name");
       unlink($filename);
    }
     }      }
     untie(%hash);      untie(%hash);
     flock(DB,LOCK_UN);      flock(DB,LOCK_UN);
Line 942  sub load_cache_item { Line 910  sub load_cache_item {
     my $starttime=&Time::HiRes::time();      my $starttime=&Time::HiRes::time();
 #    &logthis("Before Loading $name  for $id size is ".scalar(%$cache));  #    &logthis("Before Loading $name  for $id size is ".scalar(%$cache));
     my %hash;      my %hash;
     my $filename=$perlvar{'lonDaemons'}.'/tmp/'.$name.".db";      my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
     open(DB,"$filename.lock");      open(DB,"$filename.lock");
     flock(DB,LOCK_SH);      flock(DB,LOCK_SH);
     if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) {      if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) {
  if (!%$cache) {   eval <<'EVALBLOCK';
     my $count;      if (!%$cache) {
     while (my ($key,$value)=each(%hash)) {    my $count;
  $count++;   while (my ($key,$value)=each(%hash)) { 
  if ($key =~ /\.time$/) {      $count++;
     $$cache{$key}=$value;      if ($key =~ /\.time$/) {
  } else {   $$cache{$key}=$value;
     my $hashref=thaw($value);      } else {
     $$cache{$key}=$hashref->{'item'};   my $hashref=thaw($value);
    $$cache{$key}=$hashref->{'item'};
       }
  }   }
     }  
 #    &logthis("Initial load: $count");  #    &logthis("Initial load: $count");
  } else {      } else {
     my $hashref=thaw($hash{$id});   my $hashref=thaw($hash{$id});
     $$cache{$id}=$hashref->{'item'};   $$cache{$id}=$hashref->{'item'};
     $$cache{$id.'.time'}=$hash{$id.'.time'};   $$cache{$id.'.time'}=$hash{$id.'.time'};
  }      }
   EVALBLOCK
           if ($@) {
       &logthis("<font color='red'>load_cache blew up :$@:$name</font>");
       unlink($filename);
    }        
     } else {      } else {
  &logthis("Unable to tie hash");   if (-e $filename) {
       &logthis("Unable to tie hash (load cache item): $name");
       unlink($filename);
    }
     }      }
     untie(%hash);      untie(%hash);
     flock(DB,LOCK_UN);      flock(DB,LOCK_UN);
Line 1042  sub getversion { Line 1019  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 1053  sub currentversion { Line 1032  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 1088  sub repcopy { Line 1067  sub repcopy {
    &logthis("Subscribe returned $remoteurl: $filename");     &logthis("Subscribe returned $remoteurl: $filename");
            return HTTP_SERVICE_UNAVAILABLE;             return HTTP_SERVICE_UNAVAILABLE;
     } elsif ($remoteurl eq 'not_found') {      } elsif ($remoteurl eq 'not_found') {
    &logthis("Subscribe returned not_found: $filename");     #&logthis("Subscribe returned not_found: $filename");
    return HTTP_NOT_FOUND;     return HTTP_NOT_FOUND;
     } elsif ($remoteurl =~ /^rejected by/) {      } elsif ($remoteurl =~ /^rejected by/) {
    &logthis("Subscribe returned $remoteurl: $filename");     &logthis("Subscribe returned $remoteurl: $filename");
Line 2449  sub customaccess { Line 2428  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 2734  sub allowed { Line 2713  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 3992  sub gettitle { Line 3972  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 4012  sub symblist { Line 3992  sub symblist {
   
 sub symbverify {  sub symbverify {
     my ($symb,$thisfn)=@_;      my ($symb,$thisfn)=@_;
     $thisfn=&symbclean(&declutter($thisfn));      $thisfn=&declutter($thisfn);
 # direct jump to resource in page or to a sequence - will construct own symbs  # direct jump to resource in page or to a sequence - will construct own symbs
     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 ($url eq $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;
Line 4075  sub decode_symb { Line 4057  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') || 
       ($version==&getversion($uri))) {
     $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 4179  sub numval { Line 4183  sub numval {
 }  }
   
 sub latest_rnd_algorithm_id {  sub latest_rnd_algorithm_id {
     return '64bit';      return '64bit2';
 }  }
   
 sub rndseed {  sub rndseed {
Line 4196  sub rndseed { Line 4200  sub rndseed {
     my $CODE=$ENV{'scantron.CODE'};      my $CODE=$ENV{'scantron.CODE'};
     if (defined($CODE)) {      if (defined($CODE)) {
  &rndseed_CODE_64bit($symb,$courseid,$domain,$username);   &rndseed_CODE_64bit($symb,$courseid,$domain,$username);
       } elsif ($which eq '64bit2') {
    return &rndseed_64bit2($symb,$courseid,$domain,$username);
     } elsif ($which eq '64bit') {      } elsif ($which eq '64bit') {
  return &rndseed_64bit($symb,$courseid,$domain,$username);   return &rndseed_64bit($symb,$courseid,$domain,$username);
     }      }
Line 4239  sub rndseed_64bit { Line 4245  sub rndseed_64bit {
     }      }
 }  }
   
   sub rndseed_64bit2 {
       my ($symb,$courseid,$domain,$username)=@_;
       {
    use integer;
    # strings need to be an even # of cahracters long, it it is odd the
           # last characters gets thrown away
    my $symbchck=unpack("%32S*",$symb.' ') << 21;
    my $symbseed=numval($symb) << 10;
    my $namechck=unpack("%32S*",$username.' ');
   
    my $nameseed=numval($username) << 21;
    my $domainseed=unpack("%32S*",$domain.' ') << 10;
    my $courseseed=unpack("%32S*",$courseid.' ');
   
    my $num1=$symbchck+$symbseed+$namechck;
    my $num2=$nameseed+$domainseed+$courseseed;
    #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
    #&Apache::lonxml::debug("rndseed :$num:$symb");
    return "$num1,$num2";
       }
   }
   
 sub rndseed_CODE_64bit {  sub rndseed_CODE_64bit {
     my ($symb,$courseid,$domain,$username)=@_;      my ($symb,$courseid,$domain,$username)=@_;
     {      {
  use integer;   use integer;
  my $symbchck=unpack("%32S*",$symb) << 16;   my $symbchck=unpack("%32S*",$symb.' ') << 16;
  my $symbseed=numval($symb);   my $symbseed=numval($symb);
  my $CODEseed=numval($ENV{'scantron.CODE'}) << 16;   my $CODEseed=numval($ENV{'scantron.CODE'}) << 16;
  my $courseseed=unpack("%32S*",$courseid);   my $courseseed=unpack("%32S*",$courseid.' ');
  my $num1=$symbseed+$CODEseed;   my $num1=$symbseed+$CODEseed;
  my $num2=$courseseed+$symbchck;   my $num2=$courseseed+$symbchck;
  #&Apache::lonxml::debug("$symbseed:$CODEseed|$courseseed:$symbchck");   #&Apache::lonxml::debug("$symbseed:$CODEseed|$courseseed:$symbchck");
Line 4387  sub mod_perl_version { Line 4415  sub mod_perl_version {
     }      }
     return 1;      return 1;
 }  }
   
   sub correct_line_ends {
       my ($result)=@_;
       $$result =~s/\r\n/\n/mg;
       $$result =~s/\r/\n/mg;
   }
 # ================================================================ Main Program  # ================================================================ Main Program
   
 sub goodbye {  sub goodbye {
    &logthis("Starting Shut down");     &logthis("Starting Shut down");
 #not converted to using infrastruture  #not converted to using infrastruture and probably shouldn't be
    &logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache)));  
    &logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache)));     &logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache)));
    &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));  
 #converted  #converted
      &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
      &logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache)));
    &logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache)));     &logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache)));
    &logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache)));     &logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache)));
 #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.434  
changed lines
  Added in v.1.444

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