[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.539 and 1.545.2.1

version 1.539, 2004/09/02 21:23:13 version 1.545.2.1, 2004/09/22 18:31:12
Line 36  use HTTP::Date; Line 36  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 %homecache %badServerCache %hostip %iphost %spareid %hostdom 
    %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache     %libserv %pr %prp $metacache %packagetab %titlecache %courseresversioncache %resversioncache
    %courselogs %accesshash %userrolehash $processmarker $dumpcount      %courselogs %accesshash %userrolehash $processmarker $dumpcount 
    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache      %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache 
    %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def      %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def 
Line 51  use Apache::loncoursedata; Line 51  use Apache::loncoursedata;
 use Apache::lonlocal;  use Apache::lonlocal;
 use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw);  use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw);
 use Time::HiRes qw( gettimeofday tv_interval );  use Time::HiRes qw( gettimeofday tv_interval );
   use Cache::Memcached;
 my $readit;  my $readit;
   
 =pod  =pod
Line 826  my $disk_caching_disabled=1; Line 827  my $disk_caching_disabled=1;
 sub devalidate_cache {  sub devalidate_cache {
     my ($cache,$id,$name) = @_;      my ($cache,$id,$name) = @_;
     delete $$cache{$id.'.time'};      delete $$cache{$id.'.time'};
       delete $$cache{$id.'.file'};
     delete $$cache{$id};      delete $$cache{$id};
     if ($disk_caching_disabled) { return; }      if (1 || $disk_caching_disabled) { return; }
     my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";      my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
     open(DB,"$filename.lock");      if (!-e $filename) { return; }
       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)) {
Line 856  sub is_cached { Line 859  sub is_cached {
     my ($cache,$id,$name,$time) = @_;      my ($cache,$id,$name,$time) = @_;
     if (!$time) { $time=300; }      if (!$time) { $time=300; }
     if (!exists($$cache{$id.'.time'})) {      if (!exists($$cache{$id.'.time'})) {
  &load_cache_item($cache,$name,$id);   &load_cache_item($cache,$name,$id,$time);
     }      }
     if (!exists($$cache{$id.'.time'})) {      if (!exists($$cache{$id.'.time'})) {
 # &logthis("Didn't find $id");  # &logthis("Didn't find $id");
  return (undef,undef);   return (undef,undef);
     } else {      } else {
  if (time-($$cache{$id.'.time'})>$time) {   if (time-($$cache{$id.'.time'})>$time) {
 #    &logthis("Devalidating $id - ".time-($$cache{$id.'.time'}));      if (exists($$cache{$id.'.file'})) {
     &devalidate_cache($cache,$id,$name);   foreach my $filename (@{ $$cache{$id.'.file'} }) {
     return (undef,undef);      my $mtime=(stat($filename))[9];
       #+1 is to take care of edge effects
       if ($mtime && (($mtime+1) < ($$cache{$id.'.time'}))) {
   # &logthis("Upping $mtime - ".$$cache{$id.'.time'}.
   # "$id because of $filename");
       } else {
   # &logthis("Devalidating $filename $id - ".(time-($$cache{$id.'.time'})));
    &devalidate_cache($cache,$id,$name);
    return (undef,undef);
       }
    }
    $$cache{$id.'.time'}=time;
       } else {
   # &logthis("Devalidating $id - ".time-($$cache{$id.'.time'}));
    &devalidate_cache($cache,$id,$name);
    return (undef,undef);
       }
  }   }
     }      }
     return ($$cache{$id},1);      return ($$cache{$id},1);
Line 881  sub do_cache { Line 900  sub do_cache {
     $$cache{$id};      $$cache{$id};
 }  }
   
   my %do_save_item;
   my %do_save;
 sub save_cache_item {  sub save_cache_item {
     my ($cache,$name,$id)=@_;      my ($cache,$name,$id)=@_;
     if ($disk_caching_disabled) { return; }      if ($disk_caching_disabled) { return; }
     my $starttime=&Time::HiRes::time();      $do_save{$name}=$cache;
 #    &logthis("Saving :$name:$id");      if (!exists($do_save_item{$name})) { $do_save_item{$name}={} }
     my %hash;      $do_save_item{$name}->{$id}=1;
     my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";      return;
     open(DB,"$filename.lock");  }
     flock(DB,LOCK_EX);  
     if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {  sub save_cache {
  eval <<'EVALBLOCK';      if ($disk_caching_disabled) { return; }
     $hash{$id.'.time'}=$$cache{$id.'.time'};      my ($cache,$name,$id);
     $hash{$id}=freeze({'item'=>$$cache{$id}});      foreach $name (keys(%do_save)) {
    $cache=$do_save{$name};
   
    my $starttime=&Time::HiRes::time();
    &logthis("Saving :$name:");
    my %hash;
    my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
    open(DB,">$filename.lock");
    flock(DB,LOCK_EX);
    if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
       foreach $id (keys(%{ $do_save_item{$name} })) {
    eval <<'EVALBLOCK';
    $hash{$id.'.time'}=$$cache{$id.'.time'};
    $hash{$id}=freeze({'item'=>$$cache{$id}});
    if (exists($$cache{$id.'.file'})) {
       $hash{$id.'.file'}=freeze({'item'=>$$cache{$id.'.file'}});
    }
 EVALBLOCK  EVALBLOCK
         if ($@) {                  if ($@) {
     &logthis("<font color='red'>save_cache blew up :$@:$name</font>");      &logthis("<font color='red'>save_cache blew up :$@:$name</font>");
     unlink($filename);      unlink($filename);
  }      last;
     } else {   }
  if (-e $filename) {      }
     &logthis("Unable to tie hash (save cache item): $name ($!)");   } else {
     unlink($filename);      if (-e $filename) {
    &logthis("Unable to tie hash (save cache): $name ($!)");
    unlink($filename);
       }
  }   }
    untie(%hash);
    flock(DB,LOCK_UN);
    close(DB);
    &logthis("save_cache $name took ".(&Time::HiRes::time()-$starttime));
     }      }
     untie(%hash);      undef(%do_save);
     flock(DB,LOCK_UN);      undef(%do_save_item);
     close(DB);  
 #    &logthis("save_cache_item $name took ".(&Time::HiRes::time()-$starttime));  
 }  }
   
 sub load_cache_item {  sub load_cache_item {
     my ($cache,$name,$id)=@_;      my ($cache,$name,$id,$time)=@_;
     if ($disk_caching_disabled) { return; }      if ($disk_caching_disabled) { return; }
     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/lonnet_internal_cache_'.$name.".db";      my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
     open(DB,"$filename.lock");      if (!-e $filename) { return; }
       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)) {
  eval <<'EVALBLOCK';   eval <<'EVALBLOCK';
Line 935  sub load_cache_item { Line 979  sub load_cache_item {
  }   }
 #    &logthis("Initial load: $count");  #    &logthis("Initial load: $count");
     } else {      } else {
  my $hashref=thaw($hash{$id});   if (($$cache{$id.'.time'}+$time) < time) {
  $$cache{$id}=$hashref->{'item'};      $$cache{$id.'.time'}=$hash{$id.'.time'};
  $$cache{$id.'.time'}=$hash{$id.'.time'};      {
    my $hashref=thaw($hash{$id});
    $$cache{$id}=$hashref->{'item'};
       }
       if (exists($hash{$id.'.file'})) {
    my $hashref=thaw($hash{$id.'.file'});
    $$cache{$id.'.file'}=$hashref->{'item'};
       }
    }
     }      }
 EVALBLOCK  EVALBLOCK
         if ($@) {          if ($@) {
Line 957  EVALBLOCK Line 1009  EVALBLOCK
 #    &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime));  #    &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime));
 }  }
   
   sub devalidate_cache_new {
       my ($cache,$name,$id) = @_;
       if (0) { &Apache::lonnet::logthis("deleting $name:$id"); }
       $cache->delete($name.':'.$id);
   }
   
   my $lastone;
   my $lastname;
   sub is_cached_new {
       my ($cache,$name,$id,$debug) = @_;
       $debug=0;
       $id=$name.':'.$id;
       if ($lastname eq $id) {
    if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $lastone <= $lastname "); }
    return ($lastone,1);
       }
       undef($lastone);
       undef($lastname);
       my $value = $cache->get($id);
       if (!(defined($value))) {
    if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }
    return (undef,undef);
       }
       $lastname=$id;
       if ($value eq '__undef__') {
    if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); }
    return (undef,1);
       }
       if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }
       $lastone=$value;
       return ($value,1);
   }
   
   sub do_cache_new {
       my ($cache,$name,$id,$value,$time,$debug) = @_;
       $debug=0;
       $id=$name.':'.$id;
       my $setvalue=$value;
       if (!defined($setvalue)) {
    $setvalue='__undef__';
       }
       if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }
       $cache->set($id,$setvalue,300);
       return $value;
   }
   
 sub usection {  sub usection {
     my ($udom,$unam,$courseid)=@_;      my ($udom,$unam,$courseid)=@_;
     my $hashid="$udom:$unam:$courseid";      my $hashid="$udom:$unam:$courseid";
Line 1284  sub clean_filename { Line 1382  sub clean_filename {
     $fname=~s/\s+/\_/g;      $fname=~s/\s+/\_/g;
 # Replace all other weird characters by nothing  # Replace all other weird characters by nothing
     $fname=~s/[^\w\.\-]//g;      $fname=~s/[^\w\.\-]//g;
   # Replace all .\d. sequences with _\d. so they no longer look like version
   # numbers
       $fname=~s/\.(\d+)(?=\.)/_$1/g;
     return $fname;      return $fname;
 }  }
   
Line 2152  sub tmprestore { Line 2253  sub tmprestore {
 }  }
   
 # ----------------------------------------------------------------------- Store  # ----------------------------------------------------------------------- Store
   my $memcache_store=0;
 sub store {  sub store {
     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;      my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
     my $home='';      my $home='';
Line 2166  sub store { Line 2267  sub store {
     if (!$stuname) { $stuname=$ENV{'user.name'}; }      if (!$stuname) { $stuname=$ENV{'user.name'}; }
   
     &devalidate($symb,$stuname,$domain);      &devalidate($symb,$stuname,$domain);
   
     $symb=escape($symb);      $symb=escape($symb);
       $memcache_store &&
    $metacache->delete("store:".$symb.":".$stuname.":".$domain.':'.$namespace);
     if (!$namespace) {       if (!$namespace) { 
        unless ($namespace=$ENV{'request.course.id'}) {          unless ($namespace=$ENV{'request.course.id'}) { 
           return '';             return ''; 
Line 2202  sub cstore { Line 2304  sub cstore {
     if (!$stuname) { $stuname=$ENV{'user.name'}; }      if (!$stuname) { $stuname=$ENV{'user.name'}; }
   
     &devalidate($symb,$stuname,$domain);      &devalidate($symb,$stuname,$domain);
   
     $symb=escape($symb);      $symb=escape($symb);
       $memcache_store &&
    $metacache->delete("store:".$symb.":".$stuname.":".$domain.':'.$namespace);
     if (!$namespace) {       if (!$namespace) { 
        unless ($namespace=$ENV{'request.course.id'}) {          unless ($namespace=$ENV{'request.course.id'}) { 
           return '';             return ''; 
Line 2245  sub restore { Line 2348  sub restore {
     if (!$domain) { $domain=$ENV{'user.domain'}; }      if (!$domain) { $domain=$ENV{'user.domain'}; }
     if (!$stuname) { $stuname=$ENV{'user.name'}; }      if (!$stuname) { $stuname=$ENV{'user.name'}; }
     if (!$home) { $home=$ENV{'user.home'}; }      if (!$home) { $home=$ENV{'user.home'}; }
       if ($memcache_store) {
    my $rethash=$metacache->get("store:".$symb.":".$stuname.":".
       $domain.':'.$namespace);
    if ($rethash) { return %{$rethash}; }
       }
     my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");      my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");
   
     my %returnhash=();      my %returnhash=();
Line 2258  sub restore { Line 2366  sub restore {
           $returnhash{$_}=$returnhash{$version.':'.$_};            $returnhash{$_}=$returnhash{$version.':'.$_};
        }         }
     }      }
       if ($memcache_store) {
    $metacache->set("store:".$symb.":".$stuname.":".$domain.':'.$namespace,
    \%returnhash);
       }
     return %returnhash;      return %returnhash;
 }  }
   
Line 2720  sub allowed { Line 2832  sub allowed {
     $uri=&deversion($uri);      $uri=&deversion($uri);
     my $orguri=$uri;      my $orguri=$uri;
     $uri=&declutter($uri);      $uri=&declutter($uri);
       
       
       
     if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; }      if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; }
 # Free bre access to adm and meta resources  # Free bre access to adm and meta resources
     if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|))       if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|)) 
Line 2728  sub allowed { Line 2842  sub allowed {
  return 'F';   return 'F';
     }      }
   
   # Free bre access to user's own portfolio contents
       $uri=~m:([^/]+)/([^/]+)/([^/]+)/([^/]+)/:;
       if (('uploaded' eq $1)&&($ENV{'user.name'} eq $3) && ($ENV{'user.domain'} eq $2) && ('portfolio' eq $4)) {
           return 'F';
       }
   
 # Free bre to public access  # Free bre to public access
   
     if ($priv eq 'bre') {      if ($priv eq 'bre') {
Line 4195  sub add_prefix_and_part { Line 4315  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 4214  sub metadata { Line 4335  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(\%metacache,$uri,'meta');   my ($result,$cached)=&is_cached_new($metacache,'meta',$uri);
  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(\%metacache,$uri,'meta');      &devalidate_cache_new($metacache,'meta',$uri);
       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/|) {
     $metastring=&getfile(&filelocation('',&clutter($filename)));      my $file=&filelocation('',&clutter($filename));
       #push(@{$metaentry{$uri.'.file'}},$file);
       $metastring=&getfile($file);
  }   }
         my $parser=HTML::LCParser->new(\$metastring);          my $parser=HTML::LCParser->new(\$metastring);
         my $token;          my $token;
Line 4250  sub metadata { Line 4374  sub metadata {
     if (defined($token->[2]->{'id'})) {       if (defined($token->[2]->{'id'})) { 
  $keyroot.='_'.$token->[2]->{'id'};    $keyroot.='_'.$token->[2]->{'id'}; 
     }      }
     if ($metacache{$uri}->{':packages'}) {      if ($metaentry{':packages'}) {
  $metacache{$uri}->{':packages'}.=','.$package.$keyroot;   $metaentry{':packages'}.=','.$package.$keyroot;
     } else {      } else {
  $metacache{$uri}->{':packages'}=$package.$keyroot;   $metaentry{':packages'}=$package.$keyroot;
     }      }
     foreach (keys %packagetab) {      foreach (keys %packagetab) {
  my $part=$keyroot;   my $part=$keyroot;
Line 4275  sub metadata { Line 4399  sub metadata {
     if ($subp eq 'display') {      if ($subp eq 'display') {
  $value.=' [Part: '.$part.']';   $value.=' [Part: '.$part.']';
     }      }
     $metacache{$uri}->{':'.$unikey.'.part'}=$part;      $metaentry{':'.$unikey.'.part'}=$part;
     $metathesekeys{$unikey}=1;      $metathesekeys{$unikey}=1;
     unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) {      unless (defined($metaentry{':'.$unikey.'.'.$subp})) {
  $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value;   $metaentry{':'.$unikey.'.'.$subp}=$value;
     }      }
     if (defined($metacache{$uri}->{':'.$unikey.'.default'})) {      if (defined($metaentry{':'.$unikey.'.default'})) {
  $metacache{$uri}->{':'.$unikey}=   $metaentry{':'.$unikey}=
     $metacache{$uri}->{':'.$unikey.'.default'};      $metaentry{':'.$unikey.'.default'};
     }      }
  }   }
     }      }
Line 4315  sub metadata { Line 4439  sub metadata {
     foreach (sort(split(/\,/,&metadata($uri,'keys',      foreach (sort(split(/\,/,&metadata($uri,'keys',
        $location,$unikey,         $location,$unikey,
        $depthcount+1)))) {         $depthcount+1)))) {
  $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_};   $metaentry{':'.$_}=$metaentry{':'.$_};
  $metathesekeys{$_}=1;   $metathesekeys{$_}=1;
     }      }
  }   }
Line 4326  sub metadata { Line 4450  sub metadata {
  }   }
  $metathesekeys{$unikey}=1;   $metathesekeys{$unikey}=1;
  foreach (@{$token->[3]}) {   foreach (@{$token->[3]}) {
     $metacache{$uri}->{':'.$unikey.'.'.$_}=$token->[2]->{$_};      $metaentry{':'.$unikey.'.'.$_}=$token->[2]->{$_};
  }   }
  my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));   my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
  my $default=$metacache{$uri}->{':'.$unikey.'.default'};   my $default=$metaentry{':'.$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
     $metacache{$uri}->{':'.$unikey}=$default;      $metaentry{':'.$unikey}=$default;
  } else {   } else {
   # either something interesting inside the tag or default    # either something interesting inside the tag or default
                   # uninteresting                    # uninteresting
     $metacache{$uri}->{':'.$unikey}=$internaltext;      $metaentry{':'.$unikey}=$internaltext;
  }   }
 # end of not-a-package not-a-library import  # end of not-a-package not-a-library import
     }      }
Line 4354  sub metadata { Line 4478  sub metadata {
     &metadata_create_package_def($uri,$key,'extension_'.$extension,      &metadata_create_package_def($uri,$key,'extension_'.$extension,
  \%metathesekeys);   \%metathesekeys);
  }   }
  if (!exists($metacache{$uri}->{':packages'})) {   if (!exists($metaentry{':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 4363  sub metadata { Line 4487  sub metadata {
     }      }
  }   }
 # are there custom rights to evaluate  # are there custom rights to evaluate
  if ($metacache{$uri}->{':copyright'} eq 'custom') {   if ($metaentry{':copyright'} eq 'custom') {
   
     #      #
     # Importing a rights file here      # Importing a rights file here
     #      #
     unless ($depthcount) {      unless ($depthcount) {
  my $location=$metacache{$uri}->{':customdistributionfile'};   my $location=$metaentry{':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)))) {
     $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_};      #$metaentry{':'.$_}=$metacache{$uri}->{':'.$_};
     $metathesekeys{$_}=1;      $metathesekeys{$_}=1;
  }   }
     }      }
  }   }
  $metacache{$uri}->{':keys'}=join(',',keys %metathesekeys);   $metaentry{':keys'}=join(',',keys %metathesekeys);
  &metadata_generate_part0(\%metathesekeys,$metacache{$uri},$uri);   &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
  $metacache{$uri}->{':allpossiblekeys'}=join(',',keys %metathesekeys);   $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
  &do_cache(\%metacache,$uri,$metacache{$uri},'meta');   &do_cache_new($metacache,'meta',$uri,\%metaentry);
 # this is the end of "was not already recently cached  # this is the end of "was not already recently cached
     }      }
     return $metacache{$uri}->{':'.$what};      return $metaentry{':'.$what};
 }  }
   
 sub metadata_create_package_def {  sub metadata_create_package_def {
Line 4395  sub metadata_create_package_def { Line 4519  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($metacache{$uri}->{':packages'})) {      if (defined($metaentry{':packages'})) {
  $metacache{$uri}->{':packages'}.=','.$package;   $metaentry{':packages'}.=','.$package;
     } else {      } else {
  $metacache{$uri}->{':packages'}=$package;   $metaentry{':packages'}=$package;
     }      }
     my $value=$packagetab{$key};      my $value=$packagetab{$key};
     my $unikey;      my $unikey;
     $unikey='parameter_0_'.$name;      $unikey='parameter_0_'.$name;
     $metacache{$uri}->{':'.$unikey.'.part'}=0;      $metaentry{':'.$unikey.'.part'}=0;
     $$metathesekeys{$unikey}=1;      $$metathesekeys{$unikey}=1;
     unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) {      unless (defined($metaentry{':'.$unikey.'.'.$subp})) {
  $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value;   $metaentry{':'.$unikey.'.'.$subp}=$value;
     }      }
     if (defined($metacache{$uri}->{':'.$unikey.'.default'})) {      if (defined($metaentry{':'.$unikey.'.default'})) {
  $metacache{$uri}->{':'.$unikey}=   $metaentry{':'.$unikey}=
     $metacache{$uri}->{':'.$unikey.'.default'};      $metaentry{':'.$unikey.'.default'};
     }      }
 }  }
   
Line 4599  sub deversion { Line 4723  sub deversion {
   
 sub symbread {  sub symbread {
     my ($thisfn,$donotrecurse)=@_;      my ($thisfn,$donotrecurse)=@_;
     if (defined($ENV{'request.symbread.cached'})) {      my $cache_str='request.symbread.cached.'.$thisfn;
  return $ENV{'request.symbread.cached'};      if (defined($ENV{$cache_str})) { return $ENV{$cache_str}; }
     }  
 # no filename provided? try from environment  # no filename provided? try from environment
     unless ($thisfn) {      unless ($thisfn) {
         if ($ENV{'request.symb'}) {          if ($ENV{'request.symb'}) {
     $ENV{'request.symbread.cached'}=&symbclean($ENV{'request.symb'});      return $ENV{$cache_str}=&symbclean($ENV{'request.symb'});
     return $ENV{'request.symbread.cached'};  
  }   }
  $thisfn=$ENV{'request.filename'};   $thisfn=$ENV{'request.filename'};
     }      }
 # is that filename actually a symb? Verify, clean, and return  # is that filename actually a symb? Verify, clean, and return
     if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {      if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {
  if (&symbverify($thisfn,$1)) {   if (&symbverify($thisfn,$1)) {
     $ENV{'request.symbread.cached'}=&symbclean($thisfn);      return $ENV{$cache_str}=&symbclean($thisfn);
     return $ENV{'request.symbread.cached'};  
  }   }
     }      }
     $thisfn=declutter($thisfn);      $thisfn=declutter($thisfn);
Line 4636  sub symbread { Line 4757  sub symbread {
            unless ($syval=~/\_\d+$/) {             unless ($syval=~/\_\d+$/) {
        unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {         unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {
                   &appenv('request.ambiguous' => $thisfn);                    &appenv('request.ambiguous' => $thisfn);
   $ENV{'request.symbread.cached'}='';    return $ENV{$cache_str}='';
                   return '';  
                }                     }    
                $syval.=$1;                 $syval.=$1;
    }     }
Line 4684  sub symbread { Line 4804  sub symbread {
            }             }
         }          }
         if ($syval) {          if ($syval) {
     $ENV{'request.symbread.cached'}=&symbclean($syval.'___'.$thisfn);      return $ENV{$cache_str}=&symbclean($syval.'___'.$thisfn);
     return $ENV{'request.symbread.cached'};  
         }          }
     }      }
     &appenv('request.ambiguous' => $thisfn);      &appenv('request.ambiguous' => $thisfn);
     $ENV{'request.symbread.cached'}='';      return $ENV{$cache_str}='';
     return '';  
 }  }
   
 # ---------------------------------------------------------- Return random seed  # ---------------------------------------------------------- Return random seed
Line 5199  sub goodbye { Line 5317  sub goodbye {
 #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',scalar(%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',scalar(%homecache)));     &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)));
Line 5352  BEGIN { Line 5470  BEGIN {
   
 }  }
   
 %metacache=();  $metacache=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.539  
changed lines
  Added in v.1.545.2.1

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