version 1.441, 2003/11/04 18:44:17
|
version 1.444, 2003/11/10 21:50:21
|
Line 823 sub devalidate_cache {
|
Line 823 sub devalidate_cache {
|
my ($cache,$id,$name) = @_; |
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"; |
my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db"; |
open(DB,"$filename.lock"); |
open(DB,"$filename.lock"); |
flock(DB,LOCK_EX); |
flock(DB,LOCK_EX); |
my %hash; |
my %hash; |
if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) { |
if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) { |
delete($hash{$id}); |
eval <<'EVALBLOCK'; |
delete($hash{$id.'.time'}); |
delete($hash{$id}); |
|
delete($hash{$id.'.time'}); |
|
EVALBLOCK |
|
if ($@) { |
|
&logthis("<font color='red'>devalidate_cache blew up :$@:$name</font>"); |
|
unlink($filename); |
|
} |
} else { |
} else { |
&logthis("Unable to tie hash (devalidate cache): $name"); |
if (-e $filename) { |
|
&logthis("Unable to tie hash (devalidate cache): $name"); |
|
unlink($filename); |
|
} |
} |
} |
untie(%hash); |
untie(%hash); |
flock(DB,LOCK_UN); |
flock(DB,LOCK_UN); |
Line 867 sub do_cache {
|
Line 876 sub do_cache {
|
$$cache{$id}; |
$$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 { |
sub save_cache_item { |
my ($cache,$name,$id)=@_; |
my ($cache,$name,$id)=@_; |
my $starttime=&Time::HiRes::time(); |
my $starttime=&Time::HiRes::time(); |
# &logthis("Saving :$name:$id"); |
# &logthis("Saving :$name:$id"); |
my %hash; |
my %hash; |
my $filename=$perlvar{'lonDaemons'}.'/tmp/'.$name.".db"; |
my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db"; |
open(DB,"$filename.lock"); |
open(DB,"$filename.lock"); |
flock(DB,LOCK_EX); |
flock(DB,LOCK_EX); |
if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) { |
if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) { |
$hash{$id.'.time'}=$$cache{$id.'.time'}; |
eval <<'EVALBLOCK'; |
$hash{$id}=freeze({'item'=>$$cache{$id}}); |
$hash{$id.'.time'}=$$cache{$id.'.time'}; |
|
$hash{$id}=freeze({'item'=>$$cache{$id}}); |
|
EVALBLOCK |
|
if ($@) { |
|
&logthis("<font color='red'>save_cache blew up :$@:$name</font>"); |
|
unlink($filename); |
|
} |
} else { |
} else { |
&logthis("Unable to tie hash (save cache item): $name"); |
if (-e $filename) { |
|
&logthis("Unable to tie hash (save cache item): $name"); |
|
unlink($filename); |
|
} |
} |
} |
untie(%hash); |
untie(%hash); |
flock(DB,LOCK_UN); |
flock(DB,LOCK_UN); |
Line 942 sub load_cache_item {
|
Line 910 sub load_cache_item {
|
my $starttime=&Time::HiRes::time(); |
my $starttime=&Time::HiRes::time(); |
# &logthis("Before Loading $name for $id size is ".scalar(%$cache)); |
# &logthis("Before Loading $name for $id size is ".scalar(%$cache)); |
my %hash; |
my %hash; |
my $filename=$perlvar{'lonDaemons'}.'/tmp/'.$name.".db"; |
my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db"; |
open(DB,"$filename.lock"); |
open(DB,"$filename.lock"); |
flock(DB,LOCK_SH); |
flock(DB,LOCK_SH); |
if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) { |
if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) { |
if (!%$cache) { |
eval <<'EVALBLOCK'; |
my $count; |
if (!%$cache) { |
while (my ($key,$value)=each(%hash)) { |
my $count; |
$count++; |
while (my ($key,$value)=each(%hash)) { |
if ($key =~ /\.time$/) { |
$count++; |
$$cache{$key}=$value; |
if ($key =~ /\.time$/) { |
} else { |
$$cache{$key}=$value; |
my $hashref=thaw($value); |
} else { |
$$cache{$key}=$hashref->{'item'}; |
my $hashref=thaw($value); |
|
$$cache{$key}=$hashref->{'item'}; |
|
} |
} |
} |
} |
|
# &logthis("Initial load: $count"); |
# &logthis("Initial load: $count"); |
} else { |
} else { |
my $hashref=thaw($hash{$id}); |
my $hashref=thaw($hash{$id}); |
$$cache{$id}=$hashref->{'item'}; |
$$cache{$id}=$hashref->{'item'}; |
$$cache{$id.'.time'}=$hash{$id.'.time'}; |
$$cache{$id.'.time'}=$hash{$id.'.time'}; |
|
} |
|
EVALBLOCK |
|
if ($@) { |
|
&logthis("<font color='red'>load_cache blew up :$@:$name</font>"); |
|
unlink($filename); |
|
} |
|
} else { |
|
if (-e $filename) { |
|
&logthis("Unable to tie hash (load cache item): $name"); |
|
unlink($filename); |
} |
} |
} else { |
|
&logthis("Unable to tie hash (load cache item): $name"); |
|
} |
} |
untie(%hash); |
untie(%hash); |
flock(DB,LOCK_UN); |
flock(DB,LOCK_UN); |
Line 4092 sub fixversion {
|
Line 4069 sub fixversion {
|
&GDBM_READER(),0640)) { |
&GDBM_READER(),0640)) { |
if ($bighash{'version_'.$uri}) { |
if ($bighash{'version_'.$uri}) { |
my $version=$bighash{'version_'.$uri}; |
my $version=$bighash{'version_'.$uri}; |
unless ($version eq 'mostrecent') { |
unless (($version eq 'mostrecent') || |
|
($version==&getversion($uri))) { |
$uri=~s/\.(\w+)$/\.$version\.$1/; |
$uri=~s/\.(\w+)$/\.$version\.$1/; |
} |
} |
} |
} |
Line 4205 sub numval {
|
Line 4183 sub numval {
|
} |
} |
|
|
sub latest_rnd_algorithm_id { |
sub latest_rnd_algorithm_id { |
return '64bit'; |
return '64bit2'; |
} |
} |
|
|
sub rndseed { |
sub rndseed { |
Line 4222 sub rndseed {
|
Line 4200 sub rndseed {
|
my $CODE=$ENV{'scantron.CODE'}; |
my $CODE=$ENV{'scantron.CODE'}; |
if (defined($CODE)) { |
if (defined($CODE)) { |
&rndseed_CODE_64bit($symb,$courseid,$domain,$username); |
&rndseed_CODE_64bit($symb,$courseid,$domain,$username); |
|
} elsif ($which eq '64bit2') { |
|
return &rndseed_64bit2($symb,$courseid,$domain,$username); |
} elsif ($which eq '64bit') { |
} elsif ($which eq '64bit') { |
return &rndseed_64bit($symb,$courseid,$domain,$username); |
return &rndseed_64bit($symb,$courseid,$domain,$username); |
} |
} |
Line 4265 sub rndseed_64bit {
|
Line 4245 sub rndseed_64bit {
|
} |
} |
} |
} |
|
|
|
sub rndseed_64bit2 { |
|
my ($symb,$courseid,$domain,$username)=@_; |
|
{ |
|
use integer; |
|
# strings need to be an even # of cahracters long, it it is odd the |
|
# last characters gets thrown away |
|
my $symbchck=unpack("%32S*",$symb.' ') << 21; |
|
my $symbseed=numval($symb) << 10; |
|
my $namechck=unpack("%32S*",$username.' '); |
|
|
|
my $nameseed=numval($username) << 21; |
|
my $domainseed=unpack("%32S*",$domain.' ') << 10; |
|
my $courseseed=unpack("%32S*",$courseid.' '); |
|
|
|
my $num1=$symbchck+$symbseed+$namechck; |
|
my $num2=$nameseed+$domainseed+$courseseed; |
|
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck"); |
|
#&Apache::lonxml::debug("rndseed :$num:$symb"); |
|
return "$num1,$num2"; |
|
} |
|
} |
|
|
sub rndseed_CODE_64bit { |
sub rndseed_CODE_64bit { |
my ($symb,$courseid,$domain,$username)=@_; |
my ($symb,$courseid,$domain,$username)=@_; |
{ |
{ |
use integer; |
use integer; |
my $symbchck=unpack("%32S*",$symb) << 16; |
my $symbchck=unpack("%32S*",$symb.' ') << 16; |
my $symbseed=numval($symb); |
my $symbseed=numval($symb); |
my $CODEseed=numval($ENV{'scantron.CODE'}) << 16; |
my $CODEseed=numval($ENV{'scantron.CODE'}) << 16; |
my $courseseed=unpack("%32S*",$courseid); |
my $courseseed=unpack("%32S*",$courseid.' '); |
my $num1=$symbseed+$CODEseed; |
my $num1=$symbseed+$CODEseed; |
my $num2=$courseseed+$symbchck; |
my $num2=$courseseed+$symbchck; |
#&Apache::lonxml::debug("$symbseed:$CODEseed|$courseseed:$symbchck"); |
#&Apache::lonxml::debug("$symbseed:$CODEseed|$courseseed:$symbchck"); |
Line 4416 sub mod_perl_version {
|
Line 4418 sub mod_perl_version {
|
|
|
sub correct_line_ends { |
sub correct_line_ends { |
my ($result)=@_; |
my ($result)=@_; |
&logthis("Wha $result"); |
|
$$result =~s/\r\n/\n/mg; |
$$result =~s/\r\n/\n/mg; |
$$result =~s/\r/\n/mg; |
$$result =~s/\r/\n/mg; |
} |
} |
Line 4424 sub correct_line_ends {
|
Line 4425 sub correct_line_ends {
|
|
|
sub goodbye { |
sub goodbye { |
&logthis("Starting Shut down"); |
&logthis("Starting Shut down"); |
#not converted to using infrastruture |
#not converted to using infrastruture and probably shouldn't be |
&logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache))); |
|
&logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache))); |
&logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache))); |
&logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); |
|
#converted |
#converted |
|
&logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache))); |
|
&logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache))); |
&logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache))); |
&logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache))); |
&logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache))); |
&logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache))); |
#1.1 only |
#1.1 only |