--- loncom/lonnet/perl/lonnet.pm 2003/10/30 20:22:00 1.436 +++ 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.436 2003/10/30 20:22:00 albertel Exp $ +# $Id: lonnet.pm,v 1.447 2003/11/11 20:10:32 www Exp $ # # Copyright Michigan State University Board of Trustees # @@ -35,7 +35,7 @@ use LWP::UserAgent(); use HTTP::Headers; use vars qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom - %libserv %pr %prp %metacache %packagetab %titlecache + %libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache %courselogs %accesshash %userrolehash $processmarker $dumpcount %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache %userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def @@ -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 @@ -367,7 +367,7 @@ sub userload { while ($filename=readdir(LONIDS)) { if ($filename eq '.' || $filename eq '..') {next;} my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9]; - if ($curtime-$mtime < 3600) { $numusers++; } + if ($curtime-$mtime < 1800) { $numusers++; } } closedir(LONIDS); } @@ -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("devalidate_cache blew up :$@:$name"); + 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("save_cache blew up :$@:$name"); + 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("load_cache blew up :$@:$name"); + 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); @@ -1042,6 +1019,8 @@ sub getversion { sub currentversion { my $fname=shift; + my ($result,$cached)=&is_cached(\%resversioncache,$fname,'resversion',600); + if (defined($cached)) { return $result; } my $author=$fname; $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; my ($udom,$uname)=split(/\//,$author); @@ -1053,7 +1032,7 @@ sub currentversion { if (($answer eq 'con_lost') || ($answer eq 'rejected')) { return -1; } - return $answer; + return &do_cache(\%resversioncache,$fname,$answer,'resversion'); } # ----------------------------- Subscribe to a resource, return URL if possible @@ -1088,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"); @@ -1991,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{$_}).'&'; @@ -2024,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{$_}).'&'; @@ -2449,7 +2435,7 @@ sub customaccess { sub allowed { my ($priv,$uri)=@_; - + $uri=&deversion($uri); my $orguri=$uri; $uri=&declutter($uri); @@ -3993,13 +3979,13 @@ sub gettitle { sub symblist { my ($mapname,%newhash)=@_; - $mapname=declutter($mapname); + $mapname=&deversion(&declutter($mapname)); my %hash; if (($ENV{'request.course.fn'}) && (%newhash)) { if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', &GDBM_WRCREAT(),0640)) { foreach (keys %newhash) { - $hash{declutter($_)}=$mapname.'___'.$newhash{$_}; + $hash{declutter($_)}=$mapname.'___'.&deversion($newhash{$_}); } if (untie(%hash)) { return 'ok'; @@ -4013,14 +3999,16 @@ sub symblist { sub symbverify { my ($symb,$thisfn)=@_; - $thisfn=&symbclean(&declutter($thisfn)); + $thisfn=&declutter($thisfn); # direct jump to resource in page or to a sequence - will construct own symbs if ($thisfn=~/\.(page|sequence)$/) { return 1; } # check URL part my ($map,$resid,$url)=&decode_symb($symb); + unless ($url eq $thisfn) { return 0; } $symb=&symbclean($symb); + $thisfn=&deversion($thisfn); my %bighash; my $okay=0; @@ -4078,17 +4066,31 @@ sub fixversion { if ($fn=~/^(adm|uploaded|public)/) { return $fn; } my %bighash; my $uri=&clutter($fn); + my $key=$ENV{'request.course.id'}.'_'.$uri; +# is this cached? + my ($result,$cached)=&is_cached(\%courseresversioncache,$key, + 'courseresversion',600); + if (defined($cached)) { return $result; } +# unfortunately not cached, or expired if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db', - &GDBM_READER(),0640)) { - if ($bighash{'version_'.$uri}) { - my $version=$bighash{'version_'.$uri}; - unless ($version eq 'mostrecent') { - $uri=~s/\.(\w+)$/\.$version\.$1/; - } - } - untie %bighash; - } - return &declutter($uri); + &GDBM_READER(),0640)) { + if ($bighash{'version_'.$uri}) { + my $version=$bighash{'version_'.$uri}; + unless (($version eq 'mostrecent') || + ($version==&getversion($uri))) { + $uri=~s/\.(\w+)$/\.$version\.$1/; + } + } + untie %bighash; + } + return &do_cache + (\%courseresversioncache,$key,&declutter($uri),'courseresversion'); +} + +sub deversion { + my $url=shift; + $url=~s/\.\d+\.(\w+)$/\.$1/; + return $url; } # ------------------------------------------------------ Return symb list entry @@ -4188,7 +4190,7 @@ sub numval { } sub latest_rnd_algorithm_id { - return '64bit'; + return '64bit2'; } sub rndseed { @@ -4205,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); } @@ -4248,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"); @@ -4399,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; } @@ -4407,16 +4432,18 @@ 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 &logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache))); &logthis(sprintf("%-20s is %s",'%usectioncache',scalar(%usectioncache))); + &logthis(sprintf("%-20s is %s",'%courseresversioncache',scalar(%courseresversioncache))); + &logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache))); &flushcourselogs(); &logthis("Shutting down"); return DONE;