[LON-CAPA-cvs] cvs: loncom /lonnet/perl lonnet.pm
albertel
lon-capa-cvs@mail.lon-capa.org
Tue, 07 Oct 2003 07:20:05 -0000
This is a MIME encoded message
--albertel1065511205
Content-Type: text/plain
albertel Tue Oct 7 03:20:05 2003 EDT
Modified files:
/loncom/lonnet/perl lonnet.pm
Log:
- converted to use GDBM on lonnet caches
- converted metacache to use common caching infrastructure
- this looks like it works well and quickly, I wann do some further testing
but nothing is blowing up on me
(Probably still need to try this out on s1 just to get an idea at if it scales well I think it will)
--albertel1065511205
Content-Type: text/plain
Content-Disposition: attachment; filename="albertel-20031007032005.txt"
Index: loncom/lonnet/perl/lonnet.pm
diff -u loncom/lonnet/perl/lonnet.pm:1.427 loncom/lonnet/perl/lonnet.pm:1.428
--- loncom/lonnet/perl/lonnet.pm:1.427 Mon Oct 6 16:38:25 2003
+++ loncom/lonnet/perl/lonnet.pm Tue Oct 7 03:20:05 2003
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.427 2003/10/06 20:38:25 www Exp $
+# $Id: lonnet.pm,v 1.428 2003/10/07 07:20:05 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -86,7 +86,7 @@
use Fcntl qw(:flock);
use Apache::loncoursedata;
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();
my $readit;
@@ -849,24 +849,37 @@
}
sub devalidate_cache {
- my ($cache,$id) = @_;
+ my ($cache,$id,$name) = @_;
delete $$cache{$id.'.time'};
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 {
my ($cache,$id,$name,$time) = @_;
if (!$time) { $time=300; }
if (!exists($$cache{$id.'.time'})) {
- &load_cache($cache,$name);
+ &load_cache_item($cache,$name,$id);
}
if (!exists($$cache{$id.'.time'})) {
# &logthis("Didn't find $id");
return (undef,undef);
} else {
if (time-($$cache{$id.'.time'})>$time) {
-# &logthis("Devailidating $id");
- &devalidate_cache($cache,$id);
+# &logthis("Devailidating $id - ".time-($$cache{$id.'.time'}));
+ &devalidate_cache($cache,$id,$name);
return (undef,undef);
}
}
@@ -877,14 +890,15 @@
my ($cache,$id,$value,$name) = @_;
$$cache{$id.'.time'}=time;
$$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
$$cache{$id};
}
sub save_cache {
my ($cache,$name)=@_;
-# my $starttime=&Time::HiRes::time();
+ my $starttime=&Time::HiRes::time();
# &logthis("Saving :$name:");
eval lock_store($cache,$perlvar{'lonDaemons'}.'/tmp/'.$name.".storable");
if ($@) { &logthis("lock_store threw a die ".$@); }
@@ -893,7 +907,7 @@
sub load_cache {
my ($cache,$name)=@_;
-# my $starttime=&Time::HiRes::time();
+ my $starttime=&Time::HiRes::time();
# &logthis("Before Loading $name size is ".scalar(%$cache));
my $tmpcache;
eval {
@@ -932,6 +946,62 @@
# &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 {
my ($udom,$unam,$courseid)=@_;
my $hashid="$udom:$unam:$courseid";
@@ -3390,7 +3460,7 @@
sub devalidatecourseresdata {
my ($coursenum,$coursedomain)=@_;
my $hashid=$coursenum.':'.$coursedomain;
- &devalidate_cache(\%courseresdatacache,$hashid);
+ &devalidate_cache(\%courseresdatacache,$hashid,'courseres');
}
# --------------------------------------------------- Course Resourcedata Query
@@ -3734,15 +3804,20 @@
# Look at timestamp of caching
# 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?
#
+ my %lcmetacache;
if ($liburi) {
$liburi=&declutter($liburi);
$filename=$liburi;
} else {
- delete($metacache{$uri.':packages'});
+ &devalidate_cache(\%metacache,$uri,'meta');
}
my %metathesekeys=();
unless ($filename=~/\.meta$/) { $filename.='.meta'; }
@@ -3761,10 +3836,10 @@
if (defined($token->[2]->{'id'})) {
$keyroot.='_'.$token->[2]->{'id'};
}
- if ($metacache{$uri.':packages'}) {
- $metacache{$uri.':packages'}.=','.$package.$keyroot;
+ if ($lcmetacache{':packages'}) {
+ $lcmetacache{':packages'}.=','.$package.$keyroot;
} else {
- $metacache{$uri.':packages'}=$package.$keyroot;
+ $lcmetacache{':packages'}=$package.$keyroot;
}
foreach (keys %packagetab) {
if ($_=~/^$package\&/) {
@@ -3779,14 +3854,14 @@
$value.=' [Part: '.$part.']';
}
my $unikey='parameter'.$keyroot.'_'.$name;
- $metacache{$uri.':'.$unikey.'.part'}=$part;
+ $lcmetacache{':'.$unikey.'.part'}=$part;
$metathesekeys{$unikey}=1;
- unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {
- $metacache{$uri.':'.$unikey.'.'.$subp}=$value;
+ unless (defined($lcmetacache{':'.$unikey.'.'.$subp})) {
+ $lcmetacache{':'.$unikey.'.'.$subp}=$value;
}
- if (defined($metacache{$uri.':'.$unikey.'.default'})) {
- $metacache{$uri.':'.$unikey}=
- $metacache{$uri.':'.$unikey.'.default'};
+ if (defined($lcmetacache{':'.$unikey.'.default'})) {
+ $lcmetacache{':'.$unikey}=
+ $lcmetacache{':'.$unikey.'.default'};
}
}
}
@@ -3829,18 +3904,18 @@
}
$metathesekeys{$unikey}=1;
foreach (@{$token->[3]}) {
- $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};
+ $lcmetacache{':'.$unikey.'.'.$_}=$token->[2]->{$_};
}
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*$/) {
# only ws inside the tag, and not in default, so use default
# as value
- $metacache{$uri.':'.$unikey}=$default;
+ $lcmetacache{':'.$unikey}=$default;
} else {
# either something interesting inside the tag or default
# uninteresting
- $metacache{$uri.':'.$unikey}=$internaltext;
+ $lcmetacache{':'.$unikey}=$internaltext;
}
# end of not-a-package not-a-library import
}
@@ -3850,13 +3925,13 @@
}
}
# are there custom rights to evaluate
- if ($metacache{$uri.':copyright'} eq 'custom') {
+ if ($lcmetacache{':copyright'} eq 'custom') {
#
# Importing a rights file here
#
unless ($depthcount) {
- my $location=$metacache{$uri.':customdistributionfile'};
+ my $location=$lcmetacache{':customdistributionfile'};
my $dir=$filename;
$dir=~s|[^/]*$||;
$location=&filelocation($dir,$location);
@@ -3867,13 +3942,13 @@
}
}
}
- $metacache{$uri.':keys'}=join(',',keys %metathesekeys);
- &metadata_generate_part0(\%metathesekeys,\%metacache,$uri);
- $metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys);
- $metacache{$uri.':cachedtimestamp'}=time;
+ $lcmetacache{':keys'}=join(',',keys %metathesekeys);
+ &metadata_generate_part0(\%metathesekeys,\%lcmetacache,$uri);
+ $lcmetacache{':allpossiblekeys'}=join(',',keys %metathesekeys);
+ &do_cache(\%metacache,$uri,\%lcmetacache,'meta');
# this is the end of "was not already recently cached
}
- return $metacache{$uri.':'.$what};
+ return $metacache{$uri}->{':'.$what};
}
sub metadata_generate_part0 {
@@ -3881,8 +3956,8 @@
my %allnames;
foreach my $metakey (sort keys %$metadata) {
if ($metakey=~/^parameter\_(.*)/) {
- my $part=$$metacache{$uri.':'.$metakey.'.part'};
- my $name=$$metacache{$uri.':'.$metakey.'.name'};
+ my $part=$$metacache{':'.$metakey.'.part'};
+ my $name=$$metacache{':'.$metakey.'.name'};
if (! exists($$metadata{'parameter_0_'.$name.'.name'})) {
$allnames{$name}=$part;
}
@@ -3890,13 +3965,13 @@
}
foreach my $name (keys(%allnames)) {
$$metadata{"parameter_0_$name"}=1;
- my $key="$uri:parameter_0_$name";
+ my $key=":parameter_0_$name";
$$metacache{"$key.part"}='0';
$$metacache{"$key.name"}=$name;
- $$metacache{"$key.type"}=$$metacache{$uri.':parameter_'.
+ $$metacache{"$key.type"}=$$metacache{':parameter_'.
$allnames{$name}.'_'.$name.
'.type'};
- my $olddis=$$metacache{$uri.':parameter_'.$allnames{$name}.'_'.$name.
+ my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name.
'.display'};
my $expr='\\[Part: '.$allnames{$name}.'\\]';
$olddis=~s/$expr/\[Part: 0\]/;
--albertel1065511205--