--- loncom/lonnet/perl/lonnet.pm 2005/01/28 09:26:28 1.587.2.3 +++ loncom/lonnet/perl/lonnet.pm 2005/02/15 17:14:51 1.587.2.3.2.13 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.587.2.3 2005/01/28 09:26:28 albertel Exp $ +# $Id: lonnet.pm,v 1.587.2.3.2.13 2005/02/15 17:14:51 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -35,11 +35,11 @@ use HTTP::Headers; use HTTP::Date; # use Date::Parse; use vars -qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom - %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache +qw(%perlvar %hostname %badServerCache %hostip %iphost %spareid %hostdom + %libserv %pr %prp $memcache %packagetab %courselogs %accesshash %userrolehash $processmarker $dumpcount - %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %courseresdatacache - %userresdatacache %getsectioncache %domaindescription %domain_auth_def %domain_auth_arg_def + %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf + %domaindescription %domain_auth_def %domain_auth_arg_def %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit); use IO::Socket; @@ -50,6 +50,7 @@ use Fcntl qw(:flock); use Apache::lonlocal; use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze); use Time::HiRes qw( gettimeofday tv_interval ); +use Cache::Memcached; my $readit; my $max_connection_retries = 10; # Or some such value. @@ -562,7 +563,7 @@ sub homeserver { my ($uname,$udom,$ignoreBadCache)=@_; my $index="$uname:$udom"; - my ($result,$cached)=&is_cached(\%homecache,$index,'home',86400); + my ($result,$cached)=&is_cached_new('home',$index); if (defined($cached)) { return $result; } my $tryserver; foreach $tryserver (keys %libserv) { @@ -571,7 +572,7 @@ sub homeserver { if ($hostdom{$tryserver} eq $udom) { my $answer=reply("home:$udom:$uname",$tryserver); if ($answer eq 'found') { - return &do_cache(\%homecache,$index,$tryserver,'home'); + return &do_cache_new('home',$index,$tryserver,86400); } elsif ($answer eq 'no_host') { $badServerCache{$tryserver}=1; } @@ -776,11 +777,12 @@ sub validate_access_key { sub getsection { my ($udom,$unam,$courseid)=@_; + my $cachetime=1800; $courseid=~s/\_/\//g; $courseid=~s/^(\w)/\/$1/; my $hashid="$udom:$unam:$courseid"; - my ($result,$cached)=&is_cached(\%getsectioncache,$hashid,'getsection'); + my ($result,$cached)=&is_cached_new('getsection',$hashid); if (defined($cached)) { return $result; } my %Pending; @@ -815,21 +817,21 @@ sub getsection { $Pending{$start}=$section; next; } - return &do_cache(\%getsectioncache,$hashid,$section,'getsection'); + return &do_cache_new('getsection',$hashid,$section,$cachetime); } # # Presumedly there will be few matching roles from the above # loop and the sorting time will be negligible. if (scalar(keys(%Pending))) { my ($time) = sort {$a <=> $b} keys(%Pending); - return &do_cache(\%getsectioncache,$hashid,$Pending{$time},'getsection'); + return &do_cache_new('getsection',$hashid,$Pending{$time},$cachetime); } if (scalar(keys(%Expired))) { my @sorted = sort {$a <=> $b} keys(%Expired); my $time = pop(@sorted); - return &do_cache(\%getsectioncache,$hashid,$Expired{$time},'getsection'); + return &do_cache_new('getsection',$hashid,$Expired{$time},$cachetime); } - return &do_cache(\%getsectioncache,$hashid,'-1','getsection'); + return &do_cache_new('getsection',$hashid,'-1',$cachetime); } @@ -923,6 +925,7 @@ sub save_cache_item { } sub save_cache { + &purge_remembered(); if ($disk_caching_disabled) { return; } my ($cache,$name,$id); foreach $name (keys(%do_save)) { @@ -1020,6 +1023,81 @@ EVALBLOCK # &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime)); } +my $to_remember=20; +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 ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); } + $memcache->set($id,$setvalue,300); + &make_room($id,$value,$debug); + return $value; +} + +sub make_room { + my ($id,$value,$debug)=@_; + $remembered{$id}=$value; + $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))); + undef(%remembered); + undef(%accessed); +} # ------------------------------------- Read an entry from a user's environment sub userenvironment { @@ -1057,7 +1135,7 @@ sub getversion { sub currentversion { my $fname=shift; - my ($result,$cached)=&is_cached(\%resversioncache,$fname,'resversion',600); + my ($result,$cached)=&is_cached_new('resversion',$fname); if (defined($cached)) { return $result; } my $author=$fname; $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; @@ -1070,7 +1148,7 @@ sub currentversion { if (($answer eq 'con_lost') || ($answer eq 'rejected')) { return -1; } - return &do_cache(\%resversioncache,$fname,$answer,'resversion'); + return &do_cache_new('resversion',$fname,$answer,600); } # ----------------------------- Subscribe to a resource, return URL if possible @@ -4122,7 +4200,7 @@ sub condval { sub devalidatecourseresdata { my ($coursenum,$coursedomain)=@_; my $hashid=$coursenum.':'.$coursedomain; - &devalidate_cache(\%courseresdatacache,$hashid,'courseres'); + &devalidate_cache_new('courseres',$hashid); } # --------------------------------------------------- Course Resourcedata Query @@ -4131,18 +4209,18 @@ sub courseresdata { my ($coursenum,$coursedomain,@which)=@_; my $coursehom=&homeserver($coursenum,$coursedomain); my $hashid=$coursenum.':'.$coursedomain; - my ($result,$cached)=&is_cached(\%courseresdatacache,$hashid,'courseres'); + my ($result,$cached)=&is_cached_new('courseres',$hashid); unless (defined($cached)) { my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum); $result=\%dumpreply; my ($tmp) = keys(%dumpreply); if ($tmp !~ /^(con_lost|error|no_such_host)/i) { - &do_cache(\%courseresdatacache,$hashid,$result,'courseres'); + &do_cache_new('courseres',$hashid,$result,600); } elsif ($tmp =~ /^(con_lost|no_such_host)/) { return $tmp; } elsif ($tmp =~ /^(error)/) { $result=undef; - &do_cache(\%courseresdatacache,$hashid,$result,'courseres'); + &do_cache_new('courseres',$hashid,$result,600); } } foreach my $item (@which) { @@ -4331,12 +4409,11 @@ sub EXT { #most student don\'t have any data set, check if there is some data if (! &EXT_cache_status($udom,$uname)) { my $hashid="$udom:$uname"; - my ($result,$cached)=&is_cached(\%userresdatacache,$hashid, - 'userres'); + my ($result,$cached)=&is_cached_new('userres',$hashid); if (!defined($cached)) { my %resourcedata=&dump('resourcedata',$udom,$uname); $result=\%resourcedata; - &do_cache(\%userresdatacache,$hashid,$result,'userres'); + &do_cache_new('userres',$hashid,$result); } my ($tmp)=keys(%$result); if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { @@ -4464,6 +4541,7 @@ sub add_prefix_and_part { # ---------------------------------------------------------------- Get metadata +my %metaentry; sub metadata { my ($uri,$what,$liburi,$prefix,$depthcount)=@_; $uri=&declutter($uri); @@ -4483,28 +4561,29 @@ sub metadata { # 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('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('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); @@ -4521,10 +4600,10 @@ sub metadata { 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; @@ -4546,14 +4625,14 @@ sub metadata { 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'}; } } } @@ -4586,7 +4665,7 @@ sub metadata { foreach (sort(split(/\,/,&metadata($uri,'keys', $location,$unikey, $depthcount+1)))) { - $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_}; + $metaentry{':'.$_}=$metaentry{':'.$_}; $metathesekeys{$_}=1; } } @@ -4597,18 +4676,18 @@ sub metadata { } $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 } @@ -4625,7 +4704,7 @@ sub metadata { &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; } @@ -4634,31 +4713,31 @@ sub metadata { } } # 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('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 { @@ -4666,22 +4745,22 @@ sub metadata_create_package_def { 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'}; } } @@ -4719,7 +4798,8 @@ sub gettitle { my $urlsymb=shift; my $symb=&symbread($urlsymb); if ($symb) { - my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600); + my $key=$ENV{'request.course.id'}."\0".$symb; + my ($result,$cached)=&is_cached_new('title',$key); if (defined($cached)) { return $result; } @@ -4734,7 +4814,7 @@ sub gettitle { } $title=~s/\&colon\;/\:/gs; if ($title) { - return &do_cache(\%titlecache,$symb,$title,'title'); + return &do_cache_new('title',$key,$title,600); } $urlsymb=$url; } @@ -4848,8 +4928,7 @@ sub fixversion { my $uri=&clutter($fn); my $key=$ENV{'request.course.id'}.'_'.$uri; # is this cached? - my ($result,$cached)=&is_cached(\%courseresversioncache,$key, - 'courseresversion',600); + my ($result,$cached)=&is_cached_new('courseresversion',$key); if (defined($cached)) { return $result; } # unfortunately not cached, or expired if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', @@ -4863,8 +4942,7 @@ sub fixversion { } untie %bighash; } - return &do_cache - (\%courseresversioncache,$key,&declutter($uri),'courseresversion'); + return &do_cache_new('courseresversion',$key,&declutter($uri),600); } sub deversion { @@ -5573,17 +5651,20 @@ sub correct_line_ends { sub goodbye { &logthis("Starting Shut down"); #not converted to using infrastruture and probably shouldn't be - &logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache))); + &logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%badServerCache)))); #converted - &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))); +# &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); +# &logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache)))); +# &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache)))); +# &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache)))); #1.1 only - &logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache))); - &logthis(sprintf("%-20s is %s",'%getsectioncache',scalar(%getsectioncache))); - &logthis(sprintf("%-20s is %s",'%courseresversioncache',scalar(%courseresversioncache))); - &logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache))); +# &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache)))); +# &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache)))); +# &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache)))); +# &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%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(); &logthis("Shutting down"); return DONE; @@ -5729,7 +5810,7 @@ BEGIN { } -%metacache=(); +$memcache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']}); $processmarker='_'.time.'_'.$perlvar{'lonHostID'}; $dumpcount=0;