[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.587.2.3.2.1 and 1.587.2.3.2.15

version 1.587.2.3.2.1, 2005/02/10 08:16:31 version 1.587.2.3.2.15, 2005/02/23 23:28:54
Line 35  use HTTP::Headers; Line 35  use HTTP::Headers;
 use HTTP::Date;  use HTTP::Date;
 # use Date::Parse;  # use Date::Parse;
 use vars   use vars 
 qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom   qw(%perlvar %hostname %badServerCache %hostip %iphost %spareid %hostdom 
    %libserv %pr %prp $metacache %packagetab %titlecache %courseresversioncache %resversioncache     %libserv %pr %prp $memcache %packagetab 
    %courselogs %accesshash %userrolehash $processmarker $dumpcount      %courselogs %accesshash %userrolehash $processmarker $dumpcount 
    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %courseresdatacache      %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf
    %userresdatacache %getsectioncache %domaindescription %domain_auth_def %domain_auth_arg_def      %domaindescription %domain_auth_def %domain_auth_arg_def 
    %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit);     %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit);
   
 use IO::Socket;  use IO::Socket;
Line 559  sub authenticate { Line 559  sub authenticate {
   
 # ---------------------- Find the homebase for a user from domain's lib servers  # ---------------------- Find the homebase for a user from domain's lib servers
   
   my %homecache;
 sub homeserver {  sub homeserver {
     my ($uname,$udom,$ignoreBadCache)=@_;      my ($uname,$udom,$ignoreBadCache)=@_;
     my $index="$uname:$udom";      my $index="$uname:$udom";
   
     my ($result,$cached)=&is_cached(\%homecache,$index,'home',86400);      if (exists($homecache{$index})) { return $homecache{$index}; }
     if (defined($cached)) { return $result; }  
     my $tryserver;      my $tryserver;
     foreach $tryserver (keys %libserv) {      foreach $tryserver (keys %libserv) {
         next if ($ignoreBadCache ne 'true' &&           next if ($ignoreBadCache ne 'true' && 
Line 572  sub homeserver { Line 572  sub homeserver {
  if ($hostdom{$tryserver} eq $udom) {   if ($hostdom{$tryserver} eq $udom) {
            my $answer=reply("home:$udom:$uname",$tryserver);             my $answer=reply("home:$udom:$uname",$tryserver);
            if ($answer eq 'found') {              if ($answer eq 'found') { 
        return &do_cache(\%homecache,$index,$tryserver,'home');         return $homecache{$index}=$tryserver;
            } elsif ($answer eq 'no_host') {             } elsif ($answer eq 'no_host') {
        $badServerCache{$tryserver}=1;         $badServerCache{$tryserver}=1;
            }             }
Line 777  sub validate_access_key { Line 777  sub validate_access_key {
   
 sub getsection {  sub getsection {
     my ($udom,$unam,$courseid)=@_;      my ($udom,$unam,$courseid)=@_;
       my $cachetime=1800;
     $courseid=~s/\_/\//g;      $courseid=~s/\_/\//g;
     $courseid=~s/^(\w)/\/$1/;      $courseid=~s/^(\w)/\/$1/;
   
     my $hashid="$udom:$unam:$courseid";      my $hashid="$udom:$unam:$courseid";
     my ($result,$cached)=&is_cached(\%getsectioncache,$hashid,'getsection');      my ($result,$cached)=&is_cached_new('getsection',$hashid);
     if (defined($cached)) { return $result; }      if (defined($cached)) { return $result; }
   
     my %Pending;       my %Pending; 
Line 816  sub getsection { Line 817  sub getsection {
             $Pending{$start}=$section;              $Pending{$start}=$section;
             next;              next;
         }          }
         return &do_cache(\%getsectioncache,$hashid,$section,'getsection');          return &do_cache_new('getsection',$hashid,$section,$cachetime);
     }      }
     #      #
     # Presumedly there will be few matching roles from the above      # Presumedly there will be few matching roles from the above
     # loop and the sorting time will be negligible.      # loop and the sorting time will be negligible.
     if (scalar(keys(%Pending))) {      if (scalar(keys(%Pending))) {
         my ($time) = sort {$a <=> $b} keys(%Pending);          my ($time) = sort {$a <=> $b} keys(%Pending);
         return &do_cache(\%getsectioncache,$hashid,$Pending{$time},'getsection');          return &do_cache_new('getsection',$hashid,$Pending{$time},$cachetime);
     }       } 
     if (scalar(keys(%Expired))) {      if (scalar(keys(%Expired))) {
         my @sorted = sort {$a <=> $b} keys(%Expired);          my @sorted = sort {$a <=> $b} keys(%Expired);
         my $time = pop(@sorted);          my $time = pop(@sorted);
         return &do_cache(\%getsectioncache,$hashid,$Expired{$time},'getsection');          return &do_cache_new('getsection',$hashid,$Expired{$time},$cachetime);
     }      }
     return &do_cache(\%getsectioncache,$hashid,'-1','getsection');      return &do_cache_new('getsection',$hashid,'-1',$cachetime);
 }  }
   
   
Line 924  sub save_cache_item { Line 925  sub save_cache_item {
 }  }
   
 sub save_cache {  sub save_cache {
       &purge_remembered();
     if ($disk_caching_disabled) { return; }      if ($disk_caching_disabled) { return; }
     my ($cache,$name,$id);      my ($cache,$name,$id);
     foreach $name (keys(%do_save)) {      foreach $name (keys(%do_save)) {
Line 1021  EVALBLOCK Line 1023  EVALBLOCK
 #    &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime));  #    &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime));
 }  }
   
   my $to_remember=-1;
   my %remembered;
   my %accessed;
   my $kicks=0;
   my $hits=0;
 sub devalidate_cache_new {  sub devalidate_cache_new {
     my ($cache,$name,$id) = @_;      my ($name,$id,$debug) = @_;
     if (1) { &Apache::lonnet::logthis("deleting $name:$id"); }      if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }
     $cache->delete(&escape($name.':'.$id));      $id=&escape($name.':'.$id);
       $memcache->delete($id);
       delete($remembered{$id});
       delete($accessed{$id});
 }  }
   
 my $to_remember=10;  
 my %remembered;  
 my %accessed;  
 sub is_cached_new {  sub is_cached_new {
     my ($cache,$name,$id,$debug) = @_;      my ($name,$id,$debug) = @_;
     $debug=0;  
     $id=&escape($name.':'.$id);      $id=&escape($name.':'.$id);
     if (exists($remembered{$id})) {      if (exists($remembered{$id})) {
  if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }   if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }
  $accessed{$id}=[&gettimeofday()];   $accessed{$id}=[&gettimeofday()];
    $hits++;
  return ($remembered{$id},1);   return ($remembered{$id},1);
     }      }
     my $value = $cache->get($id);      my $value = $memcache->get($id);
     if (!(defined($value))) {      if (!(defined($value))) {
  if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }   if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }
  return (undef,undef);   return (undef,undef);
     }      }
     &make_room($id,$value);  
     if ($value eq '__undef__') {      if ($value eq '__undef__') {
  if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); }   if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); }
  return (undef,1);   $value=undef;
     }      }
       &make_room($id,$value,$debug);
     if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }      if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }
     return ($value,1);      return ($value,1);
 }  }
   
 sub do_cache_new {  sub do_cache_new {
     my ($cache,$name,$id,$value,$time,$debug) = @_;      my ($name,$id,$value,$time,$debug) = @_;
     $debug=0;  
     $id=&escape($name.':'.$id);      $id=&escape($name.':'.$id);
     my $setvalue=$value;      my $setvalue=$value;
     if (!defined($setvalue)) {      if (!defined($setvalue)) {
  $setvalue='__undef__';   $setvalue='__undef__';
     }      }
     if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }      if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }
     $cache->set($id,$setvalue,300);      $memcache->set($id,$setvalue,$time);
       #&make_room($id,$value,$debug);
     return $value;      return $value;
 }  }
   
 my $kicks=0;  
 sub make_room {  sub make_room {
     my ($id,$value)=@_;      my ($id,$value,$debug)=@_;
     my $debug=0;  
     $remembered{$id}=$value;      $remembered{$id}=$value;
       if ($to_remember<0) { return; }
     $accessed{$id}=[&gettimeofday()];      $accessed{$id}=[&gettimeofday()];
     if (scalar(keys(%remembered)) <= $to_remember) { return; }      if (scalar(keys(%remembered)) <= $to_remember) { return; }
     my $to_kick;      my $to_kick;
Line 1088  sub make_room { Line 1094  sub make_room {
     return;      return;
 }  }
   
   sub purge_remembered {
       &logthis("Tossing ".scalar(keys(%remembered)));
       &logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered))));
       undef(%remembered);
       undef(%accessed);
   }
 # ------------------------------------- Read an entry from a user's environment  # ------------------------------------- Read an entry from a user's environment
   
 sub userenvironment {  sub userenvironment {
Line 1125  sub getversion { Line 1137  sub getversion {
   
 sub currentversion {  sub currentversion {
     my $fname=shift;      my $fname=shift;
     my ($result,$cached)=&is_cached(\%resversioncache,$fname,'resversion',600);      my ($result,$cached)=&is_cached_new('resversion',$fname);
     if (defined($cached)) { return $result; }      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/;
Line 1138  sub currentversion { Line 1150  sub currentversion {
     if (($answer eq 'con_lost') || ($answer eq 'rejected')) {      if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
  return -1;   return -1;
     }      }
     return &do_cache(\%resversioncache,$fname,$answer,'resversion');      return &do_cache_new('resversion',$fname,$answer,600);
 }  }
   
 # ----------------------------- Subscribe to a resource, return URL if possible  # ----------------------------- Subscribe to a resource, return URL if possible
Line 4190  sub condval { Line 4202  sub condval {
 sub devalidatecourseresdata {  sub devalidatecourseresdata {
     my ($coursenum,$coursedomain)=@_;      my ($coursenum,$coursedomain)=@_;
     my $hashid=$coursenum.':'.$coursedomain;      my $hashid=$coursenum.':'.$coursedomain;
     &devalidate_cache(\%courseresdatacache,$hashid,'courseres');      &devalidate_cache_new('courseres',$hashid);
 }  }
   
 # --------------------------------------------------- Course Resourcedata Query  # --------------------------------------------------- Course Resourcedata Query
Line 4199  sub courseresdata { Line 4211  sub courseresdata {
     my ($coursenum,$coursedomain,@which)=@_;      my ($coursenum,$coursedomain,@which)=@_;
     my $coursehom=&homeserver($coursenum,$coursedomain);      my $coursehom=&homeserver($coursenum,$coursedomain);
     my $hashid=$coursenum.':'.$coursedomain;      my $hashid=$coursenum.':'.$coursedomain;
     my ($result,$cached)=&is_cached(\%courseresdatacache,$hashid,'courseres');      my ($result,$cached)=&is_cached_new('courseres',$hashid);
     unless (defined($cached)) {      unless (defined($cached)) {
  my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum);   my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum);
  $result=\%dumpreply;   $result=\%dumpreply;
  my ($tmp) = keys(%dumpreply);   my ($tmp) = keys(%dumpreply);
  if ($tmp !~ /^(con_lost|error|no_such_host)/i) {   if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
     &do_cache(\%courseresdatacache,$hashid,$result,'courseres');      &do_cache_new('courseres',$hashid,$result,600);
  } elsif ($tmp =~ /^(con_lost|no_such_host)/) {   } elsif ($tmp =~ /^(con_lost|no_such_host)/) {
     return $tmp;      return $tmp;
  } elsif ($tmp =~ /^(error)/) {   } elsif ($tmp =~ /^(error)/) {
     $result=undef;      $result=undef;
     &do_cache(\%courseresdatacache,$hashid,$result,'courseres');      &do_cache_new('courseres',$hashid,$result,600);
  }   }
     }      }
     foreach my $item (@which) {      foreach my $item (@which) {
Line 4399  sub EXT { Line 4411  sub EXT {
     #most student don\'t have any data set, check if there is some data      #most student don\'t have any data set, check if there is some data
     if (! &EXT_cache_status($udom,$uname)) {      if (! &EXT_cache_status($udom,$uname)) {
  my $hashid="$udom:$uname";   my $hashid="$udom:$uname";
  my ($result,$cached)=&is_cached(\%userresdatacache,$hashid,   my ($result,$cached)=&is_cached_new('userres',$hashid);
  'userres');  
  if (!defined($cached)) {   if (!defined($cached)) {
     my %resourcedata=&dump('resourcedata',$udom,$uname);      my %resourcedata=&dump('resourcedata',$udom,$uname);
     $result=\%resourcedata;      $result=\%resourcedata;
     &do_cache(\%userresdatacache,$hashid,$result,'userres');      &do_cache_new('userres',$hashid,$result);
  }   }
  my ($tmp)=keys(%$result);   my ($tmp)=keys(%$result);
  if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {   if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {
Line 4552  sub metadata { Line 4563  sub metadata {
 # Everything is cached by the main uri, libraries are never directly cached  # Everything is cached by the main uri, libraries are never directly cached
 #  #
     if (!defined($liburi)) {      if (!defined($liburi)) {
  my ($result,$cached)=&is_cached_new($metacache,'meta',$uri);   my ($result,$cached)=&is_cached_new('meta',$uri);
  if (defined($cached)) { return $result->{':'.$what}; }   if (defined($cached)) { return $result->{':'.$what}; }
     }      }
     {      {
Line 4566  sub metadata { Line 4577  sub metadata {
     $liburi=&declutter($liburi);      $liburi=&declutter($liburi);
             $filename=$liburi;              $filename=$liburi;
         } else {          } else {
     &devalidate_cache_new($metacache,'meta',$uri);      &devalidate_cache_new('meta',$uri);
     undef(%metaentry);      undef(%metaentry);
  }   }
         my %metathesekeys=();          my %metathesekeys=();
Line 4725  sub metadata { Line 4736  sub metadata {
  $metaentry{':keys'}=join(',',keys %metathesekeys);   $metaentry{':keys'}=join(',',keys %metathesekeys);
  &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);   &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
  $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);   $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
  &do_cache_new($metacache,'meta',$uri,\%metaentry);   &do_cache_new('meta',$uri,\%metaentry);
 # this is the end of "was not already recently cached  # this is the end of "was not already recently cached
     }      }
     return $metaentry{':'.$what};      return $metaentry{':'.$what};
Line 4789  sub gettitle { Line 4800  sub gettitle {
     my $urlsymb=shift;      my $urlsymb=shift;
     my $symb=&symbread($urlsymb);      my $symb=&symbread($urlsymb);
     if ($symb) {      if ($symb) {
  my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);   my $key=$ENV{'request.course.id'}."\0".$symb;
    my ($result,$cached)=&is_cached_new('title',$key);
  if (defined($cached)) {    if (defined($cached)) { 
     return $result;      return $result;
  }   }
Line 4804  sub gettitle { Line 4816  sub gettitle {
  }   }
  $title=~s/\&colon\;/\:/gs;   $title=~s/\&colon\;/\:/gs;
  if ($title) {   if ($title) {
     return &do_cache(\%titlecache,$symb,$title,'title');      return &do_cache_new('title',$key,$title,600);
  }   }
  $urlsymb=$url;   $urlsymb=$url;
     }      }
Line 4918  sub fixversion { Line 4930  sub fixversion {
     my $uri=&clutter($fn);      my $uri=&clutter($fn);
     my $key=$ENV{'request.course.id'}.'_'.$uri;      my $key=$ENV{'request.course.id'}.'_'.$uri;
 # is this cached?  # is this cached?
     my ($result,$cached)=&is_cached(\%courseresversioncache,$key,      my ($result,$cached)=&is_cached_new('courseresversion',$key);
     'courseresversion',600);  
     if (defined($cached)) { return $result; }      if (defined($cached)) { return $result; }
 # unfortunately not cached, or expired  # unfortunately not cached, or expired
     if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',      if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
Line 4933  sub fixversion { Line 4944  sub fixversion {
   }    }
   untie %bighash;    untie %bighash;
     }      }
     return &do_cache      return &do_cache_new('courseresversion',$key,&declutter($uri),600);
  (\%courseresversioncache,$key,&declutter($uri),'courseresversion');  
 }  }
   
 sub deversion {  sub deversion {
Line 5646  sub goodbye { Line 5656  sub goodbye {
    &logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%badServerCache))));     &logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%badServerCache))));
 #converted  #converted
 #   &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));  #   &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
    &logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache))));  #   &logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache))));
    &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache))));  #   &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache))));
    &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache))));  #   &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache))));
 #1.1 only  #1.1 only
    &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache))));  #   &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache))));
    &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache))));  #   &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache))));
    &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache))));  #   &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache))));
    &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%resversioncache))));  #   &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%resversioncache))));
    &logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered))));     &logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered))));
    &logthis(sprintf("%-20s is %s",'kicks',$kicks));     &logthis(sprintf("%-20s is %s",'kicks',$kicks));
      &logthis(sprintf("%-20s is %s",'hits',$hits));
    &flushcourselogs();     &flushcourselogs();
    &logthis("Shutting down");     &logthis("Shutting down");
    return DONE;     return DONE;
Line 5801  BEGIN { Line 5812  BEGIN {
   
 }  }
   
 $metacache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']});  $memcache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']});
   
 $processmarker='_'.time.'_'.$perlvar{'lonHostID'};  $processmarker='_'.time.'_'.$perlvar{'lonHostID'};
 $dumpcount=0;  $dumpcount=0;
Removed from v.1.587.2.3.2.1  
changed lines
  Added in v.1.587.2.3.2.15

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