[LON-CAPA-cvs] cvs: loncom(memcached) /lonnet/perl lonnet.pm
albertel
lon-capa-cvs@mail.lon-capa.org
Wed, 22 Sep 2004 18:31:12 -0000
This is a MIME encoded message
--albertel1095877872
Content-Type: text/plain
albertel Wed Sep 22 14:31:12 2004 EDT
Modified files: (Branch: memcached)
/loncom/lonnet/perl lonnet.pm
Log:
- a branch that uses Cache::memcached for caching metadata, and store/restore data
--albertel1095877872
Content-Type: text/plain
Content-Disposition: attachment; filename="albertel-20040922143112.txt"
Index: loncom/lonnet/perl/lonnet.pm
diff -u loncom/lonnet/perl/lonnet.pm:1.545 loncom/lonnet/perl/lonnet.pm:1.545.2.1
--- loncom/lonnet/perl/lonnet.pm:1.545 Tue Sep 21 18:38:10 2004
+++ loncom/lonnet/perl/lonnet.pm Wed Sep 22 14:31:12 2004
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.545 2004/09/21 22:38:10 banghart Exp $
+# $Id: lonnet.pm,v 1.545.2.1 2004/09/22 18:31:12 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -36,7 +36,7 @@
# use Date::Parse;
use vars
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
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache
%userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def
@@ -51,6 +51,7 @@
use Apache::lonlocal;
use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw);
use Time::HiRes qw( gettimeofday tv_interval );
+use Cache::Memcached;
my $readit;
=pod
@@ -821,7 +822,7 @@
}
-my $disk_caching_disabled=0;
+my $disk_caching_disabled=1;
sub devalidate_cache {
my ($cache,$id,$name) = @_;
@@ -873,7 +874,7 @@
# &logthis("Upping $mtime - ".$$cache{$id.'.time'}.
# "$id because of $filename");
} else {
- &logthis("Devalidating $filename $id - ".(time-($$cache{$id.'.time'})));
+# &logthis("Devalidating $filename $id - ".(time-($$cache{$id.'.time'})));
&devalidate_cache($cache,$id,$name);
return (undef,undef);
}
@@ -1008,6 +1009,52 @@
# &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 {
my ($udom,$unam,$courseid)=@_;
my $hashid="$udom:$unam:$courseid";
@@ -2206,7 +2253,7 @@
}
# ----------------------------------------------------------------------- Store
-
+my $memcache_store=0;
sub store {
my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
my $home='';
@@ -2220,8 +2267,9 @@
if (!$stuname) { $stuname=$ENV{'user.name'}; }
&devalidate($symb,$stuname,$domain);
-
$symb=escape($symb);
+ $memcache_store &&
+ $metacache->delete("store:".$symb.":".$stuname.":".$domain.':'.$namespace);
if (!$namespace) {
unless ($namespace=$ENV{'request.course.id'}) {
return '';
@@ -2256,8 +2304,9 @@
if (!$stuname) { $stuname=$ENV{'user.name'}; }
&devalidate($symb,$stuname,$domain);
-
$symb=escape($symb);
+ $memcache_store &&
+ $metacache->delete("store:".$symb.":".$stuname.":".$domain.':'.$namespace);
if (!$namespace) {
unless ($namespace=$ENV{'request.course.id'}) {
return '';
@@ -2299,6 +2348,11 @@
if (!$domain) { $domain=$ENV{'user.domain'}; }
if (!$stuname) { $stuname=$ENV{'user.name'}; }
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 %returnhash=();
@@ -2312,6 +2366,10 @@
$returnhash{$_}=$returnhash{$version.':'.$_};
}
}
+ if ($memcache_store) {
+ $metacache->set("store:".$symb.":".$stuname.":".$domain.':'.$namespace,
+ \%returnhash);
+ }
return %returnhash;
}
@@ -4257,6 +4315,7 @@
# ---------------------------------------------------------------- Get metadata
+my %metaentry;
sub metadata {
my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
$uri=&declutter($uri);
@@ -4276,28 +4335,29 @@
# Everything is cached by the main uri, libraries are never directly cached
#
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}; }
}
{
#
# Is this a recursive call for a library?
#
- if (! exists($metacache{$uri})) {
- $metacache{$uri}={};
- }
+# if (! exists($metacache{$uri})) {
+# $metacache{$uri}={};
+# }
if ($liburi) {
$liburi=&declutter($liburi);
$filename=$liburi;
} else {
- &devalidate_cache(\%metacache,$uri,'meta');
+ &devalidate_cache_new($metacache,'meta',$uri);
+ undef(%metaentry);
}
my %metathesekeys=();
unless ($filename=~/\.meta$/) { $filename.='.meta'; }
my $metastring;
if ($uri !~ m|^uploaded/|) {
my $file=&filelocation('',&clutter($filename));
- push(@{$metacache{$uri.'.file'}},$file);
+ #push(@{$metaentry{$uri.'.file'}},$file);
$metastring=&getfile($file);
}
my $parser=HTML::LCParser->new(\$metastring);
@@ -4314,10 +4374,10 @@
if (defined($token->[2]->{'id'})) {
$keyroot.='_'.$token->[2]->{'id'};
}
- if ($metacache{$uri}->{':packages'}) {
- $metacache{$uri}->{':packages'}.=','.$package.$keyroot;
+ if ($metaentry{':packages'}) {
+ $metaentry{':packages'}.=','.$package.$keyroot;
} else {
- $metacache{$uri}->{':packages'}=$package.$keyroot;
+ $metaentry{':packages'}=$package.$keyroot;
}
foreach (keys %packagetab) {
my $part=$keyroot;
@@ -4339,14 +4399,14 @@
if ($subp eq 'display') {
$value.=' [Part: '.$part.']';
}
- $metacache{$uri}->{':'.$unikey.'.part'}=$part;
+ $metaentry{':'.$unikey.'.part'}=$part;
$metathesekeys{$unikey}=1;
- unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) {
- $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value;
+ unless (defined($metaentry{':'.$unikey.'.'.$subp})) {
+ $metaentry{':'.$unikey.'.'.$subp}=$value;
}
- if (defined($metacache{$uri}->{':'.$unikey.'.default'})) {
- $metacache{$uri}->{':'.$unikey}=
- $metacache{$uri}->{':'.$unikey.'.default'};
+ if (defined($metaentry{':'.$unikey.'.default'})) {
+ $metaentry{':'.$unikey}=
+ $metaentry{':'.$unikey.'.default'};
}
}
}
@@ -4379,7 +4439,7 @@
foreach (sort(split(/\,/,&metadata($uri,'keys',
$location,$unikey,
$depthcount+1)))) {
- $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_};
+ $metaentry{':'.$_}=$metaentry{':'.$_};
$metathesekeys{$_}=1;
}
}
@@ -4390,18 +4450,18 @@
}
$metathesekeys{$unikey}=1;
foreach (@{$token->[3]}) {
- $metacache{$uri}->{':'.$unikey.'.'.$_}=$token->[2]->{$_};
+ $metaentry{':'.$unikey.'.'.$_}=$token->[2]->{$_};
}
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*$/) {
# only ws inside the tag, and not in default, so use default
# as value
- $metacache{$uri}->{':'.$unikey}=$default;
+ $metaentry{':'.$unikey}=$default;
} else {
# either something interesting inside the tag or default
# uninteresting
- $metacache{$uri}->{':'.$unikey}=$internaltext;
+ $metaentry{':'.$unikey}=$internaltext;
}
# end of not-a-package not-a-library import
}
@@ -4418,7 +4478,7 @@
&metadata_create_package_def($uri,$key,'extension_'.$extension,
\%metathesekeys);
}
- if (!exists($metacache{$uri}->{':packages'})) {
+ if (!exists($metaentry{':packages'})) {
foreach my $key (sort(keys(%packagetab))) {
#no specific packages well let's get default then
if ($key!~/^default&/) { next; }
@@ -4427,31 +4487,31 @@
}
}
# are there custom rights to evaluate
- if ($metacache{$uri}->{':copyright'} eq 'custom') {
+ if ($metaentry{':copyright'} eq 'custom') {
#
# Importing a rights file here
#
unless ($depthcount) {
- my $location=$metacache{$uri}->{':customdistributionfile'};
+ my $location=$metaentry{':customdistributionfile'};
my $dir=$filename;
$dir=~s|[^/]*$||;
$location=&filelocation($dir,$location);
foreach (sort(split(/\,/,&metadata($uri,'keys',
$location,'_rights',
$depthcount+1)))) {
- $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_};
+ #$metaentry{':'.$_}=$metacache{$uri}->{':'.$_};
$metathesekeys{$_}=1;
}
}
}
- $metacache{$uri}->{':keys'}=join(',',keys %metathesekeys);
- &metadata_generate_part0(\%metathesekeys,$metacache{$uri},$uri);
- $metacache{$uri}->{':allpossiblekeys'}=join(',',keys %metathesekeys);
- &do_cache(\%metacache,$uri,$metacache{$uri},'meta');
+ $metaentry{':keys'}=join(',',keys %metathesekeys);
+ &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
+ $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
+ &do_cache_new($metacache,'meta',$uri,\%metaentry);
# this is the end of "was not already recently cached
}
- return $metacache{$uri}->{':'.$what};
+ return $metaentry{':'.$what};
}
sub metadata_create_package_def {
@@ -4459,22 +4519,22 @@
my ($pack,$name,$subp)=split(/\&/,$key);
if ($subp eq 'default') { next; }
- if (defined($metacache{$uri}->{':packages'})) {
- $metacache{$uri}->{':packages'}.=','.$package;
+ if (defined($metaentry{':packages'})) {
+ $metaentry{':packages'}.=','.$package;
} else {
- $metacache{$uri}->{':packages'}=$package;
+ $metaentry{':packages'}=$package;
}
my $value=$packagetab{$key};
my $unikey;
$unikey='parameter_0_'.$name;
- $metacache{$uri}->{':'.$unikey.'.part'}=0;
+ $metaentry{':'.$unikey.'.part'}=0;
$$metathesekeys{$unikey}=1;
- unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) {
- $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value;
+ unless (defined($metaentry{':'.$unikey.'.'.$subp})) {
+ $metaentry{':'.$unikey.'.'.$subp}=$value;
}
- if (defined($metacache{$uri}->{':'.$unikey.'.default'})) {
- $metacache{$uri}->{':'.$unikey}=
- $metacache{$uri}->{':'.$unikey.'.default'};
+ if (defined($metaentry{':'.$unikey.'.default'})) {
+ $metaentry{':'.$unikey}=
+ $metaentry{':'.$unikey.'.default'};
}
}
@@ -5257,7 +5317,7 @@
#not converted to using infrastruture and probably shouldn't be
&logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache)));
#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",'%titlecache',scalar(%titlecache)));
&logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache)));
@@ -5410,7 +5470,7 @@
}
-%metacache=();
+$metacache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']});
$processmarker='_'.time.'_'.$perlvar{'lonHostID'};
$dumpcount=0;
--albertel1095877872--