loncom/lonnet/perl/lonnet.pm - diff

Return to lonnet.pm CVS log

Up to [LON-CAPA] / loncom / lonnet / perl

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.587.2.3.2.11 and 1.590

version 1.587.2.3.2.11, 2005/02/14 04:29:43	version 1.590, 2005/01/19 01:25:35
Line 35 use HTTP::Headers;	Line 35 use HTTP::Headers;
use HTTP::Date;	use HTTP::Date;
# use Date::Parse;	# use Date::Parse;
use vars	use vars
qw(%perlvar %hostname %badServerCache %hostip %iphost %spareid %hostdom	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	%courselogs %accesshash %userrolehash $processmarker $dumpcount
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf	%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %courseresdatacache
%domaindescription %domain_auth_def %domain_auth_arg_def	%userresdatacache %getsectioncache %domaindescription %domain_auth_def %domain_auth_arg_def
%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit);	%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit);

use IO::Socket;	use IO::Socket;
Line 50 use Fcntl qw(:flock);	Line 50 use Fcntl qw(:flock);
use Apache::lonlocal;	use Apache::lonlocal;
use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);	use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);
use Time::HiRes qw( gettimeofday tv_interval );	use Time::HiRes qw( gettimeofday tv_interval );
use Cache::Memcached;
my $readit;	my $readit;
my $max_connection_retries = 10; # Or some such value.	my $max_connection_retries = 10; # Or some such value.

Line 563 sub homeserver {	Line 562 sub homeserver {
my ($uname,$udom,$ignoreBadCache)=@_;	my ($uname,$udom,$ignoreBadCache)=@_;
my $index="$uname:$udom";	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; }	if (defined($cached)) { return $result; }
my $tryserver;	my $tryserver;
foreach $tryserver (keys %libserv) {	foreach $tryserver (keys %libserv) {
Line 572 sub homeserver {	Line 571 sub homeserver {
if ($hostdom{$tryserver} eq $udom) {	if ($hostdom{$tryserver} eq $udom) {
my $answer=reply("home:$udom:$uname",$tryserver);	my $answer=reply("home:$udom:$uname",$tryserver);
if ($answer eq 'found') {	if ($answer eq 'found') {
return &do_cache_new('home',$index,$tryserver,86400);	return &do_cache(\%homecache,$index,$tryserver,'home');
} elsif ($answer eq 'no_host') {	} elsif ($answer eq 'no_host') {
$badServerCache{$tryserver}=1;	$badServerCache{$tryserver}=1;
}	}
Line 777 sub validate_access_key {	Line 776 sub validate_access_key {

sub getsection {	sub getsection {
my ($udom,$unam,$courseid)=@_;	my ($udom,$unam,$courseid)=@_;
my $cachetime=1800;
$courseid=~s/\_/\//g;	$courseid=~s/\_/\//g;
$courseid=~s/^(\w)/\/$1/;	$courseid=~s/^(\w)/\/$1/;

my $hashid="$udom:$unam:$courseid";	my $hashid="$udom:$unam:$courseid";
my ($result,$cached)=&is_cached_new('getsection',$hashid,1);	my ($result,$cached)=&is_cached(\%getsectioncache,$hashid,'getsection');
if (defined($cached)) { return $result; }	if (defined($cached)) { return $result; }

my %Pending;	my %Pending;
Line 817 sub getsection {	Line 815 sub getsection {
$Pending{$start}=$section;	$Pending{$start}=$section;
next;	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	# Presumedly there will be few matching roles from the above
# loop and the sorting time will be negligible.	# loop and the sorting time will be negligible.
if (scalar(keys(%Pending))) {	if (scalar(keys(%Pending))) {
my ($time) = sort {$a <=> $b} 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))) {	if (scalar(keys(%Expired))) {
my @sorted = sort {$a <=> $b} keys(%Expired);	my @sorted = sort {$a <=> $b} keys(%Expired);
my $time = pop(@sorted);	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');
}	}


Line 925 sub save_cache_item {	Line 923 sub save_cache_item {
}	}

sub save_cache {	sub save_cache {
&purge_remembered();
if ($disk_caching_disabled) { return; }	if ($disk_caching_disabled) { return; }
my ($cache,$name,$id);	my ($cache,$name,$id);
foreach $name (keys(%do_save)) {	foreach $name (keys(%do_save)) {
Line 1023 EVALBLOCK	Line 1020 EVALBLOCK
# &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime));	# &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,$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	# ------------------------------------- Read an entry from a user's environment

sub userenvironment {	sub userenvironment {
Line 1135 sub getversion {	Line 1057 sub getversion {

sub currentversion {	sub currentversion {
my $fname=shift;	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; }	if (defined($cached)) { return $result; }
my $author=$fname;	my $author=$fname;
$author=~s/\/home\/httpd\/html\/res\/([^\/])\/([^\/]).*/$1\/$2/;	$author=~s/\/home\/httpd\/html\/res\/([^\/])\/([^\/]).*/$1\/$2/;
Line 1148 sub currentversion {	Line 1070 sub currentversion {
if (($answer eq 'con_lost') \|\| ($answer eq 'rejected')) {	if (($answer eq 'con_lost') \|\| ($answer eq 'rejected')) {
return -1;	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	# ----------------------------- Subscribe to a resource, return URL if possible
Line 1817 sub get_first_access {	Line 1739 sub get_first_access {
my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();	my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
if ($argsymb) { $symb=$argsymb; }	if ($argsymb) { $symb=$argsymb; }
my ($map,$id,$res)=&decode_symb($symb);	my ($map,$id,$res)=&decode_symb($symb);
if ($type eq 'map') { $res=$map; }	if ($type eq 'map') {
my %times=&get('firstaccesstimes',[$res],$udom,$uname);	$res=&symbread($map);
return $times{$res};	} else {
	$res=$symb;
	}
	my %times=&get('firstaccesstimes',["$courseid\0$res"],$udom,$uname);
	return $times{"$courseid\0$res"};
}	}

sub set_first_access {	sub set_first_access {
my ($type)=@_;	my ($type)=@_;
my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();	my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
my ($map,$id,$res)=&decode_symb($symb);	my ($map,$id,$res)=&decode_symb($symb);
if ($type eq 'map') { $res=$map; }	if ($type eq 'map') {
my $firstaccess=&get_first_access($type);	$res=&symbread($map);
	} else {
	$res=$symb;
	}
	my $firstaccess=&get_first_access($type,$symb);
if (!$firstaccess) {	if (!$firstaccess) {
return &put('firstaccesstimes',{$res=>time},$udom,$uname);	return &put('firstaccesstimes',{"$courseid\0$res"=>time},$udom,$uname);
}	}
return 'already_set';	return 'already_set';
}	}
Line 4200 sub condval {	Line 4130 sub condval {
sub devalidatecourseresdata {	sub devalidatecourseresdata {
my ($coursenum,$coursedomain)=@_;	my ($coursenum,$coursedomain)=@_;
my $hashid=$coursenum.':'.$coursedomain;	my $hashid=$coursenum.':'.$coursedomain;
&devalidate_cache_new('courseres',$hashid);	&devalidate_cache(\%courseresdatacache,$hashid,'courseres');
}	}

# --------------------------------------------------- Course Resourcedata Query	# --------------------------------------------------- Course Resourcedata Query
Line 4209 sub courseresdata {	Line 4139 sub courseresdata {
my ($coursenum,$coursedomain,@which)=@_;	my ($coursenum,$coursedomain,@which)=@_;
my $coursehom=&homeserver($coursenum,$coursedomain);	my $coursehom=&homeserver($coursenum,$coursedomain);
my $hashid=$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)) {	unless (defined($cached)) {
my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum);	my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum);
$result=\%dumpreply;	$result=\%dumpreply;
my ($tmp) = keys(%dumpreply);	my ($tmp) = keys(%dumpreply);
if ($tmp !~ /^(con_lost\|error\|no_such_host)/i) {	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)/) {	} elsif ($tmp =~ /^(con_lost\|no_such_host)/) {
return $tmp;	return $tmp;
} elsif ($tmp =~ /^(error)/) {	} elsif ($tmp =~ /^(error)/) {
$result=undef;	$result=undef;
&do_cache_new('courseres',$hashid,$result,600);	&do_cache(\%courseresdatacache,$hashid,$result,'courseres');
}	}
}	}
foreach my $item (@which) {	foreach my $item (@which) {
Line 4409 sub EXT {	Line 4339 sub EXT {
#most student don\'t have any data set, check if there is some data	#most student don\'t have any data set, check if there is some data
if (! &EXT_cache_status($udom,$uname)) {	if (! &EXT_cache_status($udom,$uname)) {
my $hashid="$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)) {	if (!defined($cached)) {
my %resourcedata=&dump('resourcedata',$udom,$uname);	my %resourcedata=&dump('resourcedata',$udom,$uname);
$result=\%resourcedata;	$result=\%resourcedata;
&do_cache_new('userres',$hashid,$result);	&do_cache(\%userresdatacache,$hashid,$result,'userres');
}	}
my ($tmp)=keys(%$result);	my ($tmp)=keys(%$result);
if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {	if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {
Line 4541 sub add_prefix_and_part {	Line 4472 sub add_prefix_and_part {

# ---------------------------------------------------------------- Get metadata	# ---------------------------------------------------------------- Get metadata

my %metaentry;
sub metadata {	sub metadata {
my ($uri,$what,$liburi,$prefix,$depthcount)=@_;	my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
$uri=&declutter($uri);	$uri=&declutter($uri);
Line 4561 sub metadata {	Line 4491 sub metadata {
# Everything is cached by the main uri, libraries are never directly cached	# Everything is cached by the main uri, libraries are never directly cached
#	#
if (!defined($liburi)) {	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}; }	if (defined($cached)) { return $result->{':'.$what}; }
}	}
{	{
#	#
# Is this a recursive call for a library?	# Is this a recursive call for a library?
#	#
# if (! exists($metacache{$uri})) {	if (! exists($metacache{$uri})) {
# $metacache{$uri}={};	$metacache{$uri}={};
# }	}
if ($liburi) {	if ($liburi) {
$liburi=&declutter($liburi);	$liburi=&declutter($liburi);
$filename=$liburi;	$filename=$liburi;
} else {	} else {
&devalidate_cache_new('meta',$uri);	&devalidate_cache(\%metacache,$uri,'meta');
undef(%metaentry);
}	}
my %metathesekeys=();	my %metathesekeys=();
unless ($filename=~/\.meta$/) { $filename.='.meta'; }	unless ($filename=~/\.meta$/) { $filename.='.meta'; }
my $metastring;	my $metastring;
if ($uri !~ m\|^uploaded/\|) {	if ($uri !~ m\|^uploaded/\|) {
my $file=&filelocation('',&clutter($filename));	my $file=&filelocation('',&clutter($filename));
#push(@{$metaentry{$uri.'.file'}},$file);	push(@{$metacache{$uri.'.file'}},$file);
$metastring=&getfile($file);	$metastring=&getfile($file);
}	}
my $parser=HTML::LCParser->new(\$metastring);	my $parser=HTML::LCParser->new(\$metastring);
Line 4600 sub metadata {	Line 4529 sub metadata {
if (defined($token->[2]->{'id'})) {	if (defined($token->[2]->{'id'})) {
$keyroot.='_'.$token->[2]->{'id'};	$keyroot.='_'.$token->[2]->{'id'};
}	}
if ($metaentry{':packages'}) {	if ($metacache{$uri}->{':packages'}) {
$metaentry{':packages'}.=','.$package.$keyroot;	$metacache{$uri}->{':packages'}.=','.$package.$keyroot;
} else {	} else {
$metaentry{':packages'}=$package.$keyroot;	$metacache{$uri}->{':packages'}=$package.$keyroot;
}	}
foreach (keys %packagetab) {	foreach (keys %packagetab) {
my $part=$keyroot;	my $part=$keyroot;
Line 4625 sub metadata {	Line 4554 sub metadata {
if ($subp eq 'display') {	if ($subp eq 'display') {
$value.=' [Part: '.$part.']';	$value.=' [Part: '.$part.']';
}	}
$metaentry{':'.$unikey.'.part'}=$part;	$metacache{$uri}->{':'.$unikey.'.part'}=$part;
$metathesekeys{$unikey}=1;	$metathesekeys{$unikey}=1;
unless (defined($metaentry{':'.$unikey.'.'.$subp})) {	unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) {
$metaentry{':'.$unikey.'.'.$subp}=$value;	$metacache{$uri}->{':'.$unikey.'.'.$subp}=$value;
}	}
if (defined($metaentry{':'.$unikey.'.default'})) {	if (defined($metacache{$uri}->{':'.$unikey.'.default'})) {
$metaentry{':'.$unikey}=	$metacache{$uri}->{':'.$unikey}=
$metaentry{':'.$unikey.'.default'};	$metacache{$uri}->{':'.$unikey.'.default'};
}	}
}	}
}	}
Line 4665 sub metadata {	Line 4594 sub metadata {
foreach (sort(split(/\,/,&metadata($uri,'keys',	foreach (sort(split(/\,/,&metadata($uri,'keys',
$location,$unikey,	$location,$unikey,
$depthcount+1)))) {	$depthcount+1)))) {
$metaentry{':'.$_}=$metaentry{':'.$_};	$metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_};
$metathesekeys{$_}=1;	$metathesekeys{$_}=1;
}	}
}	}
Line 4676 sub metadata {	Line 4605 sub metadata {
}	}
$metathesekeys{$unikey}=1;	$metathesekeys{$unikey}=1;
foreach (@{$token->[3]}) {	foreach (@{$token->[3]}) {
$metaentry{':'.$unikey.'.'.$_}=$token->[2]->{$_};	$metacache{$uri}->{':'.$unikey.'.'.$_}=$token->[2]->{$_};
}	}
my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));	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$/) {	if ( $internaltext =~ /^\s$/ && $default !~ /^\s$/) {
# only ws inside the tag, and not in default, so use default	# only ws inside the tag, and not in default, so use default
# as value	# as value
$metaentry{':'.$unikey}=$default;	$metacache{$uri}->{':'.$unikey}=$default;
} else {	} else {
# either something interesting inside the tag or default	# either something interesting inside the tag or default
# uninteresting	# uninteresting
$metaentry{':'.$unikey}=$internaltext;	$metacache{$uri}->{':'.$unikey}=$internaltext;
}	}
# end of not-a-package not-a-library import	# end of not-a-package not-a-library import
}	}
Line 4704 sub metadata {	Line 4633 sub metadata {
&metadata_create_package_def($uri,$key,'extension_'.$extension,	&metadata_create_package_def($uri,$key,'extension_'.$extension,
\%metathesekeys);	\%metathesekeys);
}	}
if (!exists($metaentry{':packages'})) {	if (!exists($metacache{$uri}->{':packages'})) {
foreach my $key (sort(keys(%packagetab))) {	foreach my $key (sort(keys(%packagetab))) {
#no specific packages well let's get default then	#no specific packages well let's get default then
if ($key!~/^default&/) { next; }	if ($key!~/^default&/) { next; }
Line 4713 sub metadata {	Line 4642 sub metadata {
}	}
}	}
# are there custom rights to evaluate	# are there custom rights to evaluate
if ($metaentry{':copyright'} eq 'custom') {	if ($metacache{$uri}->{':copyright'} eq 'custom') {

#	#
# Importing a rights file here	# Importing a rights file here
#	#
unless ($depthcount) {	unless ($depthcount) {
my $location=$metaentry{':customdistributionfile'};	my $location=$metacache{$uri}->{':customdistributionfile'};
my $dir=$filename;	my $dir=$filename;
$dir=~s\|[^/]*$\|\|;	$dir=~s\|[^/]*$\|\|;
$location=&filelocation($dir,$location);	$location=&filelocation($dir,$location);
foreach (sort(split(/\,/,&metadata($uri,'keys',	foreach (sort(split(/\,/,&metadata($uri,'keys',
$location,'_rights',	$location,'_rights',
$depthcount+1)))) {	$depthcount+1)))) {
#$metaentry{':'.$_}=$metacache{$uri}->{':'.$_};	$metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_};
$metathesekeys{$_}=1;	$metathesekeys{$_}=1;
}	}
}	}
}	}
$metaentry{':keys'}=join(',',keys %metathesekeys);	$metacache{$uri}->{':keys'}=join(',',keys %metathesekeys);
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);	&metadata_generate_part0(\%metathesekeys,$metacache{$uri},$uri);
$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);	$metacache{$uri}->{':allpossiblekeys'}=join(',',keys %metathesekeys);
&do_cache_new('meta',$uri,\%metaentry);	&do_cache(\%metacache,$uri,$metacache{$uri},'meta');
# this is the end of "was not already recently cached	# this is the end of "was not already recently cached
}	}
return $metaentry{':'.$what};	return $metacache{$uri}->{':'.$what};
}	}

sub metadata_create_package_def {	sub metadata_create_package_def {
Line 4745 sub metadata_create_package_def {	Line 4674 sub metadata_create_package_def {
my ($pack,$name,$subp)=split(/\&/,$key);	my ($pack,$name,$subp)=split(/\&/,$key);
if ($subp eq 'default') { next; }	if ($subp eq 'default') { next; }

if (defined($metaentry{':packages'})) {	if (defined($metacache{$uri}->{':packages'})) {
$metaentry{':packages'}.=','.$package;	$metacache{$uri}->{':packages'}.=','.$package;
} else {	} else {
$metaentry{':packages'}=$package;	$metacache{$uri}->{':packages'}=$package;
}	}
my $value=$packagetab{$key};	my $value=$packagetab{$key};
my $unikey;	my $unikey;
$unikey='parameter_0_'.$name;	$unikey='parameter_0_'.$name;
$metaentry{':'.$unikey.'.part'}=0;	$metacache{$uri}->{':'.$unikey.'.part'}=0;
$$metathesekeys{$unikey}=1;	$$metathesekeys{$unikey}=1;
unless (defined($metaentry{':'.$unikey.'.'.$subp})) {	unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) {
$metaentry{':'.$unikey.'.'.$subp}=$value;	$metacache{$uri}->{':'.$unikey.'.'.$subp}=$value;
}	}
if (defined($metaentry{':'.$unikey.'.default'})) {	if (defined($metacache{$uri}->{':'.$unikey.'.default'})) {
$metaentry{':'.$unikey}=	$metacache{$uri}->{':'.$unikey}=
$metaentry{':'.$unikey.'.default'};	$metacache{$uri}->{':'.$unikey.'.default'};
}	}
}	}

Line 4798 sub gettitle {	Line 4727 sub gettitle {
my $urlsymb=shift;	my $urlsymb=shift;
my $symb=&symbread($urlsymb);	my $symb=&symbread($urlsymb);
if ($symb) {	if ($symb) {
my $key=$ENV{'request.course.id'}."\0".$symb;	my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);
my ($result,$cached)=&is_cached_new('title',$key);
if (defined($cached)) {	if (defined($cached)) {
return $result;	return $result;
}	}
Line 4814 sub gettitle {	Line 4742 sub gettitle {
}	}
$title=~s/\&colon\;/\:/gs;	$title=~s/\&colon\;/\:/gs;
if ($title) {	if ($title) {
return &do_cache_new('title',$key,$title,600);	return &do_cache(\%titlecache,$symb,$title,'title');
}	}
$urlsymb=$url;	$urlsymb=$url;
}	}
Line 4928 sub fixversion {	Line 4856 sub fixversion {
my $uri=&clutter($fn);	my $uri=&clutter($fn);
my $key=$ENV{'request.course.id'}.'_'.$uri;	my $key=$ENV{'request.course.id'}.'_'.$uri;
# is this cached?	# 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; }	if (defined($cached)) { return $result; }
# unfortunately not cached, or expired	# unfortunately not cached, or expired
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',	if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
Line 4942 sub fixversion {	Line 4871 sub fixversion {
}	}
untie %bighash;	untie %bighash;
}	}
return &do_cache_new('courseresversion',$key,&declutter($uri),600);	return &do_cache
	(\%courseresversioncache,$key,&declutter($uri),'courseresversion');
}	}

sub deversion {	sub deversion {
Line 5503 sub readfile {	Line 5433 sub readfile {
}	}

sub filelocation {	sub filelocation {
my ($dir,$file) = @_;	my ($dir,$file) = @_;
my $location;	my $location;
$file=~ s/^\s(\S+)\s$/$1/; ## strip off leading and trailing spaces	$file=~ s/^\s(\S+)\s$/$1/; ## strip off leading and trailing spaces
if ($file=~m:^/~:) { # is a contruction space reference	if ($file=~m:^/~:) { # is a contruction space reference
$location = $file;	$location = $file;
$location =~ s:/~(.?)/(.):/home/$1/public_html/$2:;	$location =~ s:/~(.?)/(.):/home/$1/public_html/$2:;
} elsif ($file=~/^\/*uploaded/) { # is an uploaded file	} elsif ($file=~/^\/*uploaded/) { # is an uploaded file
my ($udom,$uname,$filename)=	my ($udom,$uname,$filename)=
($file=~m\|^/+uploaded/+([^/]+)/+([^/]+)/+(.*)$\|);	($file=~m\|^/+uploaded/+([^/]+)/+([^/]+)/+(.*)$\|);
my $home=&homeserver($uname,$udom);	my $home=&homeserver($uname,$udom);
my $is_me=0;	my $is_me=0;
my @ids=&current_machine_ids();	my @ids=&current_machine_ids();
foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }	foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
if ($is_me) {	if ($is_me) {
$location=&Apache::loncommon::propath($udom,$uname).	$location=&Apache::loncommon::propath($udom,$uname).
'/userfiles/'.$filename;	'/userfiles/'.$filename;
} else {	} else {
$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.	$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
$udom.'/'.$uname.'/'.$filename;	$udom.'/'.$uname.'/'.$filename;
}	}
} else {	} elsif ($file =~ /^\/adm\/portfolio\//) {
$file=~s/^\Q$perlvar{'lonDocRoot'}\E//;	$file =~ s:^/adm/portfolio/::;
$file=~s:^/res/:/:;	$location = $location=&Apache::loncommon::propath($ENV{'user.domain'},$ENV{'user.name'}).'/userfiles/portfolio/'.$file;
if ( !( $file =~ m:^/:) ) {	} else {
$location = $dir. '/'.$file;	$file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
} else {	$file=~s:^/res/:/:;
$location = '/home/httpd/html/res'.$file;	if ( !( $file =~ m:^/:) ) {
	$location = $dir. '/'.$file;
	} else {
	$location = '/home/httpd/html/res'.$file;
	}
}	}
}	$location=~s://+:/:g; # remove duplicate /
$location=~s://+:/:g; # remove duplicate /	while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..	while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./
while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./	return $location;
return $location;
}	}

sub hreflocation {	sub hreflocation {
Line 5651 sub correct_line_ends {	Line 5584 sub correct_line_ends {
sub goodbye {	sub goodbye {
&logthis("Starting Shut down");	&logthis("Starting Shut down");
#not converted to using infrastruture and probably shouldn't be	#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	#converted
# &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));	&logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
# &logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache))));	&logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache)));
# &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache))));	&logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache)));
# &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache))));	&logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache)));
#1.1 only	#1.1 only
# &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache))));	&logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache)));
# &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache))));	&logthis(sprintf("%-20s is %s",'%getsectioncache',scalar(%getsectioncache)));
# &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache))));	&logthis(sprintf("%-20s is %s",'%courseresversioncache',scalar(%courseresversioncache)));
# &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%resversioncache))));	&logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%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();	&flushcourselogs();
&logthis("Shutting down");	&logthis("Shutting down");
return DONE;	return DONE;
Line 5810 BEGIN {	Line 5740 BEGIN {

}	}

$memcache=new Cache::Memcached({'servers'=>['127.0.0.1:11211']});	%metacache=();

$processmarker='_'.time.'_'.$perlvar{'lonHostID'};	$processmarker='_'.time.'_'.$perlvar{'lonHostID'};
$dumpcount=0;	$dumpcount=0;

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>

Removed from v.1.587.2.3.2.11
changed lines
	Added in v.1.590