--- loncom/lonnet/perl/lonnet.pm 2004/09/02 18:01:52 1.538 +++ loncom/lonnet/perl/lonnet.pm 2004/10/12 20:26:48 1.545.2.2 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.538 2004/09/02 18:01:52 albertel Exp $ +# $Id: lonnet.pm,v 1.545.2.2 2004/10/12 20:26:48 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -36,7 +36,7 @@ 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 + %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 @@ -50,7 +50,8 @@ use Fcntl qw(:flock); use Apache::loncoursedata; use Apache::lonlocal; use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw); -use Time::HiRes(); +use Time::HiRes qw( gettimeofday tv_interval ); +use Cache::Memcached; my $readit; =pod @@ -115,6 +116,7 @@ sub logperm { # -------------------------------------------------- Non-critical communication sub subreply { my ($cmd,$server)=@_; + my $t0_f=[&Time::HiRes::gettimeofday()]; my $peerfile="$perlvar{'lonSockDir'}/$server"; my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", Type => SOCK_STREAM, @@ -124,6 +126,8 @@ sub subreply { my $answer=<$client>; if (!$answer) { $answer="con_lost"; } chomp($answer); + my $td=&Time::HiRes::tv_interval($t0_f); + &Apache::lonnet::logthis("\n $td seconds for $cmd"); return $answer; } @@ -826,10 +830,12 @@ my $disk_caching_disabled=1; sub devalidate_cache { my ($cache,$id,$name) = @_; delete $$cache{$id.'.time'}; + delete $$cache{$id.'.file'}; delete $$cache{$id}; - if ($disk_caching_disabled) { return; } + if (1 || $disk_caching_disabled) { return; } my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db"; - open(DB,"$filename.lock"); + if (!-e $filename) { return; } + open(DB,">$filename.lock"); flock(DB,LOCK_EX); my %hash; if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) { @@ -856,16 +862,32 @@ sub is_cached { my ($cache,$id,$name,$time) = @_; if (!$time) { $time=300; } if (!exists($$cache{$id.'.time'})) { - &load_cache_item($cache,$name,$id); + &load_cache_item($cache,$name,$id,$time); } if (!exists($$cache{$id.'.time'})) { # &logthis("Didn't find $id"); return (undef,undef); } else { if (time-($$cache{$id.'.time'})>$time) { -# &logthis("Devalidating $id - ".time-($$cache{$id.'.time'})); - &devalidate_cache($cache,$id,$name); - return (undef,undef); + if (exists($$cache{$id.'.file'})) { + foreach my $filename (@{ $$cache{$id.'.file'} }) { + my $mtime=(stat($filename))[9]; + #+1 is to take care of edge effects + if ($mtime && (($mtime+1) < ($$cache{$id.'.time'}))) { +# &logthis("Upping $mtime - ".$$cache{$id.'.time'}. +# "$id because of $filename"); + } else { +# &logthis("Devalidating $filename $id - ".(time-($$cache{$id.'.time'}))); + &devalidate_cache($cache,$id,$name); + return (undef,undef); + } + } + $$cache{$id.'.time'}=time; + } else { +# &logthis("Devalidating $id - ".time-($$cache{$id.'.time'})); + &devalidate_cache($cache,$id,$name); + return (undef,undef); + } } } return ($$cache{$id},1); @@ -881,44 +903,69 @@ sub do_cache { $$cache{$id}; } +my %do_save_item; +my %do_save; sub save_cache_item { my ($cache,$name,$id)=@_; if ($disk_caching_disabled) { return; } - my $starttime=&Time::HiRes::time(); -# &logthis("Saving :$name:$id"); - my %hash; - my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db"; - open(DB,"$filename.lock"); - flock(DB,LOCK_EX); - if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) { - eval <<'EVALBLOCK'; - $hash{$id.'.time'}=$$cache{$id.'.time'}; - $hash{$id}=freeze({'item'=>$$cache{$id}}); + $do_save{$name}=$cache; + if (!exists($do_save_item{$name})) { $do_save_item{$name}={} } + $do_save_item{$name}->{$id}=1; + return; +} + +sub save_cache { + if ($disk_caching_disabled) { return; } + my ($cache,$name,$id); + foreach $name (keys(%do_save)) { + $cache=$do_save{$name}; + + my $starttime=&Time::HiRes::time(); + &logthis("Saving :$name:"); + my %hash; + my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db"; + open(DB,">$filename.lock"); + flock(DB,LOCK_EX); + if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) { + foreach $id (keys(%{ $do_save_item{$name} })) { + eval <<'EVALBLOCK'; + $hash{$id.'.time'}=$$cache{$id.'.time'}; + $hash{$id}=freeze({'item'=>$$cache{$id}}); + if (exists($$cache{$id.'.file'})) { + $hash{$id.'.file'}=freeze({'item'=>$$cache{$id.'.file'}}); + } EVALBLOCK - if ($@) { - &logthis("save_cache blew up :$@:$name"); - unlink($filename); - } - } else { - if (-e $filename) { - &logthis("Unable to tie hash (save cache item): $name ($!)"); - unlink($filename); + if ($@) { + &logthis("save_cache blew up :$@:$name"); + unlink($filename); + last; + } + } + } else { + if (-e $filename) { + &logthis("Unable to tie hash (save cache): $name ($!)"); + unlink($filename); + } } + untie(%hash); + flock(DB,LOCK_UN); + close(DB); + &logthis("save_cache $name took ".(&Time::HiRes::time()-$starttime)); } - untie(%hash); - flock(DB,LOCK_UN); - close(DB); -# &logthis("save_cache_item $name took ".(&Time::HiRes::time()-$starttime)); + undef(%do_save); + undef(%do_save_item); + } sub load_cache_item { - my ($cache,$name,$id)=@_; + my ($cache,$name,$id,$time)=@_; if ($disk_caching_disabled) { return; } my $starttime=&Time::HiRes::time(); # &logthis("Before Loading $name for $id size is ".scalar(%$cache)); my %hash; my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db"; - open(DB,"$filename.lock"); + if (!-e $filename) { return; } + open(DB,">$filename.lock"); flock(DB,LOCK_SH); if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) { eval <<'EVALBLOCK'; @@ -935,9 +982,17 @@ sub load_cache_item { } # &logthis("Initial load: $count"); } else { - my $hashref=thaw($hash{$id}); - $$cache{$id}=$hashref->{'item'}; - $$cache{$id.'.time'}=$hash{$id.'.time'}; + if (($$cache{$id.'.time'}+$time) < time) { + $$cache{$id.'.time'}=$hash{$id.'.time'}; + { + my $hashref=thaw($hash{$id}); + $$cache{$id}=$hashref->{'item'}; + } + if (exists($hash{$id.'.file'})) { + my $hashref=thaw($hash{$id.'.file'}); + $$cache{$id.'.file'}=$hashref->{'item'}; + } + } } EVALBLOCK if ($@) { @@ -957,6 +1012,52 @@ EVALBLOCK # &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(&escape($name.':'.$id)); +} + +my $lastone; +my $lastname; +sub is_cached_new { + my ($cache,$name,$id,$debug) = @_; + $debug=0; + $id=&escape($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=&escape($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"; @@ -1284,6 +1385,9 @@ sub clean_filename { $fname=~s/\s+/\_/g; # Replace all other weird characters by nothing $fname=~s/[^\w\.\-]//g; +# Replace all .\d. sequences with _\d. so they no longer look like version +# numbers + $fname=~s/\.(\d+)(?=\.)/_$1/g; return $fname; } @@ -2152,7 +2256,6 @@ sub tmprestore { } # ----------------------------------------------------------------------- Store - sub store { my ($storehash,$symb,$namespace,$domain,$stuname) = @_; my $home=''; @@ -2166,7 +2269,6 @@ sub store { if (!$stuname) { $stuname=$ENV{'user.name'}; } &devalidate($symb,$stuname,$domain); - $symb=escape($symb); if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { @@ -2202,7 +2304,6 @@ sub cstore { if (!$stuname) { $stuname=$ENV{'user.name'}; } &devalidate($symb,$stuname,$domain); - $symb=escape($symb); if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { @@ -2245,6 +2346,7 @@ sub restore { if (!$domain) { $domain=$ENV{'user.domain'}; } if (!$stuname) { $stuname=$ENV{'user.name'}; } if (!$home) { $home=$ENV{'user.home'}; } + my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home"); my %returnhash=(); @@ -2720,7 +2822,9 @@ sub allowed { $uri=&deversion($uri); my $orguri=$uri; $uri=&declutter($uri); - + + + if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; } # Free bre access to adm and meta resources if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|)) @@ -2728,8 +2832,13 @@ sub allowed { return 'F'; } -# Free bre to public access +# Free bre access to user's own portfolio contents + $uri=~m:([^/]+)/([^/]+)/([^/]+)/([^/]+)/:; + if (('uploaded' eq $1)&&($ENV{'user.name'} eq $3) && ($ENV{'user.domain'} eq $2) && ('portfolio' eq $4)) { + return 'F'; + } +# Free bre to public access if ($priv eq 'bre') { my $copyright=&metadata($uri,'copyright'); if (($copyright eq 'public') && (!$ENV{'request.course.id'})) { @@ -4026,11 +4135,14 @@ sub EXT { my $section; if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) { + if (!$symbparm) { $symbparm=&symbread(); } + } + if ($symbparm && defined($courseid) && + $courseid eq $ENV{'request.course.id'}) { #print '
'.$space.' - '.$qualifier.' - '.$spacequalifierrest; # ----------------------------------------------------- Cascading lookup scheme - if (!$symbparm) { $symbparm=&symbread(); } my $symbp=$symbparm; my $mapp=(&decode_symb($symbp))[0]; @@ -4041,11 +4153,11 @@ sub EXT { ($ENV{'user.domain'} eq $udom)) { $section=$ENV{'request.course.sec'}; } else { - if (! defined($usection)) { - $section=&usection($udom,$uname,$courseid); - } else { - $section = $usection; - } + if (! defined($usection)) { + $section=&usection($udom,$uname,$courseid); + } else { + $section = $usection; + } } my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; @@ -4083,7 +4195,7 @@ sub EXT { $uname." at ".$udom.": ". $tmp.""); } elsif ($tmp=~/error: 2 /) { - &EXT_cache_set($udom,$uname); + &EXT_cache_set($udom,$uname); } elsif ($tmp =~ /^(con_lost|no_such_host)/) { return $tmp; } @@ -4093,10 +4205,10 @@ sub EXT { # -------------------------------------------------------- second, check course my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'}, - $ENV{'course.'.$courseid.'.domain'}, - ($seclevelr,$seclevelm,$seclevel, - $courselevelr,$courselevelm, - $courselevel)); + $ENV{'course.'.$courseid.'.domain'}, + ($seclevelr,$seclevelm,$seclevel, + $courselevelr,$courselevelm, + $courselevel)); if (defined($coursereply)) { return $coursereply; } # ------------------------------------------------------ third, check map parms @@ -4192,6 +4304,7 @@ sub add_prefix_and_part { # ---------------------------------------------------------------- Get metadata +my %metaentry; sub metadata { my ($uri,$what,$liburi,$prefix,$depthcount)=@_; $uri=&declutter($uri); @@ -4211,27 +4324,30 @@ 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($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/|) { - $metastring=&getfile(&filelocation('',&clutter($filename))); + my $file=&filelocation('',&clutter($filename)); + #push(@{$metaentry{$uri.'.file'}},$file); + $metastring=&getfile($file); } my $parser=HTML::LCParser->new(\$metastring); my $token; @@ -4247,10 +4363,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; @@ -4272,14 +4388,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'}; } } } @@ -4312,7 +4428,7 @@ sub metadata { foreach (sort(split(/\,/,&metadata($uri,'keys', $location,$unikey, $depthcount+1)))) { - $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_}; + $metaentry{':'.$_}=$metaentry{':'.$_}; $metathesekeys{$_}=1; } } @@ -4323,18 +4439,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 } @@ -4351,7 +4467,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; } @@ -4360,31 +4476,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($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 { @@ -4392,22 +4508,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'}; } } @@ -4596,14 +4712,20 @@ sub deversion { sub symbread { my ($thisfn,$donotrecurse)=@_; + my $cache_str='request.symbread.cached.'.$thisfn; + if (defined($ENV{$cache_str})) { return $ENV{$cache_str}; } # no filename provided? try from environment unless ($thisfn) { - if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); } + if ($ENV{'request.symb'}) { + return $ENV{$cache_str}=&symbclean($ENV{'request.symb'}); + } $thisfn=$ENV{'request.filename'}; } # is that filename actually a symb? Verify, clean, and return if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) { - if (&symbverify($thisfn,$1)) { return &symbclean($thisfn); } + if (&symbverify($thisfn,$1)) { + return $ENV{$cache_str}=&symbclean($thisfn); + } } $thisfn=declutter($thisfn); my %hash; @@ -4624,7 +4746,7 @@ sub symbread { unless ($syval=~/\_\d+$/) { unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) { &appenv('request.ambiguous' => $thisfn); - return ''; + return $ENV{$cache_str}=''; } $syval.=$1; } @@ -4671,11 +4793,11 @@ sub symbread { } } if ($syval) { - return &symbclean($syval.'___'.$thisfn); + return $ENV{$cache_str}=&symbclean($syval.'___'.$thisfn); } } &appenv('request.ambiguous' => $thisfn); - return ''; + return $ENV{$cache_str}=''; } # ---------------------------------------------------------- Return random seed @@ -5184,7 +5306,7 @@ sub goodbye { #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))); @@ -5337,7 +5459,7 @@ BEGIN { } -%metacache=(); +$metacache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']}); $processmarker='_'.time.'_'.$perlvar{'lonHostID'}; $dumpcount=0;