version 1.427, 2003/10/06 20:38:25
|
version 1.428, 2003/10/07 07:20:05
|
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); |
use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw); |
use Time::HiRes(); |
use Time::HiRes(); |
my $readit; |
my $readit; |
|
|
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,$name,$time) = @_; |
my ($cache,$id,$name,$time) = @_; |
if (!$time) { $time=300; } |
if (!$time) { $time=300; } |
if (!exists($$cache{$id.'.time'})) { |
if (!exists($$cache{$id.'.time'})) { |
&load_cache($cache,$name); |
&load_cache_item($cache,$name,$id); |
} |
} |
if (!exists($$cache{$id.'.time'})) { |
if (!exists($$cache{$id.'.time'})) { |
# &logthis("Didn't find $id"); |
# &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) { |
# &logthis("Devailidating $id"); |
# &logthis("Devailidating $id - ".time-($$cache{$id.'.time'})); |
&devalidate_cache($cache,$id); |
&devalidate_cache($cache,$id,$name); |
return (undef,undef); |
return (undef,undef); |
} |
} |
} |
} |
Line 877 sub do_cache {
|
Line 890 sub do_cache {
|
my ($cache,$id,$value,$name) = @_; |
my ($cache,$id,$value,$name) = @_; |
$$cache{$id.'.time'}=time; |
$$cache{$id.'.time'}=time; |
$$cache{$id}=$value; |
$$cache{$id}=$value; |
&save_cache($cache,$name); |
# &logthis("Caching $id as :$value:"); |
|
&save_cache_item($cache,$name,$id); |
# do_cache implictly return the set value |
# do_cache implictly return the set value |
$$cache{$id}; |
$$cache{$id}; |
} |
} |
|
|
sub save_cache { |
sub save_cache { |
my ($cache,$name)=@_; |
my ($cache,$name)=@_; |
# my $starttime=&Time::HiRes::time(); |
my $starttime=&Time::HiRes::time(); |
# &logthis("Saving :$name:"); |
# &logthis("Saving :$name:"); |
eval lock_store($cache,$perlvar{'lonDaemons'}.'/tmp/'.$name.".storable"); |
eval lock_store($cache,$perlvar{'lonDaemons'}.'/tmp/'.$name.".storable"); |
if ($@) { &logthis("lock_store threw a die ".$@); } |
if ($@) { &logthis("lock_store threw a die ".$@); } |
Line 893 sub save_cache {
|
Line 907 sub save_cache {
|
|
|
sub load_cache { |
sub load_cache { |
my ($cache,$name)=@_; |
my ($cache,$name)=@_; |
# my $starttime=&Time::HiRes::time(); |
my $starttime=&Time::HiRes::time(); |
# &logthis("Before Loading $name size is ".scalar(%$cache)); |
# &logthis("Before Loading $name size is ".scalar(%$cache)); |
my $tmpcache; |
my $tmpcache; |
eval { |
eval { |
Line 932 sub load_cache {
|
Line 946 sub load_cache {
|
# &logthis("load_cache took ".(&Time::HiRes::time()-$starttime)); |
# &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"; |
Line 3390 sub condval {
|
Line 3460 sub condval {
|
sub devalidatecourseresdata { |
sub devalidatecourseresdata { |
my ($coursenum,$coursedomain)=@_; |
my ($coursenum,$coursedomain)=@_; |
my $hashid=$coursenum.':'.$coursedomain; |
my $hashid=$coursenum.':'.$coursedomain; |
&devalidate_cache(\%courseresdatacache,$hashid); |
&devalidate_cache(\%courseresdatacache,$hashid,'courseres'); |
} |
} |
|
|
# --------------------------------------------------- Course Resourcedata Query |
# --------------------------------------------------- Course Resourcedata Query |
Line 3734 sub metadata {
|
Line 3804 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 3761 sub metadata {
|
Line 3836 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 3779 sub metadata {
|
Line 3854 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 3829 sub metadata {
|
Line 3904 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 3850 sub metadata {
|
Line 3925 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 3867 sub metadata {
|
Line 3942 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 3881 sub metadata_generate_part0 {
|
Line 3956 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 3890 sub metadata_generate_part0 {
|
Line 3965 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\]/; |