[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.427 and 1.428

version 1.427, 2003/10/06 20:38:25 version 1.428, 2003/10/07 07:20:05
Line 86  use HTML::LCParser; Line 86  use HTML::LCParser;
 use Fcntl qw(:flock);  use Fcntl qw(:flock);
 use Apache::loncoursedata;  use Apache::loncoursedata;
 use Apache::lonlocal;  use Apache::lonlocal;
 use Storable qw(lock_store lock_nstore lock_retrieve);  use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw);
 use Time::HiRes();  use Time::HiRes();
 my $readit;  my $readit;
   
Line 849  sub getsection { Line 849  sub getsection {
 }  }
   
 sub devalidate_cache {  sub devalidate_cache {
     my ($cache,$id) = @_;      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";
       open(DB,"$filename.lock");
       flock(DB,LOCK_EX);
       my %hash;
       if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
    delete($hash{$id});
    delete($hash{$id.'.time'});
       } else {
    &logthis("Unable to tie hash");
       }
       untie(%hash);
       flock(DB,LOCK_UN);
       close(DB);
 }  }
   
 sub is_cached {  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($cache,$name);   &load_cache_item($cache,$name,$id);
     }      }
     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("Devailidating $id");  #    &logthis("Devailidating $id - ".time-($$cache{$id.'.time'}));
     &devalidate_cache($cache,$id);      &devalidate_cache($cache,$id,$name);
     return (undef,undef);      return (undef,undef);
  }   }
     }      }
Line 877  sub do_cache { Line 890  sub do_cache {
     my ($cache,$id,$value,$name) = @_;      my ($cache,$id,$value,$name) = @_;
     $$cache{$id.'.time'}=time;      $$cache{$id.'.time'}=time;
     $$cache{$id}=$value;      $$cache{$id}=$value;
     &save_cache($cache,$name);  #    &logthis("Caching $id as :$value:");
       &save_cache_item($cache,$name,$id);
     # do_cache implictly return the set value      # do_cache implictly return the set value
     $$cache{$id};      $$cache{$id};
 }  }
   
 sub save_cache {  sub save_cache {
     my ($cache,$name)=@_;      my ($cache,$name)=@_;
 #    my $starttime=&Time::HiRes::time();      my $starttime=&Time::HiRes::time();
 #    &logthis("Saving :$name:");  #    &logthis("Saving :$name:");
     eval lock_store($cache,$perlvar{'lonDaemons'}.'/tmp/'.$name.".storable");      eval lock_store($cache,$perlvar{'lonDaemons'}.'/tmp/'.$name.".storable");
     if ($@) { &logthis("lock_store threw a die ".$@); }      if ($@) { &logthis("lock_store threw a die ".$@); }
Line 893  sub save_cache { Line 907  sub save_cache {
   
 sub load_cache {  sub load_cache {
     my ($cache,$name)=@_;      my ($cache,$name)=@_;
 #    my $starttime=&Time::HiRes::time();      my $starttime=&Time::HiRes::time();
 #    &logthis("Before Loading $name size is ".scalar(%$cache));  #    &logthis("Before Loading $name size is ".scalar(%$cache));
     my $tmpcache;      my $tmpcache;
     eval {      eval {
Line 932  sub load_cache { Line 946  sub load_cache {
 #    &logthis("load_cache took ".(&Time::HiRes::time()-$starttime));  #    &logthis("load_cache took ".(&Time::HiRes::time()-$starttime));
 }  }
   
   sub save_cache_item {
       my ($cache,$name,$id)=@_;
       my $starttime=&Time::HiRes::time();
    #   &logthis("Saving :$name:$id");
       my %hash;
       my $filename=$perlvar{'lonDaemons'}.'/tmp/'.$name.".db";
       open(DB,"$filename.lock");
       flock(DB,LOCK_EX);
       if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
    $hash{$id.'.time'}=$$cache{$id.'.time'};
    $hash{$id}=freeze({'item'=>$$cache{$id}});
       } else {
    &logthis("Unable to tie hash");
       }
       untie(%hash);
       flock(DB,LOCK_UN);
       close(DB);
   #    &logthis("save_cache_item $name took ".(&Time::HiRes::time()-$starttime));
   }
   
   sub load_cache_item {
       my ($cache,$name,$id)=@_;
       my $starttime=&Time::HiRes::time();
   #    &logthis("Before Loading $name  for $id size is ".scalar(%$cache));
       my %hash;
       my $filename=$perlvar{'lonDaemons'}.'/tmp/'.$name.".db";
       open(DB,"$filename.lock");
       flock(DB,LOCK_SH);
       if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) {
    if (!%$cache) {
       my $count;
       while (my ($key,$value)=each(%hash)) { 
    $count++;
    if ($key =~ /\.time$/) {
       $$cache{$key}=$value;
    } else {
       my $hashref=thaw($value);
       $$cache{$key}=$hashref->{'item'};
    }
       }
   #    &logthis("Initial load: $count");
    } else {
       my $hashref=thaw($hash{$id});
       $$cache{$id}=$hashref->{'item'};
       $$cache{$id.'.time'}=$hash{$id.'.time'};
    }
       } else {
    &logthis("Unable to tie hash");
       }
       untie(%hash);
       flock(DB,LOCK_UN);
       close(DB);
   #    &logthis("After Loading $name size is ".scalar(%$cache));
   #    &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime));
   }
   
 sub usection {  sub usection {
     my ($udom,$unam,$courseid)=@_;      my ($udom,$unam,$courseid)=@_;
     my $hashid="$udom:$unam:$courseid";      my $hashid="$udom:$unam:$courseid";
Line 3390  sub condval { Line 3460  sub condval {
 sub devalidatecourseresdata {  sub devalidatecourseresdata {
     my ($coursenum,$coursedomain)=@_;      my ($coursenum,$coursedomain)=@_;
     my $hashid=$coursenum.':'.$coursedomain;      my $hashid=$coursenum.':'.$coursedomain;
     &devalidate_cache(\%courseresdatacache,$hashid);      &devalidate_cache(\%courseresdatacache,$hashid,'courseres');
 }  }
   
 # --------------------------------------------------- Course Resourcedata Query  # --------------------------------------------------- Course Resourcedata Query
Line 3734  sub metadata { Line 3804  sub metadata {
 # Look at timestamp of caching  # Look at timestamp of caching
 # Everything is cached by the main uri, libraries are never directly cached  # Everything is cached by the main uri, libraries are never directly cached
 #  #
     unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600 && !defined($liburi)) {      if (!defined($liburi)) {
    my ($result,$cached)=&is_cached(\%metacache,$uri,'meta');
    if (defined($cached)) { return $result->{':'.$what}; }
       }
       {
 #  #
 # Is this a recursive call for a library?  # Is this a recursive call for a library?
 #  #
    my %lcmetacache;
         if ($liburi) {          if ($liburi) {
     $liburi=&declutter($liburi);      $liburi=&declutter($liburi);
             $filename=$liburi;              $filename=$liburi;
         } else {          } else {
     delete($metacache{$uri.':packages'});      &devalidate_cache(\%metacache,$uri,'meta');
  }   }
         my %metathesekeys=();          my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }          unless ($filename=~/\.meta$/) { $filename.='.meta'; }
Line 3761  sub metadata { Line 3836  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 ($lcmetacache{':packages'}) {
  $metacache{$uri.':packages'}.=','.$package.$keyroot;   $lcmetacache{':packages'}.=','.$package.$keyroot;
     } else {      } else {
  $metacache{$uri.':packages'}=$package.$keyroot;   $lcmetacache{':packages'}=$package.$keyroot;
     }      }
     foreach (keys %packagetab) {      foreach (keys %packagetab) {
  if ($_=~/^$package\&/) {   if ($_=~/^$package\&/) {
Line 3779  sub metadata { Line 3854  sub metadata {
  $value.=' [Part: '.$part.']';   $value.=' [Part: '.$part.']';
     }      }
     my $unikey='parameter'.$keyroot.'_'.$name;      my $unikey='parameter'.$keyroot.'_'.$name;
     $metacache{$uri.':'.$unikey.'.part'}=$part;      $lcmetacache{':'.$unikey.'.part'}=$part;
     $metathesekeys{$unikey}=1;      $metathesekeys{$unikey}=1;
     unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {      unless (defined($lcmetacache{':'.$unikey.'.'.$subp})) {
  $metacache{$uri.':'.$unikey.'.'.$subp}=$value;   $lcmetacache{':'.$unikey.'.'.$subp}=$value;
     }      }
     if (defined($metacache{$uri.':'.$unikey.'.default'})) {      if (defined($lcmetacache{':'.$unikey.'.default'})) {
  $metacache{$uri.':'.$unikey}=   $lcmetacache{':'.$unikey}=
     $metacache{$uri.':'.$unikey.'.default'};      $lcmetacache{':'.$unikey.'.default'};
     }      }
  }   }
     }      }
Line 3829  sub metadata { Line 3904  sub metadata {
  }   }
  $metathesekeys{$unikey}=1;   $metathesekeys{$unikey}=1;
  foreach (@{$token->[3]}) {   foreach (@{$token->[3]}) {
     $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};      $lcmetacache{':'.$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=$lcmetacache{':'.$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;      $lcmetacache{':'.$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;      $lcmetacache{':'.$unikey}=$internaltext;
  }   }
 # end of not-a-package not-a-library import  # end of not-a-package not-a-library import
     }      }
Line 3850  sub metadata { Line 3925  sub metadata {
     }      }
  }   }
 # are there custom rights to evaluate  # are there custom rights to evaluate
  if ($metacache{$uri.':copyright'} eq 'custom') {   if ($lcmetacache{':copyright'} eq 'custom') {
   
     #      #
     # Importing a rights file here      # Importing a rights file here
     #      #
     unless ($depthcount) {      unless ($depthcount) {
  my $location=$metacache{$uri.':customdistributionfile'};   my $location=$lcmetacache{':customdistributionfile'};
  my $dir=$filename;   my $dir=$filename;
  $dir=~s|[^/]*$||;   $dir=~s|[^/]*$||;
  $location=&filelocation($dir,$location);   $location=&filelocation($dir,$location);
Line 3867  sub metadata { Line 3942  sub metadata {
  }   }
     }      }
  }   }
  $metacache{$uri.':keys'}=join(',',keys %metathesekeys);   $lcmetacache{':keys'}=join(',',keys %metathesekeys);
  &metadata_generate_part0(\%metathesekeys,\%metacache,$uri);   &metadata_generate_part0(\%metathesekeys,\%lcmetacache,$uri);
  $metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys);   $lcmetacache{':allpossiblekeys'}=join(',',keys %metathesekeys);
  $metacache{$uri.':cachedtimestamp'}=time;   &do_cache(\%metacache,$uri,\%lcmetacache,'meta');
 # 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 $metacache{$uri}->{':'.$what};
 }  }
   
 sub metadata_generate_part0 {  sub metadata_generate_part0 {
Line 3881  sub metadata_generate_part0 { Line 3956  sub metadata_generate_part0 {
     my %allnames;      my %allnames;
     foreach my $metakey (sort keys %$metadata) {      foreach my $metakey (sort keys %$metadata) {
  if ($metakey=~/^parameter\_(.*)/) {   if ($metakey=~/^parameter\_(.*)/) {
   my $part=$$metacache{$uri.':'.$metakey.'.part'};    my $part=$$metacache{':'.$metakey.'.part'};
   my $name=$$metacache{$uri.':'.$metakey.'.name'};    my $name=$$metacache{':'.$metakey.'.name'};
   if (! exists($$metadata{'parameter_0_'.$name.'.name'})) {    if (! exists($$metadata{'parameter_0_'.$name.'.name'})) {
     $allnames{$name}=$part;      $allnames{$name}=$part;
   }    }
Line 3890  sub metadata_generate_part0 { Line 3965  sub metadata_generate_part0 {
     }      }
     foreach my $name (keys(%allnames)) {      foreach my $name (keys(%allnames)) {
       $$metadata{"parameter_0_$name"}=1;        $$metadata{"parameter_0_$name"}=1;
       my $key="$uri:parameter_0_$name";        my $key=":parameter_0_$name";
       $$metacache{"$key.part"}='0';        $$metacache{"$key.part"}='0';
       $$metacache{"$key.name"}=$name;        $$metacache{"$key.name"}=$name;
       $$metacache{"$key.type"}=$$metacache{$uri.':parameter_'.        $$metacache{"$key.type"}=$$metacache{':parameter_'.
    $allnames{$name}.'_'.$name.     $allnames{$name}.'_'.$name.
    '.type'};     '.type'};
       my $olddis=$$metacache{$uri.':parameter_'.$allnames{$name}.'_'.$name.        my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name.
      '.display'};       '.display'};
       my $expr='\\[Part: '.$allnames{$name}.'\\]';        my $expr='\\[Part: '.$allnames{$name}.'\\]';
       $olddis=~s/$expr/\[Part: 0\]/;        $olddis=~s/$expr/\[Part: 0\]/;
Removed from v.1.427  
changed lines
  Added in v.1.428

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