Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.587.2.3.2.16 and 1.588

version 1.587.2.3.2.16, 2005/04/15 20:48:18 version 1.588, 2005/01/13 21:45:08
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 %badServerCache %hostip %iphost %spareid %hostdom   qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom 
    %libserv %pr %prp $memcache %packagetab      %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache
    %courselogs %accesshash %userrolehash $processmarker $dumpcount      %courselogs %accesshash %userrolehash $processmarker $dumpcount 
    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf     %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %courseresdatacache 
    %domaindescription %domain_auth_def %domain_auth_arg_def      %userresdatacache %getsectioncache %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 50  use Fcntl qw(:flock); Line 50  use Fcntl qw(:flock);
 use Apache::lonlocal;  use Apache::lonlocal;
 use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);  use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);
 use Time::HiRes qw( gettimeofday tv_interval );  use Time::HiRes qw( gettimeofday tv_interval );
 use Cache::Memcached;  
 my $readit;  my $readit;
 my $max_connection_retries = 10;     # Or some such value.  my $max_connection_retries = 10;     # Or some such value.
   
Line 158  sub reply { Line 157  sub reply {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
     unless (defined($hostname{$server})) { return 'no_such_host'; }      unless (defined($hostname{$server})) { return 'no_such_host'; }
     my $answer=subreply($cmd,$server);      my $answer=subreply($cmd,$server);
       if ($answer eq 'con_lost') {
           #sleep 5; 
           #$answer=subreply($cmd,$server);
           #if ($answer eq 'con_lost') {
    #   &logthis("Second attempt con_lost on $server");
           #   my $peerfile="$perlvar{'lonSockDir'}/$server";
           #   my $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
           #                                    Type    => SOCK_STREAM,
           #                                    Timeout => 10)
           #              or return "con_lost";
           #   &logthis("Killing socket");
           #   print $client "close_connection_exit\n";
              #sleep 5;
           #   $answer=subreply($cmd,$server);       
          #}   
       }
     if (($answer=~/^refused/) || ($answer=~/^rejected/)) {      if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
        &logthis("<font color=blue>WARNING:".         &logthis("<font color=blue>WARNING:".
                 " $cmd to $server returned $answer</font>");                  " $cmd to $server returned $answer</font>");
Line 205  sub critical { Line 220  sub critical {
     }      }
     my $answer=reply($cmd,$server);      my $answer=reply($cmd,$server);
     if ($answer eq 'con_lost') {      if ($answer eq 'con_lost') {
           my $pingreply=reply('ping',$server);
  &reconlonc("$perlvar{'lonSockDir'}/$server");   &reconlonc("$perlvar{'lonSockDir'}/$server");
  my $answer=reply($cmd,$server);          my $pongreply=reply('pong',$server);
           &logthis("Ping/Pong for $server: $pingreply/$pongreply");
           $answer=reply($cmd,$server);
         if ($answer eq 'con_lost') {          if ($answer eq 'con_lost') {
             my $now=time;              my $now=time;
             my $middlename=$cmd;              my $middlename=$cmd;
Line 559  sub authenticate { Line 577  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";
   
     if (exists($homecache{$index})) { return $homecache{$index}; }      my ($result,$cached)=&is_cached(\%homecache,$index,'home',86400);
       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 590  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 $homecache{$index}=$tryserver;         return &do_cache(\%homecache,$index,$tryserver,'home');
            } elsif ($answer eq 'no_host') {             } elsif ($answer eq 'no_host') {
        $badServerCache{$tryserver}=1;         $badServerCache{$tryserver}=1;
            }             }
Line 777  sub validate_access_key { Line 795  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_new('getsection',$hashid);      my ($result,$cached)=&is_cached(\%getsectioncache,$hashid,'getsection');
     if (defined($cached)) { return $result; }      if (defined($cached)) { return $result; }
   
     my %Pending;       my %Pending; 
Line 817  sub getsection { Line 834  sub getsection {
             $Pending{$start}=$section;              $Pending{$start}=$section;
             next;              next;
         }          }
         return &do_cache_new('getsection',$hashid,$section,$cachetime);          return &do_cache(\%getsectioncache,$hashid,$section,'getsection');
     }      }
     #      #
     # 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_new('getsection',$hashid,$Pending{$time},$cachetime);          return &do_cache(\%getsectioncache,$hashid,$Pending{$time},'getsection');
     }       } 
     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_new('getsection',$hashid,$Expired{$time},$cachetime);          return &do_cache(\%getsectioncache,$hashid,$Expired{$time},'getsection');
     }      }
     return &do_cache_new('getsection',$hashid,'-1',$cachetime);      return &do_cache(\%getsectioncache,$hashid,'-1','getsection');
 }  }
   
   
Line 925  sub save_cache_item { Line 942  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 1023  EVALBLOCK Line 1039  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 {  
     my ($name,$id,$debug) = @_;  
     if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }  
     $id=&escape($name.':'.$id);  
     $memcache->delete($id);  
     delete($remembered{$id});  
     delete($accessed{$id});  
 }  
   
 sub is_cached_new {  
     my ($name,$id,$debug) = @_;  
     $id=&escape($name.':'.$id);  
     if (exists($remembered{$id})) {  
  if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }  
  $accessed{$id}=[&gettimeofday()];  
  $hits++;  
  return ($remembered{$id},1);  
     }  
     my $value = $memcache->get($id);  
     if (!(defined($value))) {  
  if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }  
  return (undef,undef);  
     }  
     if ($value eq '__undef__') {  
  if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); }  
  $value=undef;  
     }  
     &make_room($id,$value,$debug);  
     if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }  
     return ($value,1);  
 }  
   
 sub do_cache_new {  
     my ($name,$id,$value,$time,$debug) = @_;  
     $id=&escape($name.':'.$id);  
     my $setvalue=$value;  
     if (!defined($setvalue)) {  
  $setvalue='__undef__';  
     }  
     if (!defined($time)) {  
  $time=600;  
     }  
     if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }  
     $memcache->set($id,$setvalue,$time);  
     #&make_room($id,$value,$debug);  
     return $value;  
 }  
   
 sub make_room {  
     my ($id,$value,$debug)=@_;  
     $remembered{$id}=$value;  
     if ($to_remember<0) { return; }  
     $accessed{$id}=[&gettimeofday()];  
     if (scalar(keys(%remembered)) <= $to_remember) { return; }  
     my $to_kick;  
     my $max_time=0;  
     foreach my $other (keys(%accessed)) {  
  if (&tv_interval($accessed{$other}) > $max_time) {  
     $to_kick=$other;  
     $max_time=&tv_interval($accessed{$other});  
  }  
     }  
     delete($remembered{$to_kick});  
     delete($accessed{$to_kick});  
     $kicks++;  
     if ($debug) { &logthis("kicking $max_time $kicks\n"); }  
     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 1140  sub getversion { Line 1076  sub getversion {
   
 sub currentversion {  sub currentversion {
     my $fname=shift;      my $fname=shift;
     my ($result,$cached)=&is_cached_new('resversion',$fname);      my ($result,$cached)=&is_cached(\%resversioncache,$fname,'resversion',600);
     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 1153  sub currentversion { Line 1089  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_new('resversion',$fname,$answer,600);      return &do_cache(\%resversioncache,$fname,$answer,'resversion');
 }  }
   
 # ----------------------------- Subscribe to a resource, return URL if possible  # ----------------------------- Subscribe to a resource, return URL if possible
Line 1822  sub get_first_access { Line 1758  sub get_first_access {
     my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();      my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
     if ($argsymb) { $symb=$argsymb; }      if ($argsymb) { $symb=$argsymb; }
     my ($map,$id,$res)=&decode_symb($symb);      my ($map,$id,$res)=&decode_symb($symb);
     if ($type eq 'map') { $res=$map; }      if ($type eq 'map') {
     my %times=&get('firstaccesstimes',[$res],$udom,$uname);   $res=&symbread($map);
     return $times{$res};      } else {
    $res=$symb;
       }
       my %times=&get('firstaccesstimes',["$courseid\0$res"],$udom,$uname);
       return $times{"$courseid\0$res"};
 }  }
   
 sub set_first_access {  sub set_first_access {
     my ($type)=@_;      my ($type)=@_;
     my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();      my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
     my ($map,$id,$res)=&decode_symb($symb);      my ($map,$id,$res)=&decode_symb($symb);
     if ($type eq 'map') { $res=$map; }      if ($type eq 'map') {
     my $firstaccess=&get_first_access($type);   $res=&symbread($map);
       } else {
    $res=$symb;
       }
       my $firstaccess=&get_first_access($type,$symb);
     if (!$firstaccess) {      if (!$firstaccess) {
  return &put('firstaccesstimes',{$res=>time},$udom,$uname);   return &put('firstaccesstimes',{"$courseid\0$res"=>time},$udom,$uname);
     }      }
     return 'already_set';      return 'already_set';
 }  }
Line 4205  sub condval { Line 4149  sub condval {
 sub devalidatecourseresdata {  sub devalidatecourseresdata {
     my ($coursenum,$coursedomain)=@_;      my ($coursenum,$coursedomain)=@_;
     my $hashid=$coursenum.':'.$coursedomain;      my $hashid=$coursenum.':'.$coursedomain;
     &devalidate_cache_new('courseres',$hashid);      &devalidate_cache(\%courseresdatacache,$hashid,'courseres');
 }  }
   
 # --------------------------------------------------- Course Resourcedata Query  # --------------------------------------------------- Course Resourcedata Query
Line 4214  sub courseresdata { Line 4158  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_new('courseres',$hashid);      my ($result,$cached)=&is_cached(\%courseresdatacache,$hashid,'courseres');
     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_new('courseres',$hashid,$result,600);      &do_cache(\%courseresdatacache,$hashid,$result,'courseres');
  } 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_new('courseres',$hashid,$result,600);      &do_cache(\%courseresdatacache,$hashid,$result,'courseres');
  }   }
     }      }
     foreach my $item (@which) {      foreach my $item (@which) {
Line 4414  sub EXT { Line 4358  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_new('userres',$hashid);   my ($result,$cached)=&is_cached(\%userresdatacache,$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_new('userres',$hashid,$result,600);      &do_cache(\%userresdatacache,$hashid,$result,'userres');
  }   }
  my ($tmp)=keys(%$result);   my ($tmp)=keys(%$result);
  if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {   if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {
Line 4546  sub add_prefix_and_part { Line 4491  sub add_prefix_and_part {
   
 # ---------------------------------------------------------------- Get metadata  # ---------------------------------------------------------------- Get metadata
   
 my %metaentry;  
 sub metadata {  sub metadata {
     my ($uri,$what,$liburi,$prefix,$depthcount)=@_;      my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
     $uri=&declutter($uri);      $uri=&declutter($uri);
Line 4566  sub metadata { Line 4510  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('meta',$uri);   my ($result,$cached)=&is_cached(\%metacache,$uri,'meta');
  if (defined($cached)) { return $result->{':'.$what}; }   if (defined($cached)) { return $result->{':'.$what}; }
     }      }
     {      {
 #  #
 # Is this a recursive call for a library?  # Is this a recursive call for a library?
 #  #
 # if (! exists($metacache{$uri})) {   if (! exists($metacache{$uri})) {
 #    $metacache{$uri}={};      $metacache{$uri}={};
 # }   }
         if ($liburi) {          if ($liburi) {
     $liburi=&declutter($liburi);      $liburi=&declutter($liburi);
             $filename=$liburi;              $filename=$liburi;
         } else {          } else {
     &devalidate_cache_new('meta',$uri);      &devalidate_cache(\%metacache,$uri,'meta');
     undef(%metaentry);  
  }   }
         my %metathesekeys=();          my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }          unless ($filename=~/\.meta$/) { $filename.='.meta'; }
  my $metastring;   my $metastring;
  if ($uri !~ m|^uploaded/|) {   if ($uri !~ m|^uploaded/|) {
     my $file=&filelocation('',&clutter($filename));      my $file=&filelocation('',&clutter($filename));
     #push(@{$metaentry{$uri.'.file'}},$file);      push(@{$metacache{$uri.'.file'}},$file);
     $metastring=&getfile($file);      $metastring=&getfile($file);
  }   }
         my $parser=HTML::LCParser->new(\$metastring);          my $parser=HTML::LCParser->new(\$metastring);
Line 4605  sub metadata { Line 4548  sub metadata {
     if (defined($token->[2]->{'id'})) {       if (defined($token->[2]->{'id'})) { 
  $keyroot.='_'.$token->[2]->{'id'};    $keyroot.='_'.$token->[2]->{'id'}; 
     }      }
     if ($metaentry{':packages'}) {      if ($metacache{$uri}->{':packages'}) {
  $metaentry{':packages'}.=','.$package.$keyroot;   $metacache{$uri}->{':packages'}.=','.$package.$keyroot;
     } else {      } else {
  $metaentry{':packages'}=$package.$keyroot;   $metacache{$uri}->{':packages'}=$package.$keyroot;
     }      }
     foreach (keys %packagetab) {      foreach (keys %packagetab) {
  my $part=$keyroot;   my $part=$keyroot;
Line 4630  sub metadata { Line 4573  sub metadata {
     if ($subp eq 'display') {      if ($subp eq 'display') {
  $value.=' [Part: '.$part.']';   $value.=' [Part: '.$part.']';
     }      }
     $metaentry{':'.$unikey.'.part'}=$part;      $metacache{$uri}->{':'.$unikey.'.part'}=$part;
     $metathesekeys{$unikey}=1;      $metathesekeys{$unikey}=1;
     unless (defined($metaentry{':'.$unikey.'.'.$subp})) {      unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) {
  $metaentry{':'.$unikey.'.'.$subp}=$value;   $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value;
     }      }
     if (defined($metaentry{':'.$unikey.'.default'})) {      if (defined($metacache{$uri}->{':'.$unikey.'.default'})) {
  $metaentry{':'.$unikey}=   $metacache{$uri}->{':'.$unikey}=
     $metaentry{':'.$unikey.'.default'};      $metacache{$uri}->{':'.$unikey.'.default'};
     }      }
  }   }
     }      }
Line 4670  sub metadata { Line 4613  sub metadata {
     foreach (sort(split(/\,/,&metadata($uri,'keys',      foreach (sort(split(/\,/,&metadata($uri,'keys',
        $location,$unikey,         $location,$unikey,
        $depthcount+1)))) {         $depthcount+1)))) {
  $metaentry{':'.$_}=$metaentry{':'.$_};   $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_};
  $metathesekeys{$_}=1;   $metathesekeys{$_}=1;
     }      }
  }   }
Line 4681  sub metadata { Line 4624  sub metadata {
  }   }
  $metathesekeys{$unikey}=1;   $metathesekeys{$unikey}=1;
  foreach (@{$token->[3]}) {   foreach (@{$token->[3]}) {
     $metaentry{':'.$unikey.'.'.$_}=$token->[2]->{$_};      $metacache{$uri}->{':'.$unikey.'.'.$_}=$token->[2]->{$_};
  }   }
  my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));   my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
  my $default=$metaentry{':'.$unikey.'.default'};   my $default=$metacache{$uri}->{':'.$unikey.'.default'};
  if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) {   if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) {
  # only ws inside the tag, and not in default, so use default   # only ws inside the tag, and not in default, so use default
  # as value   # as value
     $metaentry{':'.$unikey}=$default;      $metacache{$uri}->{':'.$unikey}=$default;
  } else {   } else {
   # either something interesting inside the tag or default    # either something interesting inside the tag or default
                   # uninteresting                    # uninteresting
     $metaentry{':'.$unikey}=$internaltext;      $metacache{$uri}->{':'.$unikey}=$internaltext;
  }   }
 # end of not-a-package not-a-library import  # end of not-a-package not-a-library import
     }      }
Line 4709  sub metadata { Line 4652  sub metadata {
     &metadata_create_package_def($uri,$key,'extension_'.$extension,      &metadata_create_package_def($uri,$key,'extension_'.$extension,
  \%metathesekeys);   \%metathesekeys);
  }   }
  if (!exists($metaentry{':packages'})) {   if (!exists($metacache{$uri}->{':packages'})) {
     foreach my $key (sort(keys(%packagetab))) {      foreach my $key (sort(keys(%packagetab))) {
  #no specific packages well let's get default then   #no specific packages well let's get default then
  if ($key!~/^default&/) { next; }   if ($key!~/^default&/) { next; }
Line 4718  sub metadata { Line 4661  sub metadata {
     }      }
  }   }
 # are there custom rights to evaluate  # are there custom rights to evaluate
  if ($metaentry{':copyright'} eq 'custom') {   if ($metacache{$uri}->{':copyright'} eq 'custom') {
   
     #      #
     # Importing a rights file here      # Importing a rights file here
     #      #
     unless ($depthcount) {      unless ($depthcount) {
  my $location=$metaentry{':customdistributionfile'};   my $location=$metacache{$uri}->{':customdistributionfile'};
  my $dir=$filename;   my $dir=$filename;
  $dir=~s|[^/]*$||;   $dir=~s|[^/]*$||;
  $location=&filelocation($dir,$location);   $location=&filelocation($dir,$location);
  foreach (sort(split(/\,/,&metadata($uri,'keys',   foreach (sort(split(/\,/,&metadata($uri,'keys',
    $location,'_rights',     $location,'_rights',
    $depthcount+1)))) {     $depthcount+1)))) {
     #$metaentry{':'.$_}=$metacache{$uri}->{':'.$_};      $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_};
     $metathesekeys{$_}=1;      $metathesekeys{$_}=1;
  }   }
     }      }
  }   }
  $metaentry{':keys'}=join(',',keys %metathesekeys);   $metacache{$uri}->{':keys'}=join(',',keys %metathesekeys);
  &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);   &metadata_generate_part0(\%metathesekeys,$metacache{$uri},$uri);
  $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);   $metacache{$uri}->{':allpossiblekeys'}=join(',',keys %metathesekeys);
  &do_cache_new('meta',$uri,\%metaentry,6000);   &do_cache(\%metacache,$uri,$metacache{$uri},'meta');
 # this is the end of "was not already recently cached  # this is the end of "was not already recently cached
     }      }
     return $metaentry{':'.$what};      return $metacache{$uri}->{':'.$what};
 }  }
   
 sub metadata_create_package_def {  sub metadata_create_package_def {
Line 4750  sub metadata_create_package_def { Line 4693  sub metadata_create_package_def {
     my ($pack,$name,$subp)=split(/\&/,$key);      my ($pack,$name,$subp)=split(/\&/,$key);
     if ($subp eq 'default') { next; }      if ($subp eq 'default') { next; }
           
     if (defined($metaentry{':packages'})) {      if (defined($metacache{$uri}->{':packages'})) {
  $metaentry{':packages'}.=','.$package;   $metacache{$uri}->{':packages'}.=','.$package;
     } else {      } else {
  $metaentry{':packages'}=$package;   $metacache{$uri}->{':packages'}=$package;
     }      }
     my $value=$packagetab{$key};      my $value=$packagetab{$key};
     my $unikey;      my $unikey;
     $unikey='parameter_0_'.$name;      $unikey='parameter_0_'.$name;
     $metaentry{':'.$unikey.'.part'}=0;      $metacache{$uri}->{':'.$unikey.'.part'}=0;
     $$metathesekeys{$unikey}=1;      $$metathesekeys{$unikey}=1;
     unless (defined($metaentry{':'.$unikey.'.'.$subp})) {      unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) {
  $metaentry{':'.$unikey.'.'.$subp}=$value;   $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value;
     }      }
     if (defined($metaentry{':'.$unikey.'.default'})) {      if (defined($metacache{$uri}->{':'.$unikey.'.default'})) {
  $metaentry{':'.$unikey}=   $metacache{$uri}->{':'.$unikey}=
     $metaentry{':'.$unikey.'.default'};      $metacache{$uri}->{':'.$unikey.'.default'};
     }      }
 }  }
   
Line 4803  sub gettitle { Line 4746  sub gettitle {
     my $urlsymb=shift;      my $urlsymb=shift;
     my $symb=&symbread($urlsymb);      my $symb=&symbread($urlsymb);
     if ($symb) {      if ($symb) {
  my $key=$ENV{'request.course.id'}."\0".$symb;   my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);
  my ($result,$cached)=&is_cached_new('title',$key);  
  if (defined($cached)) {    if (defined($cached)) { 
     return $result;      return $result;
  }   }
Line 4819  sub gettitle { Line 4761  sub gettitle {
  }   }
  $title=~s/\&colon\;/\:/gs;   $title=~s/\&colon\;/\:/gs;
  if ($title) {   if ($title) {
     return &do_cache_new('title',$key,$title,600);      return &do_cache(\%titlecache,$symb,$title,'title');
  }   }
  $urlsymb=$url;   $urlsymb=$url;
     }      }
Line 4933  sub fixversion { Line 4875  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_new('courseresversion',$key);      my ($result,$cached)=&is_cached(\%courseresversioncache,$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 4947  sub fixversion { Line 4890  sub fixversion {
   }    }
   untie %bighash;    untie %bighash;
     }      }
     return &do_cache_new('courseresversion',$key,&declutter($uri),600);      return &do_cache
    (\%courseresversioncache,$key,&declutter($uri),'courseresversion');
 }  }
   
 sub deversion {  sub deversion {
Line 5656  sub correct_line_ends { Line 5600  sub correct_line_ends {
 sub goodbye {  sub goodbye {
    &logthis("Starting Shut down");     &logthis("Starting Shut down");
 #not converted to using infrastruture and probably shouldn't be  #not converted to using infrastruture and probably shouldn't be
    &logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%badServerCache))));     &logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%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',scalar(%homecache)));
 #   &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache))));     &logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache)));
 #   &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache))));     &logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache)));
 #1.1 only  #1.1 only
 #   &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache))));     &logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache)));
 #   &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache))));     &logthis(sprintf("%-20s is %s",'%getsectioncache',scalar(%getsectioncache)));
 #   &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache))));     &logthis(sprintf("%-20s is %s",'%courseresversioncache',scalar(%courseresversioncache)));
 #   &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%resversioncache))));     &logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache)));
    &logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered))));  
    &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 5815  BEGIN { Line 5756  BEGIN {
   
 }  }
   
 $memcache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']});  %metacache=();
   
 $processmarker='_'.time.'_'.$perlvar{'lonHostID'};  $processmarker='_'.time.'_'.$perlvar{'lonHostID'};
 $dumpcount=0;  $dumpcount=0;

Removed from v.1.587.2.3.2.16  
changed lines
  Added in v.1.588


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