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.417 and 1.430

version 1.417, 2003/09/19 16:53:35	version 1.430, 2003/10/12 22:02:44
Line 76 qw(%perlvar %hostname %homecache %badSer	Line 76 qw(%perlvar %hostname %homecache %badSer
%libserv %pr %prp %metacache %packagetab %titlecache	%libserv %pr %prp %metacache %packagetab %titlecache
%courselogs %accesshash %userrolehash $processmarker $dumpcount	%courselogs %accesshash %userrolehash $processmarker $dumpcount
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache	%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache
%usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def	%userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def
%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir);	%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir);

use IO::Socket;	use IO::Socket;
Line 86 use HTML::LCParser;	Line 86 use HTML::LCParser;
use Fcntl qw(:flock);	use Fcntl qw(:flock);
use Apache::loncoursedata;	use Apache::loncoursedata;
use Apache::lonlocal;	use Apache::lonlocal;
	use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw);
	use Time::HiRes();
my $readit;	my $readit;

# --------------------------------------------------------------------- Logging	# --------------------------------------------------------------------- Logging
Line 585 sub authenticate {	Line 586 sub authenticate {
sub homeserver {	sub homeserver {
my ($uname,$udom,$ignoreBadCache)=@_;	my ($uname,$udom,$ignoreBadCache)=@_;
my $index="$uname:$udom";	my $index="$uname:$udom";
if ($homecache{$index}) {
return "$homecache{$index}";	my ($result,$cached)=&is_cached(\%homecache,$index,'home',86400);
}	if (defined($cached)) { return $result; }
my $tryserver;	my $tryserver;
foreach $tryserver (keys %libserv) {	foreach $tryserver (keys %libserv) {
next if ($ignoreBadCache ne 'true' &&	next if ($ignoreBadCache ne 'true' &&
Line 595 sub homeserver {	Line 596 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') {
$homecache{$index}=$tryserver;	return &do_cache(\%homecache,$index,$tryserver,'home');
return $tryserver;
} elsif ($answer eq 'no_host') {	} elsif ($answer eq 'no_host') {
$badServerCache{$tryserver}=1;	$badServerCache{$tryserver}=1;
}	}
Line 849 sub getsection {	Line 849 sub getsection {
}	}

sub devalidate_cache {	sub devalidate_cache {
my ($cache,$id) = @_;	my ($cache,$id,$name) = @_;
delete $$cache{$id.'.time'};	delete $$cache{$id.'.time'};
delete $$cache{$id};	delete $$cache{$id};
	my $filename=$perlvar{'lonDaemons'}.'/tmp/'.$name.".db";
	open(DB,"$filename.lock");
	flock(DB,LOCK_EX);
	my %hash;
	if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
	delete($hash{$id});
	delete($hash{$id.'.time'});
	} else {
	&logthis("Unable to tie hash");
	}
	untie(%hash);
	flock(DB,LOCK_UN);
	close(DB);
}	}

sub is_cached {	sub is_cached {
my ($cache,$id,$time) = @_;	my ($cache,$id,$name,$time) = @_;
	if (!$time) { $time=300; }
	if (!exists($$cache{$id.'.time'})) {
	&load_cache_item($cache,$name,$id);
	}
if (!exists($$cache{$id.'.time'})) {	if (!exists($$cache{$id.'.time'})) {
	# &logthis("Didn't find $id");
return (undef,undef);	return (undef,undef);
} else {	} else {
if (time-$$cache{$id.'.time'}>$time) {	if (time-($$cache{$id.'.time'})>$time) {
&devalidate_cache($cache,$id);	# &logthis("Devailidating $id - ".time-($$cache{$id.'.time'}));
	&devalidate_cache($cache,$id,$name);
return (undef,undef);	return (undef,undef);
}	}
}	}
Line 868 sub is_cached {	Line 887 sub is_cached {
}	}

sub do_cache {	sub do_cache {
my ($cache,$id,$value) = @_;	my ($cache,$id,$value,$name) = @_;
$$cache{$id.'.time'}=time;	$$cache{$id.'.time'}=time;
# do_cache implictly return the set value
$$cache{$id}=$value;	$$cache{$id}=$value;
	# &logthis("Caching $id as :$value:");
	&save_cache_item($cache,$name,$id);
	# do_cache implictly return the set value
	$$cache{$id};
	}

	sub save_cache {
	my ($cache,$name)=@_;
	my $starttime=&Time::HiRes::time();
	# &logthis("Saving :$name:");
	eval lock_store($cache,$perlvar{'lonDaemons'}.'/tmp/'.$name.".storable");
	if ($@) { &logthis("lock_store threw a die ".$@); }
	# &logthis("save_cache took ".(&Time::HiRes::time()-$starttime));
	}

	sub load_cache {
	my ($cache,$name)=@_;
	my $starttime=&Time::HiRes::time();
	# &logthis("Before Loading $name size is ".scalar(%$cache));
	my $tmpcache;
	eval {
	$tmpcache=lock_retrieve($perlvar{'lonDaemons'}.'/tmp/'.$name.".storable");
	};
	if ($@) { &logthis("lock_retreive threw a die ".$@); return; }
	if (!%$cache) {
	my $count;
	while (my ($key,$value)=each(%$tmpcache)) {
	$count++;
	$$cache{$key}=$value;
	}
	# &logthis("Initial load: $count");
	} else {
	my $key;
	my $count;
	while ($key=each(%$tmpcache)) {
	if ($key !~/^(.*)\.time$/) { next; }
	my $name=$1;
	if (exists($$cache{$key})) {
	if ($$tmpcache{$key} >= $$cache{$key}) {
	$$cache{$key}=$$tmpcache{$key};
	$$cache{$name}=$$tmpcache{$name};
	} else {
	# &logthis("Would have overwritten $name with is set to expire at ".$$cache{$key}." with ".$$tmpcache{$key}." Whew!");
	}
	} else {
	$count++;
	$$cache{$key}=$$tmpcache{$key};
	$$cache{$name}=$$tmpcache{$name};
	}
	}
	# &logthis("Additional load: $count");
	}
	# &logthis("After Loading $name size is ".scalar(%$cache));
	# &logthis("load_cache took ".(&Time::HiRes::time()-$starttime));
	}

	sub save_cache_item {
	my ($cache,$name,$id)=@_;
	my $starttime=&Time::HiRes::time();
	# &logthis("Saving :$name:$id");
	my %hash;
	my $filename=$perlvar{'lonDaemons'}.'/tmp/'.$name.".db";
	open(DB,"$filename.lock");
	flock(DB,LOCK_EX);
	if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
	$hash{$id.'.time'}=$$cache{$id.'.time'};
	$hash{$id}=freeze({'item'=>$$cache{$id}});
	} else {
	&logthis("Unable to tie hash");
	}
	untie(%hash);
	flock(DB,LOCK_UN);
	close(DB);
	# &logthis("save_cache_item $name took ".(&Time::HiRes::time()-$starttime));
	}

	sub load_cache_item {
	my ($cache,$name,$id)=@_;
	my $starttime=&Time::HiRes::time();
	# &logthis("Before Loading $name for $id size is ".scalar(%$cache));
	my %hash;
	my $filename=$perlvar{'lonDaemons'}.'/tmp/'.$name.".db";
	open(DB,"$filename.lock");
	flock(DB,LOCK_SH);
	if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) {
	if (!%$cache) {
	my $count;
	while (my ($key,$value)=each(%hash)) {
	$count++;
	if ($key =~ /\.time$/) {
	$$cache{$key}=$value;
	} else {
	my $hashref=thaw($value);
	$$cache{$key}=$hashref->{'item'};
	}
	}
	# &logthis("Initial load: $count");
	} else {
	my $hashref=thaw($hash{$id});
	$$cache{$id}=$hashref->{'item'};
	$$cache{$id.'.time'}=$hash{$id.'.time'};
	}
	} else {
	&logthis("Unable to tie hash");
	}
	untie(%hash);
	flock(DB,LOCK_UN);
	close(DB);
	# &logthis("After Loading $name size is ".scalar(%$cache));
	# &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime));
}	}

sub usection {	sub usection {
my ($udom,$unam,$courseid)=@_;	my ($udom,$unam,$courseid)=@_;
my $hashid="$udom:$unam:$courseid";	my $hashid="$udom:$unam:$courseid";

my ($result,$cached)=&is_cached(\%usectioncache,$hashid,300);	my ($result,$cached)=&is_cached(\%usectioncache,$hashid,'usection');
if (defined($cached)) { return $result; }	if (defined($cached)) { return $result; }
$courseid=~s/\_/\//g;	$courseid=~s/\_/\//g;
$courseid=~s/^(\w)/\/$1/;	$courseid=~s/^(\w)/\/$1/;
Line 899 sub usection {	Line 1027 sub usection {
if ($now>$end) { $notactive=1; }	if ($now>$end) { $notactive=1; }
}	}
unless ($notactive) {	unless ($notactive) {
return &do_cache(\%usectioncache,$hashid,$section);	return &do_cache(\%usectioncache,$hashid,$section,'usection');
}	}
}	}
}	}
return &do_cache(\%usectioncache,$hashid,'-1');	return &do_cache(\%usectioncache,$hashid,'-1','usection');
}	}

# ------------------------------------- Read an entry from a user's environment	# ------------------------------------- Read an entry from a user's environment
Line 2219 sub currentdump {	Line 2347 sub currentdump {
return if ($tmp[0] =~ /^(error:\|no_such_host)/);	return if ($tmp[0] =~ /^(error:\|no_such_host)/);
my %hash = @tmp;	my %hash = @tmp;
@tmp=();	@tmp=();
# Code ripped from lond, essentially. The only difference	%returnhash = %{&convert_dump_to_currentdump(\%hash)};
# here is the unescaping done by lonnet::dump(). Conceivably
# we might run in to problems with parameter names =~ /^v\./
while (my ($key,$value) = each(%hash)) {
my ($v,$symb,$param) = split(/:/,$key);
next if ($v eq 'version' \|\| $symb eq 'keys');
next if (exists($returnhash{$symb}) &&
exists($returnhash{$symb}->{$param}) &&
$returnhash{$symb}->{'v.'.$param} > $v);
$returnhash{$symb}->{$param}=$value;
$returnhash{$symb}->{'v.'.$param}=$v;
}
#
# Remove all of the keys in the hashes which keep track of
# the version of the parameter.
while (my ($symb,$param_hash) = each(%returnhash)) {
# use a foreach because we are going to delete from the hash.
foreach my $key (keys(%$param_hash)) {
delete($param_hash->{$key}) if ($key =~ /^v\./);
}
}
} else {	} else {
my @pairs=split(/\&/,$rep);	my @pairs=split(/\&/,$rep);
foreach (@pairs) {	foreach (@pairs) {
Line 2252 sub currentdump {	Line 2360 sub currentdump {
return %returnhash;	return %returnhash;
}	}

	sub convert_dump_to_currentdump{
	my %hash = %{shift()};
	my %returnhash;
	# Code ripped from lond, essentially. The only difference
	# here is the unescaping done by lonnet::dump(). Conceivably
	# we might run in to problems with parameter names =~ /^v\./
	while (my ($key,$value) = each(%hash)) {
	my ($v,$symb,$param) = split(/:/,$key);
	next if ($v eq 'version' \|\| $symb eq 'keys');
	next if (exists($returnhash{$symb}) &&
	exists($returnhash{$symb}->{$param}) &&
	$returnhash{$symb}->{'v.'.$param} > $v);
	$returnhash{$symb}->{$param}=$value;
	$returnhash{$symb}->{'v.'.$param}=$v;
	}
	#
	# Remove all of the keys in the hashes which keep track of
	# the version of the parameter.
	while (my ($symb,$param_hash) = each(%returnhash)) {
	# use a foreach because we are going to delete from the hash.
	foreach my $key (keys(%$param_hash)) {
	delete($param_hash->{$key}) if ($key =~ /^v\./);
	}
	}
	return \%returnhash;
	}

# --------------------------------------------------------------- put interface	# --------------------------------------------------------------- put interface

sub put {	sub put {
Line 2646 sub is_on_map {	Line 2781 sub is_on_map {
}	}
}	}

	# --------------------------------------------------------- Get symb from alias

	sub get_symb_from_alias {
	my $symb=shift;
	my ($map,$resid,$url)=&decode_symb($symb);
	# Already is a symb
	if ($url) { return $symb; }
	# Must be an alias
	my $aliassymb='';
	my %bighash;
	if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
	&GDBM_READER(),0640)) {
	my $rid=$bighash{'mapalias_'.$symb};
	if ($rid) {
	my ($mapid,$resid)=split(/\./,$rid);
	$aliassymb=&encode_symb($bighash{'map_id_'.$mapid},
	$resid,$bighash{'src_'.$rid});
	}
	untie %bighash;
	}
	return $aliassymb;
	}

# ----------------------------------------------------------------- Define Role	# ----------------------------------------------------------------- Define Role

sub definerole {	sub definerole {
Line 3300 sub condval {	Line 3458 sub condval {
sub devalidatecourseresdata {	sub devalidatecourseresdata {
my ($coursenum,$coursedomain)=@_;	my ($coursenum,$coursedomain)=@_;
my $hashid=$coursenum.':'.$coursedomain;	my $hashid=$coursenum.':'.$coursedomain;
delete $courseresdatacache{$hashid.'.time'};	&devalidate_cache(\%courseresdatacache,$hashid,'courseres');
}	}

# --------------------------------------------------- Course Resourcedata Query	# --------------------------------------------------- Course Resourcedata Query
Line 3309 sub courseresdata {	Line 3467 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(\%courseresdatacache,$hashid,300);	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(\%courseresdatacache,$hashid,$result);	&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(\%courseresdatacache,$hashid,$result);	&do_cache(\%courseresdatacache,$hashid,$result,'courseres');
}	}
}	}
foreach my $item (@which) {	foreach my $item (@which) {
Line 3364 sub EXT {	Line 3522 sub EXT {
#get real user name/domain, courseid and symb	#get real user name/domain, courseid and symb
my $courseid;	my $courseid;
my $publicuser;	my $publicuser;
	if ($symbparm) {
	$symbparm=&get_symb_from_alias($symbparm);
	}
if (!($uname && $udom)) {	if (!($uname && $udom)) {
(my $cursymb,$courseid,$udom,$uname,$publicuser)=	(my $cursymb,$courseid,$udom,$uname,$publicuser)=
&Apache::lonxml::whichuser($symbparm);	&Apache::lonxml::whichuser($symbparm);
Line 3449 sub EXT {	Line 3610 sub EXT {
} elsif ($realm eq 'request') {	} elsif ($realm eq 'request') {
# ------------------------------------------------------------- request.browser	# ------------------------------------------------------------- request.browser
if ($space eq 'browser') {	if ($space eq 'browser') {
return $ENV{'browser.'.$qualifier};	if ($qualifier eq 'textremote') {
	if (&mt('textual_remote_display') eq 'on') {
	return 1;
	} else {
	return 0;
	}
	} else {
	return $ENV{'browser.'.$qualifier};
	}
# ------------------------------------------------------------ request.filename	# ------------------------------------------------------------ request.filename
} else {	} else {
return $ENV{'request.'.$spacequalifierrest};	return $ENV{'request.'.$spacequalifierrest};
Line 3493 sub EXT {	Line 3662 sub EXT {

# ----------------------------------------------------------- first, check user	# ----------------------------------------------------------- first, check user
#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
#every thirty minutes
if (! &EXT_cache_status($udom,$uname)) {	if (! &EXT_cache_status($udom,$uname)) {
my %resourcedata=&get('resourcedata',	my $hashid="$udom:$uname";
[$courselevelr,$courselevelm,$courselevel],	my ($result,$cached)=&is_cached(\%userresdatacache,$hashid,
$udom,$uname);	'userres');
my ($tmp)=keys(%resourcedata);	if (!defined($cached)) {
	my %resourcedata=&get('resourcedata',
	[$courselevelr,$courselevelm,
	$courselevel],$udom,$uname);
	$result=\%resourcedata;
	&do_cache(\%userresdatacache,$hashid,$result,'userres');
	}
	my ($tmp)=keys(%$result);
if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {	if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {
if ($resourcedata{$courselevelr}) {	if ($$result{$courselevelr}) {
return $resourcedata{$courselevelr}; }	return $$result{$courselevelr}; }
if ($resourcedata{$courselevelm}) {	if ($$result{$courselevelm}) {
return $resourcedata{$courselevelm}; }	return $$result{$courselevelm}; }
if ($resourcedata{$courselevel}) {	if ($$result{$courselevel}) {
return $resourcedata{$courselevel}; }	return $$result{$courselevel}; }
} else {	} else {
if ($tmp!~/No such file/) {	if ($tmp!~/No such file/) {
&logthis("<font color=blue>WARNING:".	&logthis("<font color=blue>WARNING:".
Line 3621 sub add_prefix_and_part {	Line 3796 sub add_prefix_and_part {

sub metadata {	sub metadata {
my ($uri,$what,$liburi,$prefix,$depthcount)=@_;	my ($uri,$what,$liburi,$prefix,$depthcount)=@_;

$uri=&declutter($uri);	$uri=&declutter($uri);
# if it is a non metadata possible uri return quickly	# if it is a non metadata possible uri return quickly
if (($uri eq '') \|\| (($uri =~ m\|^/*adm/\|) && ($uri !~ m\|^adm/includes\|)) \|\|	if (($uri eq '') \|\| (($uri =~ m\|^/*adm/\|) && ($uri !~ m\|^adm/includes\|)) \|\|
($uri =~ m\|/$\|) \|\| ($uri =~ m\|/.meta$\|)) {	($uri =~ m\|/$\|) \|\| ($uri =~ m\|/.meta$\|) \|\| ($uri =~ /^~/) \|\|
	($uri =~ m\|home/[^/]+/public_html/\|)) {
return '';	return '';
}	}
my $filename=$uri;	my $filename=$uri;
Line 3635 sub metadata {	Line 3810 sub metadata {
# Look at timestamp of caching	# Look at timestamp of caching
# Everything is cached by the main uri, libraries are never directly cached	# Everything is cached by the main uri, libraries are never directly cached
#	#
unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600 && !defined($liburi)) {	if (!defined($liburi)) {
	my ($result,$cached)=&is_cached(\%metacache,$uri,'meta');
	if (defined($cached)) { return $result->{':'.$what}; }
	}
	{
#	#
# Is this a recursive call for a library?	# Is this a recursive call for a library?
#	#
	my %lcmetacache;
if ($liburi) {	if ($liburi) {
$liburi=&declutter($liburi);	$liburi=&declutter($liburi);
$filename=$liburi;	$filename=$liburi;
} else {	} else {
delete($metacache{$uri.':packages'});	&devalidate_cache(\%metacache,$uri,'meta');
}	}
my %metathesekeys=();	my %metathesekeys=();
unless ($filename=~/\.meta$/) { $filename.='.meta'; }	unless ($filename=~/\.meta$/) { $filename.='.meta'; }
Line 3662 sub metadata {	Line 3842 sub metadata {
if (defined($token->[2]->{'id'})) {	if (defined($token->[2]->{'id'})) {
$keyroot.='_'.$token->[2]->{'id'};	$keyroot.='_'.$token->[2]->{'id'};
}	}
if ($metacache{$uri.':packages'}) {	if ($lcmetacache{':packages'}) {
$metacache{$uri.':packages'}.=','.$package.$keyroot;	$lcmetacache{':packages'}.=','.$package.$keyroot;
} else {	} else {
$metacache{$uri.':packages'}=$package.$keyroot;	$lcmetacache{':packages'}=$package.$keyroot;
}	}
foreach (keys %packagetab) {	foreach (keys %packagetab) {
if ($_=~/^$package\&/) {	if ($_=~/^$package\&/) {
Line 3680 sub metadata {	Line 3860 sub metadata {
$value.=' [Part: '.$part.']';	$value.=' [Part: '.$part.']';
}	}
my $unikey='parameter'.$keyroot.'_'.$name;	my $unikey='parameter'.$keyroot.'_'.$name;
$metacache{$uri.':'.$unikey.'.part'}=$part;	$lcmetacache{':'.$unikey.'.part'}=$part;
$metathesekeys{$unikey}=1;	$metathesekeys{$unikey}=1;
unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {	unless (defined($lcmetacache{':'.$unikey.'.'.$subp})) {
$metacache{$uri.':'.$unikey.'.'.$subp}=$value;	$lcmetacache{':'.$unikey.'.'.$subp}=$value;
}	}
if (defined($metacache{$uri.':'.$unikey.'.default'})) {	if (defined($lcmetacache{':'.$unikey.'.default'})) {
$metacache{$uri.':'.$unikey}=	$lcmetacache{':'.$unikey}=
$metacache{$uri.':'.$unikey.'.default'};	$lcmetacache{':'.$unikey.'.default'};
}	}
}	}
}	}
Line 3730 sub metadata {	Line 3910 sub metadata {
}	}
$metathesekeys{$unikey}=1;	$metathesekeys{$unikey}=1;
foreach (@{$token->[3]}) {	foreach (@{$token->[3]}) {
$metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};	$lcmetacache{':'.$unikey.'.'.$_}=$token->[2]->{$_};
}	}
my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));	my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
my $default=$metacache{$uri.':'.$unikey.'.default'};	my $default=$lcmetacache{':'.$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
$metacache{$uri.':'.$unikey}=$default;	$lcmetacache{':'.$unikey}=$default;
} else {	} else {
# either something interesting inside the tag or default	# either something interesting inside the tag or default
# uninteresting	# uninteresting
$metacache{$uri.':'.$unikey}=$internaltext;	$lcmetacache{':'.$unikey}=$internaltext;
}	}
# end of not-a-package not-a-library import	# end of not-a-package not-a-library import
}	}
Line 3751 sub metadata {	Line 3931 sub metadata {
}	}
}	}
# are there custom rights to evaluate	# are there custom rights to evaluate
if ($metacache{$uri.':copyright'} eq 'custom') {	if ($lcmetacache{':copyright'} eq 'custom') {

#	#
# Importing a rights file here	# Importing a rights file here
#	#
unless ($depthcount) {	unless ($depthcount) {
my $location=$metacache{$uri.':customdistributionfile'};	my $location=$lcmetacache{':customdistributionfile'};
my $dir=$filename;	my $dir=$filename;
$dir=~s\|[^/]*$\|\|;	$dir=~s\|[^/]*$\|\|;
$location=&filelocation($dir,$location);	$location=&filelocation($dir,$location);
Line 3768 sub metadata {	Line 3948 sub metadata {
}	}
}	}
}	}
$metacache{$uri.':keys'}=join(',',keys %metathesekeys);	$lcmetacache{':keys'}=join(',',keys %metathesekeys);
&metadata_generate_part0(\%metathesekeys,\%metacache,$uri);	&metadata_generate_part0(\%metathesekeys,\%lcmetacache,$uri);
$metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys);	$lcmetacache{':allpossiblekeys'}=join(',',keys %metathesekeys);
$metacache{$uri.':cachedtimestamp'}=time;	&do_cache(\%metacache,$uri,\%lcmetacache,'meta');
# this is the end of "was not already recently cached	# this is the end of "was not already recently cached
}	}
return $metacache{$uri.':'.$what};	return $metacache{$uri}->{':'.$what};
}	}

sub metadata_generate_part0 {	sub metadata_generate_part0 {
Line 3782 sub metadata_generate_part0 {	Line 3962 sub metadata_generate_part0 {
my %allnames;	my %allnames;
foreach my $metakey (sort keys %$metadata) {	foreach my $metakey (sort keys %$metadata) {
if ($metakey=~/^parameter\_(.*)/) {	if ($metakey=~/^parameter\_(.*)/) {
my $part=$$metacache{$uri.':'.$metakey.'.part'};	my $part=$$metacache{':'.$metakey.'.part'};
my $name=$$metacache{$uri.':'.$metakey.'.name'};	my $name=$$metacache{':'.$metakey.'.name'};
if (! exists($$metadata{'parameter_0_'.$name.'.name'})) {	if (! exists($$metadata{'parameter_0_'.$name.'.name'})) {
$allnames{$name}=$part;	$allnames{$name}=$part;
}	}
Line 3791 sub metadata_generate_part0 {	Line 3971 sub metadata_generate_part0 {
}	}
foreach my $name (keys(%allnames)) {	foreach my $name (keys(%allnames)) {
$$metadata{"parameter_0_$name"}=1;	$$metadata{"parameter_0_$name"}=1;
my $key="$uri:parameter_0_$name";	my $key=":parameter_0_$name";
$$metacache{"$key.part"}='0';	$$metacache{"$key.part"}='0';
$$metacache{"$key.name"}=$name;	$$metacache{"$key.name"}=$name;
$$metacache{"$key.type"}=$$metacache{$uri.':parameter_'.	$$metacache{"$key.type"}=$$metacache{':parameter_'.
$allnames{$name}.'_'.$name.	$allnames{$name}.'_'.$name.
'.type'};	'.type'};
my $olddis=$$metacache{$uri.':parameter_'.$allnames{$name}.'_'.$name.	my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name.
'.display'};	'.display'};
my $expr='\\[Part: '.$allnames{$name}.'\\]';	my $expr='\\[Part: '.$allnames{$name}.'\\]';
$olddis=~s/$expr/\[Part: 0\]/;	$olddis=~s/$expr/\[Part: 0\]/;
Line 3814 sub gettitle {	Line 3994 sub gettitle {
unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; }	unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; }
return &metadata($urlsymb,'title');	return &metadata($urlsymb,'title');
}	}
if ($titlecache{$symb}) {	my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);
if (time < ($titlecache{$symb}[1] + 600)) {	if (defined($cached)) { return $result; }
return $titlecache{$symb}[0];
} else {
delete($titlecache{$symb});
}
}
my ($map,$resid,$url)=&decode_symb($symb);	my ($map,$resid,$url)=&decode_symb($symb);
my $title='';	my $title='';
my %bighash;	my %bighash;
Line 3832 sub gettitle {	Line 4007 sub gettitle {
}	}
$title=~s/\&colon\;/\:/gs;	$title=~s/\&colon\;/\:/gs;
if ($title) {	if ($title) {
$titlecache{$symb}=[$title,time];	return &do_cache(\%titlecache,$symb,$title,'title');
return $title;
} else {	} else {
return &metadata($urlsymb,'title');	return &metadata($urlsymb,'title');
}	}
Line 3912 sub symbclean {	Line 4086 sub symbclean {

# ---------------------------------------------- Split symb to find map and url	# ---------------------------------------------- Split symb to find map and url

	sub encode_symb {
	my ($map,$resid,$url)=@_;
	return &symbclean(&declutter($map).'___'.$resid.'___'.&declutter($url));
	}

sub decode_symb {	sub decode_symb {
my ($map,$resid,$url)=split(/\_\_\_/,shift);	my ($map,$resid,$url)=split(/\_\_\_/,shift);
return (&fixversion($map),$resid,&fixversion($url));	return (&fixversion($map),$resid,&fixversion($url));
Line 4236 sub mod_perl_version {	Line 4415 sub mod_perl_version {

sub goodbye {	sub goodbye {
&logthis("Starting Shut down");	&logthis("Starting Shut down");
	#not converted to using infrastruture
	&logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache)));
	&logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache)));
	&logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
	#converted
	&logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache)));
	&logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache)));
	#1.1 only
	&logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache)));
	&logthis(sprintf("%-20s is %s",'%usectioncache',scalar(%usectioncache)));
&flushcourselogs();	&flushcourselogs();
&logthis("Shutting down");	&logthis("Shutting down");
return DONE;	return DONE;

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

Removed from v.1.417
changed lines
	Added in v.1.430