--- loncom/lonnet/perl/lonnet.pm 2003/11/01 18:34:49 1.440
+++ loncom/lonnet/perl/lonnet.pm 2003/11/11 20:10:32 1.447
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.440 2003/11/01 18:34:49 www Exp $
+# $Id: lonnet.pm,v 1.447 2003/11/11 20:10:32 www Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -247,10 +247,10 @@ sub transfer_profile_to_env {
}
}
}
+ $ENV{'user.environment'} = "$lonidsdir/$handle.id";
foreach my $expired_key (keys(%Remove)) {
&delenv($expired_key);
}
- $ENV{'user.environment'} = "$lonidsdir/$handle.id";
}
# ---------------------------------------------------------- Append Environment
@@ -823,15 +823,24 @@ sub devalidate_cache {
my ($cache,$id,$name) = @_;
delete $$cache{$id.'.time'};
delete $$cache{$id};
- my $filename=$perlvar{'lonDaemons'}.'/tmp/'.$name.".db";
+ my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$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'});
+ eval <<'EVALBLOCK';
+ delete($hash{$id});
+ delete($hash{$id.'.time'});
+EVALBLOCK
+ if ($@) {
+ &logthis("<font color='red'>devalidate_cache blew up :$@:$name</font>");
+ unlink($filename);
+ }
} else {
- &logthis("Unable to tie hash (devalidate cache): $name");
+ if (-e $filename) {
+ &logthis("Unable to tie hash (devalidate cache): $name");
+ unlink($filename);
+ }
}
untie(%hash);
flock(DB,LOCK_UN);
@@ -867,69 +876,28 @@ sub do_cache {
$$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");
+# &logthis("Saving :$name:$id");
my %hash;
- my $filename=$perlvar{'lonDaemons'}.'/tmp/'.$name.".db";
+ my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$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}});
+ eval <<'EVALBLOCK';
+ $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 {
- &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);
flock(DB,LOCK_UN);
@@ -942,29 +910,38 @@ sub load_cache_item {
my $starttime=&Time::HiRes::time();
# &logthis("Before Loading $name for $id size is ".scalar(%$cache));
my %hash;
- my $filename=$perlvar{'lonDaemons'}.'/tmp/'.$name.".db";
+ my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$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'};
+ eval <<'EVALBLOCK';
+ 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 {
+ my $hashref=thaw($hash{$id});
+ $$cache{$id}=$hashref->{'item'};
+ $$cache{$id.'.time'}=$hash{$id.'.time'};
+ }
+EVALBLOCK
+ if ($@) {
+ &logthis("<font color='red'>load_cache blew up :$@:$name</font>");
+ unlink($filename);
+ }
} else {
- &logthis("Unable to tie hash (load cache item): $name");
+ if (-e $filename) {
+ &logthis("Unable to tie hash (load cache item): $name ($!)");
+ unlink($filename);
+ }
}
untie(%hash);
flock(DB,LOCK_UN);
@@ -1090,7 +1067,7 @@ sub repcopy {
&logthis("Subscribe returned $remoteurl: $filename");
return HTTP_SERVICE_UNAVAILABLE;
} elsif ($remoteurl eq 'not_found') {
- &logthis("Subscribe returned not_found: $filename");
+ #&logthis("Subscribe returned not_found: $filename");
return HTTP_NOT_FOUND;
} elsif ($remoteurl =~ /^rejected by/) {
&logthis("Subscribe returned $remoteurl: $filename");
@@ -1993,6 +1970,10 @@ sub store {
}
}
if (!$home) { $home=$ENV{'user.home'}; }
+
+ $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};
+ $$storehash{'host'}=$perlvar{'lonHostID'};
+
my $namevalue='';
foreach (keys %$storehash) {
$namevalue.=escape($_).'='.escape($$storehash{$_}).'&';
@@ -2026,6 +2007,9 @@ sub cstore {
}
if (!$home) { $home=$ENV{'user.home'}; }
+ $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};
+ $$storehash{'host'}=$perlvar{'lonHostID'};
+
my $namevalue='';
foreach (keys %$storehash) {
$namevalue.=escape($_).'='.escape($$storehash{$_}).'&';
@@ -4092,7 +4076,8 @@ sub fixversion {
&GDBM_READER(),0640)) {
if ($bighash{'version_'.$uri}) {
my $version=$bighash{'version_'.$uri};
- unless ($version eq 'mostrecent') {
+ unless (($version eq 'mostrecent') ||
+ ($version==&getversion($uri))) {
$uri=~s/\.(\w+)$/\.$version\.$1/;
}
}
@@ -4205,7 +4190,7 @@ sub numval {
}
sub latest_rnd_algorithm_id {
- return '64bit';
+ return '64bit2';
}
sub rndseed {
@@ -4222,6 +4207,8 @@ sub rndseed {
my $CODE=$ENV{'scantron.CODE'};
if (defined($CODE)) {
&rndseed_CODE_64bit($symb,$courseid,$domain,$username);
+ } elsif ($which eq '64bit2') {
+ return &rndseed_64bit2($symb,$courseid,$domain,$username);
} elsif ($which eq '64bit') {
return &rndseed_64bit($symb,$courseid,$domain,$username);
}
@@ -4265,14 +4252,36 @@ 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 {
my ($symb,$courseid,$domain,$username)=@_;
{
use integer;
- my $symbchck=unpack("%32S*",$symb) << 16;
+ my $symbchck=unpack("%32S*",$symb.' ') << 16;
my $symbseed=numval($symb);
my $CODEseed=numval($ENV{'scantron.CODE'}) << 16;
- my $courseseed=unpack("%32S*",$courseid);
+ my $courseseed=unpack("%32S*",$courseid.' ');
my $num1=$symbseed+$CODEseed;
my $num2=$courseseed+$symbchck;
#&Apache::lonxml::debug("$symbseed:$CODEseed|$courseseed:$symbchck");
@@ -4416,7 +4425,6 @@ sub mod_perl_version {
sub correct_line_ends {
my ($result)=@_;
- &logthis("Wha $result");
$$result =~s/\r\n/\n/mg;
$$result =~s/\r/\n/mg;
}
@@ -4424,11 +4432,11 @@ sub correct_line_ends {
sub goodbye {
&logthis("Starting Shut down");
-#not converted to using infrastruture
- &logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache)));
+#not converted to using infrastruture and probably shouldn't be
&logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache)));
- &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
#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",'%courseresdatacache',scalar(%courseresdatacache)));
#1.1 only