--- loncom/lonnet/perl/lonnet.pm 2003/10/30 20:22:00 1.436 +++ loncom/lonnet/perl/lonnet.pm 2003/12/05 00:28:32 1.454 @@ -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.454 2003/12/05 00:28:32 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -30,12 +30,11 @@ package Apache::lonnet; use strict; -use Apache::File; 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 @@ -52,12 +51,35 @@ use Storable qw(lock_store lock_nstore l use Time::HiRes(); my $readit; +=pod + +=head1 Package Variables + +These are largely undocumented, so if you decipher one please note it here. + +=over 4 + +=item $processmarker + +Contains the time this process was started and this servers host id. + +=item $dumpcount + +Counts the number of times a message log flush has been attempted (regardless +of success) by this process. Used as part of the filename when messages are +delayed. + +=back + +=cut + + # --------------------------------------------------------------------- Logging sub logtouch { my $execdir=$perlvar{'lonDaemons'}; - unless (-e "$execdir/logs/lonnet.log") { - my $fh=Apache::File->new(">>$execdir/logs/lonnet.log"); + unless (-e "$execdir/logs/lonnet.log") { + open(my $fh,">>$execdir/logs/lonnet.log"); close $fh; } my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3]; @@ -69,8 +91,10 @@ sub logthis { my $execdir=$perlvar{'lonDaemons'}; my $now=time; my $local=localtime($now); - my $fh=Apache::File->new(">>$execdir/logs/lonnet.log"); - print $fh "$local ($$): $message\n"; + if (open(my $fh,">>$execdir/logs/lonnet.log")) { + print $fh "$local ($$): $message\n"; + close($fh); + } return 1; } @@ -79,8 +103,10 @@ sub logperm { my $execdir=$perlvar{'lonDaemons'}; my $now=time; my $local=localtime($now); - my $fh=Apache::File->new(">>$execdir/logs/lonnet.perm.log"); - print $fh "$now:$message:$local\n"; + if (open(my $fh,">>$execdir/logs/lonnet.perm.log")) { + print $fh "$now:$message:$local\n"; + close($fh); + } return 1; } @@ -132,7 +158,7 @@ sub reconlonc { my $peerfile=shift; &logthis("Trying to reconnect for $peerfile"); my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; - if (my $fh=Apache::File->new("$loncfile")) { + if (open(my $fh,"<$loncfile")) { my $loncpid=<$fh>; chomp($loncpid); if (kill 0 => $loncpid) { @@ -180,18 +206,20 @@ sub critical { "$perlvar{'lonSockDir'}/delayed/$now.$dumpcount.$$.$middlename.$server"; $dumpcount++; { - my $dfh; - if ($dfh=Apache::File->new(">$dfilename")) { - print $dfh "$cmd\n"; - } + my $dfh; + if (open($dfh,">$dfilename")) { + print $dfh "$cmd\n"; + close($dfh); + } } sleep 2; my $wcmd=''; { - my $dfh; - if ($dfh=Apache::File->new("$dfilename")) { - $wcmd=<$dfh>; - } + my $dfh; + if (open($dfh,"<$dfilename")) { + $wcmd=<$dfh>; + close($dfh); + } } chomp($wcmd); if ($wcmd eq $cmd) { @@ -230,10 +258,10 @@ sub transfer_profile_to_env { my ($lonidsdir,$handle)=@_; my @profile; { - my $idf=Apache::File->new("$lonidsdir/$handle.id"); + open(my $idf,"$lonidsdir/$handle.id"); flock($idf,LOCK_SH); @profile=<$idf>; - $idf->close(); + close($idf); } my $envi; my %Remove; @@ -247,10 +275,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 @@ -269,47 +297,47 @@ sub appenv { } my $lockfh; - unless ($lockfh=Apache::File->new("$ENV{'user.environment'}")) { - return 'error: '.$!; + unless (open($lockfh,"$ENV{'user.environment'}")) { + return 'error: '.$!; } unless (flock($lockfh,LOCK_EX)) { &logthis("WARNING: ". 'Could not obtain exclusive lock in appenv: '.$!); - $lockfh->close(); + close($lockfh); return 'error: '.$!; } my @oldenv; { - my $fh; - unless ($fh=Apache::File->new("$ENV{'user.environment'}")) { - return 'error: '.$!; - } - @oldenv=<$fh>; - $fh->close(); + my $fh; + unless (open($fh,"$ENV{'user.environment'}")) { + return 'error: '.$!; + } + @oldenv=<$fh>; + close($fh); } for (my $i=0; $i<=$#oldenv; $i++) { chomp($oldenv[$i]); if ($oldenv[$i] ne '') { - my ($name,$value)=split(/=/,$oldenv[$i]); - unless (defined($newenv{$name})) { - $newenv{$name}=$value; - } + my ($name,$value)=split(/=/,$oldenv[$i]); + unless (defined($newenv{$name})) { + $newenv{$name}=$value; + } } } { - my $fh; - unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) { - return 'error'; - } - my $newname; - foreach $newname (keys %newenv) { - print $fh "$newname=$newenv{$newname}\n"; - } - $fh->close(); + my $fh; + unless (open($fh,">$ENV{'user.environment'}")) { + return 'error'; + } + my $newname; + foreach $newname (keys %newenv) { + print $fh "$newname=$newenv{$newname}\n"; + } + close($fh); } - - $lockfh->close(); + + close($lockfh); return 'ok'; } # ----------------------------------------------------- Delete from Environment @@ -324,34 +352,34 @@ sub delenv { } my @oldenv; { - my $fh; - unless ($fh=Apache::File->new("$ENV{'user.environment'}")) { - return 'error'; - } - unless (flock($fh,LOCK_SH)) { - &logthis("WARNING: ". - 'Could not obtain shared lock in delenv: '.$!); - $fh->close(); - return 'error: '.$!; - } - @oldenv=<$fh>; - $fh->close(); + my $fh; + unless (open($fh,"$ENV{'user.environment'}")) { + return 'error'; + } + unless (flock($fh,LOCK_SH)) { + &logthis("WARNING: ". + 'Could not obtain shared lock in delenv: '.$!); + close($fh); + return 'error: '.$!; + } + @oldenv=<$fh>; + close($fh); } { - my $fh; - unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) { - return 'error'; - } - unless (flock($fh,LOCK_EX)) { - &logthis("WARNING: ". - 'Could not obtain exclusive lock in delenv: '.$!); - $fh->close(); - return 'error: '.$!; - } - foreach (@oldenv) { - unless ($_=~/^$delthis/) { print $fh $_; } - } - $fh->close(); + my $fh; + unless (open($fh,">$ENV{'user.environment'}")) { + return 'error'; + } + unless (flock($fh,LOCK_EX)) { + &logthis("WARNING: ". + 'Could not obtain exclusive lock in delenv: '.$!); + close($fh); + return 'error: '.$!; + } + foreach (@oldenv) { + unless ($_=~/^$delthis/) { print $fh $_; } + } + close($fh); } return 'ok'; } @@ -367,7 +395,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); } @@ -387,10 +415,11 @@ sub overloaderror { unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; } my $loadavg; if ($checkserver eq $perlvar{'lonHostID'}) { - my $loadfile=Apache::File->new('/proc/loadavg'); + open(my $loadfile,'/proc/loadavg'); $loadavg=<$loadfile>; $loadavg =~ s/\s.*//g; $loadavg = 100*$loadavg/$perlvar{'lonLoadLim'}; + close($loadfile); } else { $loadavg=&reply('load',$checkserver); } @@ -819,19 +848,32 @@ sub getsection { return '-1'; } + +my $disk_caching_disabled=1; + sub devalidate_cache { my ($cache,$id,$name) = @_; delete $$cache{$id.'.time'}; delete $$cache{$id}; - my $filename=$perlvar{'lonDaemons'}.'/tmp/'.$name.".db"; + if ($disk_caching_disabled) { return; } + 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 +909,29 @@ 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)=@_; + if ($disk_caching_disabled) { return; } 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); @@ -939,32 +941,42 @@ sub save_cache_item { sub load_cache_item { my ($cache,$name,$id)=@_; + if ($disk_caching_disabled) { return; } 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 +1054,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 +1067,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 +1102,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"); @@ -1145,8 +1159,8 @@ sub ssi_body { my ($filelink,%form)=@_; my $output=($filelink=~/^http\:/?&externalssi($filelink): &ssi($filelink,%form)); - $output=~s/^.*\]*\>//si; - $output=~s/\<\/body\s*\>.*$//si; + $output=~s/^.*?\]*\>//si; + $output=~s/(.*)\<\/body\s*\>.*?$/$1/si; $output=~ s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs; return $output; @@ -1250,8 +1264,9 @@ sub finishuserfileupload { } # Save the file { - my $fh=Apache::File->new('>'.$filepath.'/'.$fname); + open(my $fh,'>'.$filepath.'/'.$fname); print $fh $ENV{'form.'.$formname}; + close($fh); } # Notify homeserver to grep it # @@ -1325,12 +1340,27 @@ sub flushcourselogs { # File accesses # Writes to the dynamic metadata of resources to get hit counts, etc. # - foreach (keys %accesshash) { - my $entry=$_; - $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/; - my %temphash=($entry => $accesshash{$entry}); - if (&Apache::lonnet::put('nohist_resevaldata',\%temphash,$1,$2) eq 'ok') { - delete $accesshash{$entry}; + foreach my $entry (keys(%accesshash)) { + my ($dom,$name,undef,$type)=($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:); + if ($type eq 'count'){ + my $value = $accesshash{$entry}; + my (undef,$url,undef) = ($entry =~ /^(.*)___(.*)___count$/); + my %temphash=($url => $value); + my $result = &inc('nohist_accesscount',\%temphash,$dom,$name); + if ($result eq 'ok') { + delete $accesshash{$entry}; + } elsif ($result eq 'unknown_cmd') { + # Target server has old code running on it. + my %temphash=($entry => $value); + if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') { + delete $accesshash{$entry}; + } + } + } else { + my %temphash=($entry => $accesshash{$entry}); + if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') { + delete $accesshash{$entry}; + } } } # @@ -1367,7 +1397,8 @@ sub courselog { } else { $courselogs{$ENV{'request.course.id'}}.=$what; } - if (length($courselogs{$ENV{'request.course.id'}})>4048) { +# if (length($courselogs{$ENV{'request.course.id'}})>4048) { + if (length($courselogs{$ENV{'request.course.id'}})>48) { &flushcourselogs(); } } @@ -1392,11 +1423,7 @@ sub countacc { unless ($ENV{'request.course.id'}) { return ''; } $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1; my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count'; - if (defined($accesshash{$key})) { - $accesshash{$key}++; - } else { - $accesshash{$key}=1; - } + $accesshash{$key}++; } sub linklog { @@ -1475,10 +1502,11 @@ sub postannounce { } sub getannounce { - if (my $fh=Apache::File->new($perlvar{'lonDocRoot'}.'/announcement.txt')) { + + if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) { my $announcement=''; while (<$fh>) { $announcement .=$_; } - $fh->close(); + close($fh); if ($announcement=~/\w/) { return ''. @@ -1991,6 +2019,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 +2056,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{$_}).'&'; @@ -2358,6 +2393,30 @@ sub convert_dump_to_currentdump{ return \%returnhash; } +# --------------------------------------------------------------- inc interface + +sub inc { + my ($namespace,$store,$udomain,$uname) = @_; + if (!$udomain) { $udomain=$ENV{'user.domain'}; } + if (!$uname) { $uname=$ENV{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + my $items=''; + if (! ref($store)) { + # got a single value, so use that instead + $items = &escape($store).'=&'; + } elsif (ref($store) eq 'SCALAR') { + $items = &escape($$store).'=&'; + } elsif (ref($store) eq 'ARRAY') { + $items = join('=&',map {&escape($_);} @{$store}); + } elsif (ref($store) eq 'HASH') { + while (my($key,$value) = each(%{$store})) { + $items.= &escape($key).'='.&escape($value).'&'; + } + } + $items=~s/\&$//; + return &reply("inc:$udomain:$uname:$namespace:$items",$uhome); +} + # --------------------------------------------------------------- put interface sub put { @@ -2449,7 +2508,7 @@ sub customaccess { sub allowed { my ($priv,$uri)=@_; - + $uri=&deversion($uri); my $orguri=$uri; $uri=&declutter($uri); @@ -2858,9 +2917,9 @@ sub get_query_reply { for (1..100) { sleep 2; if (-e $replyfile.'.end') { - if (my $fh=Apache::File->new($replyfile)) { + if (open(my $fh,$replyfile)) { $reply.=<$fh>; - $fh->close; + close($fh); } else { return 'error: reply_file_error'; } return &unescape($reply); } @@ -3635,10 +3694,8 @@ sub EXT { my $hashid="$udom:$uname"; my ($result,$cached)=&is_cached(\%userresdatacache,$hashid, 'userres'); - if (!defined($cached)) { - my %resourcedata=&get('resourcedata', - [$courselevelr,$courselevelm, - $courselevel],$udom,$uname); + if (!defined($cached)) { + my %resourcedata=&dump('resourcedata',$udom,$uname); $result=\%resourcedata; &do_cache(\%userresdatacache,$hashid,$result,'userres'); } @@ -3787,7 +3844,9 @@ sub metadata { # # Is this a recursive call for a library? # - my %lcmetacache; + if (! exists($metacache{$uri})) { + $metacache{$uri}={}; + } if ($liburi) { $liburi=&declutter($liburi); $filename=$liburi; @@ -3811,10 +3870,10 @@ sub metadata { if (defined($token->[2]->{'id'})) { $keyroot.='_'.$token->[2]->{'id'}; } - if ($lcmetacache{':packages'}) { - $lcmetacache{':packages'}.=','.$package.$keyroot; + if ($metacache{$uri}->{':packages'}) { + $metacache{$uri}->{':packages'}.=','.$package.$keyroot; } else { - $lcmetacache{':packages'}=$package.$keyroot; + $metacache{$uri}->{':packages'}=$package.$keyroot; } foreach (keys %packagetab) { my $part=$keyroot; @@ -3836,14 +3895,14 @@ sub metadata { if ($subp eq 'display') { $value.=' [Part: '.$part.']'; } - $lcmetacache{':'.$unikey.'.part'}=$part; + $metacache{$uri}->{':'.$unikey.'.part'}=$part; $metathesekeys{$unikey}=1; - unless (defined($lcmetacache{':'.$unikey.'.'.$subp})) { - $lcmetacache{':'.$unikey.'.'.$subp}=$value; + unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) { + $metacache{$uri}->{':'.$unikey.'.'.$subp}=$value; } - if (defined($lcmetacache{':'.$unikey.'.default'})) { - $lcmetacache{':'.$unikey}= - $lcmetacache{':'.$unikey.'.default'}; + if (defined($metacache{$uri}->{':'.$unikey.'.default'})) { + $metacache{$uri}->{':'.$unikey}= + $metacache{$uri}->{':'.$unikey.'.default'}; } } } @@ -3876,6 +3935,7 @@ sub metadata { foreach (sort(split(/\,/,&metadata($uri,'keys', $location,$unikey, $depthcount+1)))) { + $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_}; $metathesekeys{$_}=1; } } @@ -3886,18 +3946,18 @@ sub metadata { } $metathesekeys{$unikey}=1; foreach (@{$token->[3]}) { - $lcmetacache{':'.$unikey.'.'.$_}=$token->[2]->{$_}; + $metacache{$uri}->{':'.$unikey.'.'.$_}=$token->[2]->{$_}; } my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry)); - my $default=$lcmetacache{':'.$unikey.'.default'}; + my $default=$metacache{$uri}->{':'.$unikey.'.default'}; if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) { # only ws inside the tag, and not in default, so use default # as value - $lcmetacache{':'.$unikey}=$default; + $metacache{$uri}->{':'.$unikey}=$default; } else { # either something interesting inside the tag or default # uninteresting - $lcmetacache{':'.$unikey}=$internaltext; + $metacache{$uri}->{':'.$unikey}=$internaltext; } # end of not-a-package not-a-library import } @@ -3907,27 +3967,28 @@ sub metadata { } } # are there custom rights to evaluate - if ($lcmetacache{':copyright'} eq 'custom') { + if ($metacache{$uri}->{':copyright'} eq 'custom') { # # Importing a rights file here # unless ($depthcount) { - my $location=$lcmetacache{':customdistributionfile'}; + my $location=$metacache{$uri}->{':customdistributionfile'}; my $dir=$filename; $dir=~s|[^/]*$||; $location=&filelocation($dir,$location); foreach (sort(split(/\,/,&metadata($uri,'keys', $location,'_rights', $depthcount+1)))) { + $metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_}; $metathesekeys{$_}=1; } } } - $lcmetacache{':keys'}=join(',',keys %metathesekeys); - &metadata_generate_part0(\%metathesekeys,\%lcmetacache,$uri); - $lcmetacache{':allpossiblekeys'}=join(',',keys %metathesekeys); - &do_cache(\%metacache,$uri,\%lcmetacache,'meta'); + $metacache{$uri}->{':keys'}=join(',',keys %metathesekeys); + &metadata_generate_part0(\%metathesekeys,$metacache{$uri},$uri); + $metacache{$uri}->{':allpossiblekeys'}=join(',',keys %metathesekeys); + &do_cache(\%metacache,$uri,$metacache{$uri},'meta'); # this is the end of "was not already recently cached } return $metacache{$uri}->{':'.$what}; @@ -3993,13 +4054,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 +4074,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 +4141,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 +4265,7 @@ sub numval { } sub latest_rnd_algorithm_id { - return '64bit'; + return '64bit2'; } sub rndseed { @@ -4205,6 +4282,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 +4327,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"); @@ -4311,7 +4412,8 @@ sub getfile { } else { # normal file from res space &repcopy($file); if (! -e $file ) { return -1; }; - my $fh=Apache::File->new($file); + my $fh; + open($fh,"<$file"); my $a=''; while (<$fh>) { $a .=$_; } return $a; @@ -4399,7 +4501,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 +4508,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; @@ -4426,7 +4529,7 @@ BEGIN { # ----------------------------------- Read loncapa.conf and loncapa_apache.conf unless ($readit) { { - my $config=Apache::File->new("/etc/httpd/conf/loncapa.conf"); + open(my $config,") { if ($configline =~ /^[^\#]*PerlSetVar/) { @@ -4435,9 +4538,10 @@ BEGIN { $perlvar{$varname}=$varvalue; } } + close($config); } { - my $config=Apache::File->new("/etc/httpd/conf/loncapa_apache.conf"); + open(my $config,") { if ($configline =~ /^[^\#]*PerlSetVar/) { @@ -4446,16 +4550,16 @@ BEGIN { $perlvar{$varname}=$varvalue; } } + close($config); } # ------------------------------------------------------------ Read domain file { - my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}. - '/domain.tab'); %domaindescription = (); %domain_auth_def = (); %domain_auth_arg_def = (); - if ($fh) { + my $fh; + if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) { while (<$fh>) { next if (/^(\#|\s*$)/); # next if /^\#/; @@ -4470,16 +4574,17 @@ BEGIN { $domain_longi{$domain}=$longi; $domain_lati{$domain}=$lati; -# &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}"); + # &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}"); # &logthis("Domain.tab: $domain ".$domaindescription{$domain} ); - } + } } + close ($fh); } # ------------------------------------------------------------- Read hosts file { - my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab"); + open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); while (my $configline=<$config>) { next if ($configline =~ /^(\#|\s*$)/); @@ -4497,11 +4602,12 @@ BEGIN { } } } + close($config); } # ------------------------------------------------------ Read spare server file { - my $config=Apache::File->new("$perlvar{'lonTabDir'}/spare.tab"); + open(my $config,"<$perlvar{'lonTabDir'}/spare.tab"); while (my $configline=<$config>) { chomp($configline); @@ -4509,46 +4615,50 @@ BEGIN { $spareid{$configline}=1; } } + close($config); } # ------------------------------------------------------------ Read permissions { - my $config=Apache::File->new("$perlvar{'lonTabDir'}/roles.tab"); + open(my $config,"<$perlvar{'lonTabDir'}/roles.tab"); while (my $configline=<$config>) { - chomp($configline); - if ($configline) { - my ($role,$perm)=split(/ /,$configline); - if ($perm ne '') { $pr{$role}=$perm; } - } + chomp($configline); + if ($configline) { + my ($role,$perm)=split(/ /,$configline); + if ($perm ne '') { $pr{$role}=$perm; } + } } + close($config); } # -------------------------------------------- Read plain texts for permissions { - my $config=Apache::File->new("$perlvar{'lonTabDir'}/rolesplain.tab"); + open(my $config,"<$perlvar{'lonTabDir'}/rolesplain.tab"); while (my $configline=<$config>) { - chomp($configline); - if ($configline) { - my ($short,$plain)=split(/:/,$configline); - if ($plain ne '') { $prp{$short}=$plain; } - } + chomp($configline); + if ($configline) { + my ($short,$plain)=split(/:/,$configline); + if ($plain ne '') { $prp{$short}=$plain; } + } } + close($config); } # ---------------------------------------------------------- Read package table { - my $config=Apache::File->new("$perlvar{'lonTabDir'}/packages.tab"); + open(my $config,"<$perlvar{'lonTabDir'}/packages.tab"); while (my $configline=<$config>) { - chomp($configline); - my ($short,$plain)=split(/:/,$configline); - my ($pack,$name)=split(/\&/,$short); - if ($plain ne '') { - $packagetab{$pack.'&'.$name.'&name'}=$name; - $packagetab{$short}=$plain; - } + chomp($configline); + my ($short,$plain)=split(/:/,$configline); + my ($pack,$name)=split(/\&/,$short); + if ($plain ne '') { + $packagetab{$pack.'&'.$name.'&name'}=$name; + $packagetab{$short}=$plain; + } } + close($config); } # ------------- set up temporary directory @@ -5167,6 +5277,14 @@ dumps the complete (or key matching rege =item * +inc($namespace,$store,$udom,$uname) : increments $store in $namespace. +$store can be a scalar, an array reference, or if the amount to be +incremented is > 1, a hash reference. + +($udom and $uname are optional) + +=item * + put($namespace,$storehash,$udom,$uname) : stores hash in namesp ($udom and $uname are optional)