|
version 1.417, 2003/09/19 16:53:35
|
version 1.429, 2003/10/07 07:24:51
|
|
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 3493 sub EXT {
|
Line 3654 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 3788 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 3802 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 3834 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 3852 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 3902 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 3923 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 3940 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 3954 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 3963 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 3986 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 3999 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 4078 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 4407 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; |
![[BACK]](/icons/back.gif){kind=icon}
Return to lonnet.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / lonnet / perl