--- loncom/lonnet/perl/lonnet.pm 2005/02/14 02:22:25 1.587.2.3.2.6
+++ loncom/lonnet/perl/lonnet.pm 2005/01/31 11:27:14 1.592
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.587.2.3.2.6 2005/02/14 02:22:25 albertel Exp $
+# $Id: lonnet.pm,v 1.592 2005/01/31 11:27:14 www 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 $memcache %packagetab
+ %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache
%courselogs %accesshash %userrolehash $processmarker $dumpcount
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %courseresdatacache
%userresdatacache %getsectioncache %domaindescription %domain_auth_def %domain_auth_arg_def
@@ -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.
@@ -924,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)) {
@@ -1022,84 +1020,6 @@ EVALBLOCK
# &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime));
}
-my $to_remember=10;
-my %remembered;
-my %accessed;
-my $kicks=0;
-my $hits=0;
-sub devalidate_cache_new {
- my ($name,$id) = @_;
- if (0) { &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) = @_;
- $debug=0;
- $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);
- 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) = @_;
- $debug=0;
- $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);
- return $value;
-}
-
-sub make_room {
- my ($id,$value)=@_;
- my $debug=0;
- $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 {
@@ -1137,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/;
@@ -1150,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
@@ -1819,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';
}
@@ -2172,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',
@@ -2207,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';
@@ -2221,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';
@@ -2248,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;
@@ -2269,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))) {
@@ -2311,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);
@@ -2347,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);
@@ -2381,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++) {
@@ -2772,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/\:$//;
@@ -3642,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.', '.
@@ -4544,7 +4481,6 @@ sub add_prefix_and_part {
# ---------------------------------------------------------------- Get metadata
-my %metaentry;
sub metadata {
my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
$uri=&declutter($uri);
@@ -4564,29 +4500,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);
@@ -4603,10 +4538,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;
@@ -4628,14 +4563,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'};
}
}
}
@@ -4668,7 +4603,7 @@ sub metadata {
foreach (sort(split(/\,/,&metadata($uri,'keys',
$location,$unikey,
$depthcount+1)))) {
- $metaentry{':'.$_}=$metaentry{':'.$_};
+ $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_};
$metathesekeys{$_}=1;
}
}
@@ -4679,18 +4614,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
}
@@ -4707,7 +4642,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; }
@@ -4716,31 +4651,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 {
@@ -4748,22 +4683,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'};
}
}
@@ -4801,8 +4736,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;
}
@@ -4817,7 +4751,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;
}
@@ -4931,7 +4865,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',
@@ -4945,7 +4880,8 @@ sub fixversion {
}
untie %bighash;
}
- return &do_cache_new('courseresversion',$key,&declutter($uri),600);
+ return &do_cache
+ (\%courseresversioncache,$key,&declutter($uri),'courseresversion');
}
sub deversion {
@@ -5506,39 +5442,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 {
@@ -5654,20 +5593,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;
@@ -5813,7 +5749,7 @@ BEGIN {
}
-$memcache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']});
+%metacache=();
$processmarker='_'.time.'_'.$perlvar{'lonHostID'};
$dumpcount=0;