--- loncom/lonnet/perl/lonnet.pm 2003/09/19 19:38:24 1.420 +++ loncom/lonnet/perl/lonnet.pm 2003/10/04 02:27:02 1.425 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.420 2003/09/19 19:38:24 albertel Exp $ +# $Id: lonnet.pm,v 1.425 2003/10/04 02:27:02 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -86,7 +86,8 @@ use HTML::LCParser; use Fcntl qw(:flock); use Apache::loncoursedata; use Apache::lonlocal; - +use Storable qw(lock_store lock_nstore lock_retrieve); +use Time::HiRes(); my $readit; # --------------------------------------------------------------------- Logging @@ -855,12 +856,17 @@ sub devalidate_cache { } sub is_cached { - my ($cache,$id,$time) = @_; + my ($cache,$id,$name,$time) = @_; if (!$time) { $time=300; } if (!exists($$cache{$id.'.time'})) { + &load_cache($cache,$name); + } + if (!exists($$cache{$id.'.time'})) { +# &logthis("Didn't find $id"); return (undef,undef); } else { - if (time-$$cache{$id.'.time'}>$time) { + if (time-($$cache{$id.'.time'})>$time) { +# &logthis("Devailidating $id"); &devalidate_cache($cache,$id); return (undef,undef); } @@ -869,17 +875,69 @@ sub is_cached { } sub do_cache { - my ($cache,$id,$value) = @_; + my ($cache,$id,$value,$name) = @_; $$cache{$id.'.time'}=time; - # do_cache implictly return the set value $$cache{$id}=$value; + &save_cache($cache,$name); + # do_cache implictly return the set value + $$cache{$id}; +} + +sub save_cache { + my ($cache,$name)=@_; +# my $starttime=&Time::HiRes::time(); +# &logthis("Saving :$name:"); + eval lock_store($cache,$perlvar{'lonDaemons'}.'/tmp/'.$name.".storable"); + if ($@) { &logthis("lock_store threw a die ".$@); } +# &logthis("save_cache took ".(&Time::HiRes::time()-$starttime)); +} + +sub load_cache { + my ($cache,$name)=@_; +# my $starttime=&Time::HiRes::time(); +# &logthis("Before Loading $name size is ".scalar(%$cache)); + my $tmpcache; + eval { + $tmpcache=lock_retrieve($perlvar{'lonDaemons'}.'/tmp/'.$name.".storable"); + }; + if ($@) { &logthis("lock_retreive threw a die ".$@); return; } + if (!%$cache) { + my $count; + while (my ($key,$value)=each(%$tmpcache)) { + $count++; + $$cache{$key}=$value; + } +# &logthis("Initial load: $count"); + } else { + my $key; + my $count; + while ($key=each(%$tmpcache)) { + if ($key !~/^(.*)\.time$/) { next; } + my $name=$1; + if (exists($$cache{$key})) { + if ($$tmpcache{$key} >= $$cache{$key}) { + $$cache{$key}=$$tmpcache{$key}; + $$cache{$name}=$$tmpcache{$name}; + } else { +# &logthis("Would have overwritten $name with is set to expire at ".$$cache{$key}." with ".$$tmpcache{$key}." Whew!"); + } + } else { + $count++; + $$cache{$key}=$$tmpcache{$key}; + $$cache{$name}=$$tmpcache{$name}; + } + } +# &logthis("Additional load: $count"); + } +# &logthis("After Loading $name size is ".scalar(%$cache)); +# &logthis("load_cache took ".(&Time::HiRes::time()-$starttime)); } sub usection { my ($udom,$unam,$courseid)=@_; my $hashid="$udom:$unam:$courseid"; - my ($result,$cached)=&is_cached(\%usectioncache,$hashid); + my ($result,$cached)=&is_cached(\%usectioncache,$hashid,'usection'); if (defined($cached)) { return $result; } $courseid=~s/\_/\//g; $courseid=~s/^(\w)/\/$1/; @@ -900,11 +958,11 @@ sub usection { if ($now>$end) { $notactive=1; } } unless ($notactive) { - return &do_cache(\%usectioncache,$hashid,$section); + return &do_cache(\%usectioncache,$hashid,$section,'usection'); } } } - return &do_cache(\%usectioncache,$hashid,'-1'); + return &do_cache(\%usectioncache,$hashid,'-1','usection'); } # ------------------------------------- Read an entry from a user's environment @@ -2220,27 +2278,7 @@ sub currentdump { return if ($tmp[0] =~ /^(error:|no_such_host)/); my %hash = @tmp; @tmp=(); - # Code ripped from lond, essentially. The only difference - # here is the unescaping done by lonnet::dump(). Conceivably - # we might run in to problems with parameter names =~ /^v\./ - while (my ($key,$value) = each(%hash)) { - my ($v,$symb,$param) = split(/:/,$key); - next if ($v eq 'version' || $symb eq 'keys'); - next if (exists($returnhash{$symb}) && - exists($returnhash{$symb}->{$param}) && - $returnhash{$symb}->{'v.'.$param} > $v); - $returnhash{$symb}->{$param}=$value; - $returnhash{$symb}->{'v.'.$param}=$v; - } - # - # Remove all of the keys in the hashes which keep track of - # the version of the parameter. - while (my ($symb,$param_hash) = each(%returnhash)) { - # use a foreach because we are going to delete from the hash. - foreach my $key (keys(%$param_hash)) { - delete($param_hash->{$key}) if ($key =~ /^v\./); - } - } + %returnhash = %{&convert_dump_to_currentdump(\%hash)}; } else { my @pairs=split(/\&/,$rep); foreach (@pairs) { @@ -2253,6 +2291,33 @@ sub currentdump { return %returnhash; } +sub convert_dump_to_currentdump{ + my %hash = %{shift()}; + my %returnhash; + # Code ripped from lond, essentially. The only difference + # here is the unescaping done by lonnet::dump(). Conceivably + # we might run in to problems with parameter names =~ /^v\./ + while (my ($key,$value) = each(%hash)) { + my ($v,$symb,$param) = split(/:/,$key); + next if ($v eq 'version' || $symb eq 'keys'); + next if (exists($returnhash{$symb}) && + exists($returnhash{$symb}->{$param}) && + $returnhash{$symb}->{'v.'.$param} > $v); + $returnhash{$symb}->{$param}=$value; + $returnhash{$symb}->{'v.'.$param}=$v; + } + # + # Remove all of the keys in the hashes which keep track of + # the version of the parameter. + while (my ($symb,$param_hash) = each(%returnhash)) { + # use a foreach because we are going to delete from the hash. + foreach my $key (keys(%$param_hash)) { + delete($param_hash->{$key}) if ($key =~ /^v\./); + } + } + return \%returnhash; +} + # --------------------------------------------------------------- put interface sub put { @@ -3296,24 +3361,32 @@ sub condval { return $result; } +# ---------------------------------------------------- Devalidate courseresdata + +sub devalidatecourseresdata { + my ($coursenum,$coursedomain)=@_; + my $hashid=$coursenum.':'.$coursedomain; + &devalidate_cache(\%courseresdatacache,$hashid); +} + # --------------------------------------------------- Course Resourcedata Query sub courseresdata { my ($coursenum,$coursedomain,@which)=@_; my $coursehom=&homeserver($coursenum,$coursedomain); my $hashid=$coursenum.':'.$coursedomain; - my ($result,$cached)=&is_cached(\%courseresdatacache,$hashid); + my ($result,$cached)=&is_cached(\%courseresdatacache,$hashid,'courseres'); 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); + &do_cache(\%courseresdatacache,$hashid,$result,'courseres'); } elsif ($tmp =~ /^(con_lost|no_such_host)/) { return $tmp; } elsif ($tmp =~ /^(error)/) { $result=undef; - &do_cache(\%courseresdatacache,$hashid,$result); + &do_cache(\%courseresdatacache,$hashid,$result,'courseres'); } } foreach my $item (@which) { @@ -3488,16 +3561,17 @@ 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); + my ($result,$cached)=&is_cached(\%userresdatacache,$hashid, + 'userres'); if (!defined($cached)) { my %resourcedata=&get('resourcedata', [$courselevelr,$courselevelm, $courselevel],$udom,$uname); $result=\%resourcedata; + &do_cache(\%userresdatacache,$hashid,$result,'userres'); } my ($tmp)=keys(%$result); if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { - &do_cache(\%userresdatacache,$hashid,$result); if ($$result{$courselevelr}) { return $$result{$courselevelr}; } if ($$result{$courselevelm}) { @@ -3510,11 +3584,9 @@ sub EXT { " Trying to get resource data for ". $uname." at ".$udom.": ". $tmp.""); - &do_cache(\%userresdatacache,$hashid,undef); } elsif ($tmp=~/error:No such file/) { &EXT_cache_set($udom,$uname); } elsif ($tmp =~ /^(con_lost|no_such_host)/) { - &do_cache(\%userresdatacache,$hashid,undef); return $tmp; } } @@ -3621,11 +3693,11 @@ sub add_prefix_and_part { sub metadata { my ($uri,$what,$liburi,$prefix,$depthcount)=@_; - $uri=&declutter($uri); # if it is a non metadata possible uri return quickly if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|)) || - ($uri =~ m|/$|) || ($uri =~ m|/.meta$|)) { + ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) || + ($uri =~ m|home/[^/]+/public_html/|)) { return ''; } my $filename=$uri; @@ -3814,7 +3886,7 @@ sub gettitle { unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; } return &metadata($urlsymb,'title'); } - my ($result,$cached)=&is_cached(\%titlecache,$symb,600); + my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600); if (defined($cached)) { return $result; } my ($map,$resid,$url)=&decode_symb($symb); my $title=''; @@ -3827,7 +3899,7 @@ sub gettitle { } $title=~s/\&colon\;/\:/gs; if ($title) { - return &do_cache(\%titlecache,$symb,$title); + return &do_cache(\%titlecache,$symb,$title,'title'); } else { return &metadata($urlsymb,'title'); } @@ -4230,6 +4302,16 @@ sub mod_perl_version { sub goodbye { &logthis("Starting Shut down"); +#not converted to using infrastruture + &logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache))); + &logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache))); + &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); +#converted + &logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache))); + &logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache))); +#1.1 only + &logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache))); + &logthis(sprintf("%-20s is %s",'%usectioncache',scalar(%usectioncache))); &flushcourselogs(); &logthis("Shutting down"); return DONE;