--- loncom/lonnet/perl/lonnet.pm 2005/02/14 04:31:59 1.587.2.3.2.12 +++ loncom/lonnet/perl/lonnet.pm 2005/02/10 22:26:38 1.598 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.587.2.3.2.12 2005/02/14 04:31:59 albertel Exp $ +# $Id: lonnet.pm,v 1.598 2005/02/10 22:26:38 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 %badServerCache %hostip %iphost %spareid %hostdom - %libserv %pr %prp $memcache %packagetab +qw(%perlvar %hostname %homecache %badServerCache %iphost %spareid %hostdom + %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache %courselogs %accesshash %userrolehash $processmarker $dumpcount - %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf - %domaindescription %domain_auth_def %domain_auth_arg_def + %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %courseresdatacache + %userresdatacache %getsectioncache %domaindescription %domain_auth_def %domain_auth_arg_def %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit); use IO::Socket; @@ -50,7 +50,6 @@ 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. @@ -563,7 +562,7 @@ sub homeserver { my ($uname,$udom,$ignoreBadCache)=@_; my $index="$uname:$udom"; - my ($result,$cached)=&is_cached_new('home',$index); + my ($result,$cached)=&is_cached(\%homecache,$index,'home',86400); if (defined($cached)) { return $result; } my $tryserver; foreach $tryserver (keys %libserv) { @@ -572,7 +571,7 @@ sub homeserver { if ($hostdom{$tryserver} eq $udom) { my $answer=reply("home:$udom:$uname",$tryserver); if ($answer eq 'found') { - return &do_cache_new('home',$index,$tryserver,86400); + return &do_cache(\%homecache,$index,$tryserver,'home'); } elsif ($answer eq 'no_host') { $badServerCache{$tryserver}=1; } @@ -777,12 +776,11 @@ 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_new('getsection',$hashid); + my ($result,$cached)=&is_cached(\%getsectioncache,$hashid,'getsection'); if (defined($cached)) { return $result; } my %Pending; @@ -817,21 +815,21 @@ sub getsection { $Pending{$start}=$section; next; } - return &do_cache_new('getsection',$hashid,$section,$cachetime); + return &do_cache(\%getsectioncache,$hashid,$section,'getsection'); } # # 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_new('getsection',$hashid,$Pending{$time},$cachetime); + return &do_cache(\%getsectioncache,$hashid,$Pending{$time},'getsection'); } if (scalar(keys(%Expired))) { my @sorted = sort {$a <=> $b} keys(%Expired); my $time = pop(@sorted); - return &do_cache_new('getsection',$hashid,$Expired{$time},$cachetime); + return &do_cache(\%getsectioncache,$hashid,$Expired{$time},'getsection'); } - return &do_cache_new('getsection',$hashid,'-1',$cachetime); + return &do_cache(\%getsectioncache,$hashid,'-1','getsection'); } @@ -925,7 +923,6 @@ sub save_cache_item { } sub save_cache { - &purge_remembered(); if ($disk_caching_disabled) { return; } my ($cache,$name,$id); foreach $name (keys(%do_save)) { @@ -1023,81 +1020,6 @@ 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); - } - &make_room($id,$value,$debug); - 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"); } - 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 { @@ -1135,7 +1057,7 @@ sub getversion { sub currentversion { my $fname=shift; - my ($result,$cached)=&is_cached_new('resversion',$fname); + my ($result,$cached)=&is_cached(\%resversioncache,$fname,'resversion',600); if (defined($cached)) { return $result; } my $author=$fname; $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; @@ -1148,7 +1070,7 @@ sub currentversion { if (($answer eq 'con_lost') || ($answer eq 'rejected')) { return -1; } - return &do_cache_new('resversion',$fname,$answer,600); + return &do_cache(\%resversioncache,$fname,$answer,'resversion'); } # ----------------------------- Subscribe to a resource, return URL if possible @@ -1817,19 +1739,27 @@ sub get_first_access { my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); if ($argsymb) { $symb=$argsymb; } my ($map,$id,$res)=&decode_symb($symb); - if ($type eq 'map') { $res=$map; } - my %times=&get('firstaccesstimes',[$res],$udom,$uname); - return $times{$res}; + if ($type eq 'map') { + $res=&symbread($map); + } else { + $res=$symb; + } + my %times=&get('firstaccesstimes',["$courseid\0$res"],$udom,$uname); + return $times{"$courseid\0$res"}; } sub set_first_access { my ($type)=@_; my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser(); my ($map,$id,$res)=&decode_symb($symb); - if ($type eq 'map') { $res=$map; } - my $firstaccess=&get_first_access($type); + if ($type eq 'map') { + $res=&symbread($map); + } else { + $res=$symb; + } + my $firstaccess=&get_first_access($type,$symb); if (!$firstaccess) { - return &put('firstaccesstimes',{$res=>time},$udom,$uname); + return &put('firstaccesstimes',{"$courseid\0$res"=>time},$udom,$uname); } return 'already_set'; } @@ -1887,7 +1817,7 @@ sub checkin { my $now=time; my ($ta,$tb,$lonhost)=split(/\*/,$token); $lonhost=~tr/A-Z/a-z/; - my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb; + my $dtoken=$ta.'_'.$hostname{$lonhost}.'_'.$tb; $dtoken=~s/\W/\_/g; my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)= split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost))); @@ -2170,9 +2100,11 @@ sub tmpreset { $namespace=~s/\//\_/g; $namespace=~s/\W//g; - #FIXME needs to do something for /pub resources if (!$domain) { $domain=$ENV{'user.domain'}; } if (!$stuname) { $stuname=$ENV{'user.name'}; } + if ($domain eq 'public' && $stuname eq 'public') { + $stuname=$ENV{'REMOTE_ADDR'}; + } my $path=$perlvar{'lonDaemons'}.'/tmp'; my %hash; if (tie(%hash,'GDBM_File', @@ -2205,9 +2137,11 @@ sub tmpstore { } $namespace=~s/\//\_/g; $namespace=~s/\W//g; -#FIXME needs to do something for /pub resources if (!$domain) { $domain=$ENV{'user.domain'}; } if (!$stuname) { $stuname=$ENV{'user.name'}; } + if ($domain eq 'public' && $stuname eq 'public') { + $stuname=$ENV{'REMOTE_ADDR'}; + } my $now=time; my %hash; my $path=$perlvar{'lonDaemons'}.'/tmp'; @@ -2219,7 +2153,7 @@ sub tmpstore { my $allkeys=''; foreach my $key (keys(%$storehash)) { $allkeys.=$key.':'; - $hash{"$version:$symb:$key"}=$$storehash{$key}; + $hash{"$version:$symb:$key"}=&freeze_escape($$storehash{$key}); } $hash{"$version:$symb:timestamp"}=$now; $allkeys.='timestamp'; @@ -2246,10 +2180,12 @@ sub tmprestore { $symb=escape($symb); if (!$namespace) { $namespace=$ENV{'request.state'}; } - #FIXME needs to do something for /pub resources + if (!$domain) { $domain=$ENV{'user.domain'}; } if (!$stuname) { $stuname=$ENV{'user.name'}; } - + if ($domain eq 'public' && $stuname eq 'public') { + $stuname=$ENV{'REMOTE_ADDR'}; + } my %returnhash; $namespace=~s/\//\_/g; $namespace=~s/\W//g; @@ -2267,8 +2203,8 @@ sub tmprestore { my $key; $returnhash{"$scope:keys"}=$vkeys; foreach $key (@keys) { - $returnhash{"$scope:$key"}=$hash{"$scope:$symb:$key"}; - $returnhash{"$key"}=$hash{"$scope:$symb:$key"}; + $returnhash{"$scope:$key"}=&thaw_unescape($hash{"$scope:$symb:$key"}); + $returnhash{"$key"}=&thaw_unescape($hash{"$scope:$symb:$key"}); } } if (!(untie(%hash))) { @@ -2309,7 +2245,7 @@ sub store { my $namevalue=''; foreach (keys %$storehash) { - $namevalue.=escape($_).'='.escape($$storehash{$_}).'&'; + $namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; } $namevalue=~s/\&$//; &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue); @@ -2345,7 +2281,7 @@ sub cstore { my $namevalue=''; foreach (keys %$storehash) { - $namevalue.=escape($_).'='.escape($$storehash{$_}).'&'; + $namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&'; } $namevalue=~s/\&$//; &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue); @@ -2379,7 +2315,7 @@ sub restore { my %returnhash=(); foreach (split(/\&/,$answer)) { my ($name,$value)=split(/\=/,$_); - $returnhash{&unescape($name)}=&unescape($value); + $returnhash{&unescape($name)}=&thaw_unescape($value); } my $version; for ($version=1;$version<=$returnhash{'version'};$version++) { @@ -2770,7 +2706,7 @@ sub putstore { my $key = $1.':keys:'.$2; $allitems{$key} .= $3.':'; } - $items.=$_.'='.&escape($$storehash{$_}).'&'; + $items.=$_.'='.&freeze_escape($$storehash{$_}).'&'; } foreach (keys %allitems) { $allitems{$_} =~ s/\:$//; @@ -3640,9 +3576,12 @@ sub modifyuser { if (defined($middle)) { $names{'middlename'} = $middle; } if ($last) { $names{'lastname'} = $last; } if (defined($gene)) { $names{'generation'} = $gene; } - if ($email) { $names{'notification'} = $email; - $names{'critnotification'} = $email; } - + if ($email) { + $email=~s/[^\w\@\.\-\,]//gs; + if ($email=~/\@/) { $names{'notification'} = $email; + $names{'critnotification'} = $email; + $names{'permanentemail'} = $email; } + } my $reply = &put('environment', \%names, $udom,$uname); if ($reply ne 'ok') { return 'error: '.$reply; } &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '. @@ -4200,7 +4139,7 @@ sub condval { sub devalidatecourseresdata { my ($coursenum,$coursedomain)=@_; my $hashid=$coursenum.':'.$coursedomain; - &devalidate_cache_new('courseres',$hashid); + &devalidate_cache(\%courseresdatacache,$hashid,'courseres'); } # --------------------------------------------------- Course Resourcedata Query @@ -4209,18 +4148,18 @@ sub courseresdata { my ($coursenum,$coursedomain,@which)=@_; my $coursehom=&homeserver($coursenum,$coursedomain); my $hashid=$coursenum.':'.$coursedomain; - my ($result,$cached)=&is_cached_new('courseres',$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_new('courseres',$hashid,$result,600); + &do_cache(\%courseresdatacache,$hashid,$result,'courseres'); } elsif ($tmp =~ /^(con_lost|no_such_host)/) { return $tmp; } elsif ($tmp =~ /^(error)/) { $result=undef; - &do_cache_new('courseres',$hashid,$result,600); + &do_cache(\%courseresdatacache,$hashid,$result,'courseres'); } } foreach my $item (@which) { @@ -4374,6 +4313,7 @@ sub EXT { if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) { if (!$symbparm) { $symbparm=&symbread(); } } + my ($courselevelm,$courselevel); if ($symbparm && defined($courseid) && $courseid eq $ENV{'request.course.id'}) { @@ -4401,19 +4341,20 @@ sub EXT { my $seclevelr=$courseid.'.['.$section.'].'.$symbparm; my $seclevelm=$courseid.'.['.$section.'].'.$mapparm; - my $courselevel=$courseid.'.'.$spacequalifierrest; + $courselevel=$courseid.'.'.$spacequalifierrest; my $courselevelr=$courseid.'.'.$symbparm; - my $courselevelm=$courseid.'.'.$mapparm; + $courselevelm=$courseid.'.'.$mapparm; # ----------------------------------------------------------- first, check user #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_new('userres',$hashid); + my ($result,$cached)=&is_cached(\%userresdatacache,$hashid, + 'userres'); if (!defined($cached)) { my %resourcedata=&dump('resourcedata',$udom,$uname); $result=\%resourcedata; - &do_cache_new('userres',$hashid,$result); + &do_cache(\%userresdatacache,$hashid,$result,'userres'); } my ($tmp)=keys(%$result); if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { @@ -4438,13 +4379,12 @@ sub EXT { } } -# -------------------------------------------------------- second, check course +# ------------------------------------------------ second, check some of course my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'}, $ENV{'course.'.$courseid.'.domain'}, ($seclevelr,$seclevelm,$seclevel, - $courselevelr,$courselevelm, - $courselevel)); + $courselevelr)); if (defined($coursereply)) { return $coursereply; } # ------------------------------------------------------ third, check map parms @@ -4458,7 +4398,7 @@ sub EXT { } if ($thisparm) { return $thisparm; } } -# --------------------------------------------- last, look in resource metadata +# ------------------------------------------ fourth, look in resource metadata $spacequalifierrest=~s/\./\_/; my $filename; @@ -4473,6 +4413,14 @@ sub EXT { $metadata=&metadata($filename,'parameter_'.$spacequalifierrest); if (defined($metadata)) { return $metadata; } +# ---------------------------------------------- fourth, look in rest pf course + if ($symbparm && defined($courseid) && + $courseid eq $ENV{'request.course.id'}) { + my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'}, + $ENV{'course.'.$courseid.'.domain'}, + ($courselevelm,$courselevel)); + if (defined($coursereply)) { return $coursereply; } + } # ------------------------------------------------------------------ Cascade up unless ($space eq '0') { my @parts=split(/_/,$space); @@ -4541,7 +4489,6 @@ sub add_prefix_and_part { # ---------------------------------------------------------------- Get metadata -my %metaentry; sub metadata { my ($uri,$what,$liburi,$prefix,$depthcount)=@_; $uri=&declutter($uri); @@ -4561,29 +4508,28 @@ sub metadata { # Everything is cached by the main uri, libraries are never directly cached # if (!defined($liburi)) { - my ($result,$cached)=&is_cached_new('meta',$uri); + my ($result,$cached)=&is_cached(\%metacache,$uri,'meta'); 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_new('meta',$uri); - undef(%metaentry); + &devalidate_cache(\%metacache,$uri,'meta'); } my %metathesekeys=(); unless ($filename=~/\.meta$/) { $filename.='.meta'; } my $metastring; if ($uri !~ m|^uploaded/|) { my $file=&filelocation('',&clutter($filename)); - #push(@{$metaentry{$uri.'.file'}},$file); + push(@{$metacache{$uri.'.file'}},$file); $metastring=&getfile($file); } my $parser=HTML::LCParser->new(\$metastring); @@ -4600,10 +4546,10 @@ sub metadata { if (defined($token->[2]->{'id'})) { $keyroot.='_'.$token->[2]->{'id'}; } - if ($metaentry{':packages'}) { - $metaentry{':packages'}.=','.$package.$keyroot; + if ($metacache{$uri}->{':packages'}) { + $metacache{$uri}->{':packages'}.=','.$package.$keyroot; } else { - $metaentry{':packages'}=$package.$keyroot; + $metacache{$uri}->{':packages'}=$package.$keyroot; } foreach (keys %packagetab) { my $part=$keyroot; @@ -4625,14 +4571,14 @@ sub metadata { if ($subp eq 'display') { $value.=' [Part: '.$part.']'; } - $metaentry{':'.$unikey.'.part'}=$part; + $metacache{$uri}->{':'.$unikey.'.part'}=$part; $metathesekeys{$unikey}=1; - unless (defined($metaentry{':'.$unikey.'.'.$subp})) { - $metaentry{':'.$unikey.'.'.$subp}=$value; + unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) { + $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value; } - if (defined($metaentry{':'.$unikey.'.default'})) { - $metaentry{':'.$unikey}= - $metaentry{':'.$unikey.'.default'}; + if (defined($metacache{$uri}->{':'.$unikey.'.default'})) { + $metacache{$uri}->{':'.$unikey}= + $metacache{$uri}->{':'.$unikey.'.default'}; } } } @@ -4665,7 +4611,7 @@ sub metadata { foreach (sort(split(/\,/,&metadata($uri,'keys', $location,$unikey, $depthcount+1)))) { - $metaentry{':'.$_}=$metaentry{':'.$_}; + $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_}; $metathesekeys{$_}=1; } } @@ -4676,18 +4622,18 @@ sub metadata { } $metathesekeys{$unikey}=1; foreach (@{$token->[3]}) { - $metaentry{':'.$unikey.'.'.$_}=$token->[2]->{$_}; + $metacache{$uri}->{':'.$unikey.'.'.$_}=$token->[2]->{$_}; } my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry)); - my $default=$metaentry{':'.$unikey.'.default'}; + my $default=$metacache{$uri}->{':'.$unikey.'.default'}; if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) { # only ws inside the tag, and not in default, so use default # as value - $metaentry{':'.$unikey}=$default; + $metacache{$uri}->{':'.$unikey}=$default; } else { # either something interesting inside the tag or default # uninteresting - $metaentry{':'.$unikey}=$internaltext; + $metacache{$uri}->{':'.$unikey}=$internaltext; } # end of not-a-package not-a-library import } @@ -4704,7 +4650,7 @@ sub metadata { &metadata_create_package_def($uri,$key,'extension_'.$extension, \%metathesekeys); } - if (!exists($metaentry{':packages'})) { + if (!exists($metacache{$uri}->{':packages'})) { foreach my $key (sort(keys(%packagetab))) { #no specific packages well let's get default then if ($key!~/^default&/) { next; } @@ -4713,31 +4659,31 @@ sub metadata { } } # are there custom rights to evaluate - if ($metaentry{':copyright'} eq 'custom') { + if ($metacache{$uri}->{':copyright'} eq 'custom') { # # Importing a rights file here # unless ($depthcount) { - my $location=$metaentry{':customdistributionfile'}; + my $location=$metacache{$uri}->{':customdistributionfile'}; my $dir=$filename; $dir=~s|[^/]*$||; $location=&filelocation($dir,$location); foreach (sort(split(/\,/,&metadata($uri,'keys', $location,'_rights', $depthcount+1)))) { - #$metaentry{':'.$_}=$metacache{$uri}->{':'.$_}; + $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_}; $metathesekeys{$_}=1; } } } - $metaentry{':keys'}=join(',',keys %metathesekeys); - &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); - $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); - &do_cache_new('meta',$uri,\%metaentry); + $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'); # this is the end of "was not already recently cached } - return $metaentry{':'.$what}; + return $metacache{$uri}->{':'.$what}; } sub metadata_create_package_def { @@ -4745,22 +4691,22 @@ sub metadata_create_package_def { my ($pack,$name,$subp)=split(/\&/,$key); if ($subp eq 'default') { next; } - if (defined($metaentry{':packages'})) { - $metaentry{':packages'}.=','.$package; + if (defined($metacache{$uri}->{':packages'})) { + $metacache{$uri}->{':packages'}.=','.$package; } else { - $metaentry{':packages'}=$package; + $metacache{$uri}->{':packages'}=$package; } my $value=$packagetab{$key}; my $unikey; $unikey='parameter_0_'.$name; - $metaentry{':'.$unikey.'.part'}=0; + $metacache{$uri}->{':'.$unikey.'.part'}=0; $$metathesekeys{$unikey}=1; - unless (defined($metaentry{':'.$unikey.'.'.$subp})) { - $metaentry{':'.$unikey.'.'.$subp}=$value; + unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) { + $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value; } - if (defined($metaentry{':'.$unikey.'.default'})) { - $metaentry{':'.$unikey}= - $metaentry{':'.$unikey.'.default'}; + if (defined($metacache{$uri}->{':'.$unikey.'.default'})) { + $metacache{$uri}->{':'.$unikey}= + $metacache{$uri}->{':'.$unikey.'.default'}; } } @@ -4798,8 +4744,7 @@ sub gettitle { my $urlsymb=shift; my $symb=&symbread($urlsymb); if ($symb) { - my $key=$ENV{'request.course.id'}."\0".$symb; - my ($result,$cached)=&is_cached_new('title',$key); + my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600); if (defined($cached)) { return $result; } @@ -4814,7 +4759,7 @@ sub gettitle { } $title=~s/\&colon\;/\:/gs; if ($title) { - return &do_cache_new('title',$key,$title,600); + return &do_cache(\%titlecache,$symb,$title,'title'); } $urlsymb=$url; } @@ -4928,7 +4873,8 @@ sub fixversion { my $uri=&clutter($fn); my $key=$ENV{'request.course.id'}.'_'.$uri; # is this cached? - my ($result,$cached)=&is_cached_new('courseresversion',$key); + my ($result,$cached)=&is_cached(\%courseresversioncache,$key, + 'courseresversion',600); if (defined($cached)) { return $result; } # unfortunately not cached, or expired if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', @@ -4942,7 +4888,8 @@ sub fixversion { } untie %bighash; } - return &do_cache_new('courseresversion',$key,&declutter($uri),600); + return &do_cache + (\%courseresversioncache,$key,&declutter($uri),'courseresversion'); } sub deversion { @@ -5503,39 +5450,42 @@ sub readfile { } sub filelocation { - my ($dir,$file) = @_; - my $location; - $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces - if ($file=~m:^/~:) { # is a contruction space reference - $location = $file; - $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; - } elsif ($file=~/^\/*uploaded/) { # is an uploaded file - my ($udom,$uname,$filename)= - ($file=~m|^/+uploaded/+([^/]+)/+([^/]+)/+(.*)$|); - my $home=&homeserver($uname,$udom); - my $is_me=0; - my @ids=¤t_machine_ids(); - foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } } - if ($is_me) { - $location=&Apache::loncommon::propath($udom,$uname). - '/userfiles/'.$filename; - } else { - $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'. - $udom.'/'.$uname.'/'.$filename; - } - } else { - $file=~s/^\Q$perlvar{'lonDocRoot'}\E//; - $file=~s:^/res/:/:; - if ( !( $file =~ m:^/:) ) { - $location = $dir. '/'.$file; - } else { - $location = '/home/httpd/html/res'.$file; + my ($dir,$file) = @_; + my $location; + $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces + if ($file=~m:^/~:) { # is a contruction space reference + $location = $file; + $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; + } elsif ($file=~/^\/*uploaded/) { # is an uploaded file + my ($udom,$uname,$filename)= + ($file=~m|^/+uploaded/+([^/]+)/+([^/]+)/+(.*)$|); + my $home=&homeserver($uname,$udom); + my $is_me=0; + my @ids=¤t_machine_ids(); + foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } } + if ($is_me) { + $location=&Apache::loncommon::propath($udom,$uname). + '/userfiles/'.$filename; + } else { + $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'. + $udom.'/'.$uname.'/'.$filename; + } + } elsif ($file =~ /^\/adm\/portfolio\//) { + $file =~ s:^/adm/portfolio/::; + $location = $location=&Apache::loncommon::propath($ENV{'user.domain'},$ENV{'user.name'}).'/userfiles/portfolio/'.$file; + } else { + $file=~s/^\Q$perlvar{'lonDocRoot'}\E//; + $file=~s:^/res/:/:; + if ( !( $file =~ m:^/:) ) { + $location = $dir. '/'.$file; + } else { + $location = '/home/httpd/html/res'.$file; + } } - } - $location=~s://+:/:g; # remove duplicate / - while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/.. - while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./ - return $location; + $location=~s://+:/:g; # remove duplicate / + while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/.. + while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./ + return $location; } sub hreflocation { @@ -5651,20 +5601,17 @@ 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',length(&freeze(\%badServerCache)))); + &logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache))); #converted -# &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)))); + &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))); #1.1 only -# &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)); + &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))); &flushcourselogs(); &logthis("Shutting down"); return DONE; @@ -5735,18 +5682,32 @@ BEGIN { while (my $configline=<$config>) { next if ($configline =~ /^(\#|\s*$)/); chomp($configline); - my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline); - if ($id && $domain && $role && $name && $ip) { + my ($id,$domain,$role,$name)=split(/:/,$configline); + $name=~s/\s//g; + if ($id && $domain && $role && $name) { $hostname{$id}=$name; $hostdom{$id}=$domain; - $hostip{$id}=$ip; - $iphost{$ip}=$id; if ($role eq 'library') { $libserv{$id}=$name; } } } close($config); } +sub get_iphost { + if (%iphost) { return %iphost; } + foreach my $id (keys(%hostname)) { + my $name=$hostname{$id}; + my $ip = gethostbyname($name); + if (!$ip || length($ip) ne 4) { + &logthis("Skipping host $id name $name no IP found\n"); + next; + } + $ip=inet_ntoa($ip); + push(@{$iphost{$ip}},$id); + } + return %iphost; +} + # ------------------------------------------------------ Read spare server file { open(my $config,"<$perlvar{'lonTabDir'}/spare.tab"); @@ -5810,7 +5771,7 @@ BEGIN { } -$memcache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']}); +%metacache=(); $processmarker='_'.time.'_'.$perlvar{'lonHostID'}; $dumpcount=0;