--- loncom/lonnet/perl/lonnet.pm 2003/10/22 18:29:28 1.431
+++ loncom/lonnet/perl/lonnet.pm 2003/12/04 20:09:35 1.452
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.431 2003/10/22 18:29:28 www Exp $
+# $Id: lonnet.pm,v 1.452 2003/12/04 20:09:35 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -25,55 +25,16 @@
#
# http://www.lon-capa.org/
#
-# 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30,
-# 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19,
-# 11/8,11/16,11/18,11/22,11/23,12/22,
-# 01/06,01/13,02/24,02/28,02/29,
-# 03/01,03/02,03/06,03/07,03/13,
-# 04/05,05/29,05/31,06/01,
-# 06/05,06/26 Gerd Kortemeyer
-# 06/26 Ben Tyszka
-# 06/30,07/15,07/17,07/18,07/20,07/21,07/22,07/25 Gerd Kortemeyer
-# 08/14 Ben Tyszka
-# 08/22,08/28,08/31,09/01,09/02,09/04,09/05,09/25,09/28,09/30 Gerd Kortemeyer
-# 10/04 Gerd Kortemeyer
-# 10/04 Guy Albertelli
-# 10/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29,
-# 10/30,10/31,
-# 11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25,11/27,
-# 12/02,12/12,12/13,12/14,12/28,12/29 Gerd Kortemeyer
-# 05/01/01 Guy Albertelli
-# 05/01,06/01,09/01 Gerd Kortemeyer
-# 09/01 Guy Albertelli
-# 09/01,10/01,11/01 Gerd Kortemeyer
-# YEAR=2001
-# 3/2 Gerd Kortemeyer
-# 3/19,3/20 Gerd Kortemeyer
-# 5/26,5/28 Gerd Kortemeyer
-# 5/30 H. K. Ng
-# 6/1 Gerd Kortemeyer
-# July Guy Albertelli
-# 8/4,8/7,8/8,8/9,8/11,8/16,8/17,8/18,8/20,8/23,9/20,9/21,9/26,
-# 10/2 Gerd Kortemeyer
-# 11/17,11/20,11/22,11/29 Gerd Kortemeyer
-# 12/5 Matthew Hall
-# 12/5 Guy Albertelli
-# 12/6,12/7,12/12 Gerd Kortemeyer
-# 12/21,12/22,12/27,12/28 Gerd Kortemeyer
-# YEAR=2002
-# 1/4,2/4,2/7 Gerd Kortemeyer
-#
###
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
@@ -90,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];
@@ -107,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;
}
@@ -117,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;
}
@@ -170,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) {
@@ -218,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) {
@@ -268,18 +258,27 @@ 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;
for ($envi=0;$envi<=$#profile;$envi++) {
chomp($profile[$envi]);
my ($envname,$envvalue)=split(/=/,$profile[$envi]);
$ENV{$envname} = $envvalue;
+ if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
+ if ($time < time-300) {
+ $Remove{$key}++;
+ }
+ }
}
$ENV{'user.environment'} = "$lonidsdir/$handle.id";
+ foreach my $expired_key (keys(%Remove)) {
+ &delenv($expired_key);
+ }
}
# ---------------------------------------------------------- Append Environment
@@ -298,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("<font color=blue>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
@@ -353,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("<font color=blue>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("<font color=blue>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("<font color=blue>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("<font color=blue>WARNING: ".
+ 'Could not obtain exclusive lock in delenv: '.$!);
+ close($fh);
+ return 'error: '.$!;
+ }
+ foreach (@oldenv) {
+ unless ($_=~/^$delthis/) { print $fh $_; }
+ }
+ close($fh);
}
return 'ok';
}
@@ -396,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);
}
@@ -416,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);
}
@@ -848,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("<font color='red'>devalidate_cache blew up :$@:$name</font>");
+ unlink($filename);
+ }
} else {
- &logthis("Unable to tie hash");
+ if (-e $filename) {
+ &logthis("Unable to tie hash (devalidate cache): $name");
+ unlink($filename);
+ }
}
untie(%hash);
flock(DB,LOCK_UN);
@@ -878,7 +891,7 @@ sub is_cached {
return (undef,undef);
} else {
if (time-($$cache{$id.'.time'})>$time) {
-# &logthis("Devailidating $id - ".time-($$cache{$id.'.time'}));
+# &logthis("Devalidating $id - ".time-($$cache{$id.'.time'}));
&devalidate_cache($cache,$id,$name);
return (undef,undef);
}
@@ -896,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("<font color='red'>save_cache blew up :$@:$name</font>");
+ unlink($filename);
+ }
} else {
- &logthis("Unable to tie hash");
+ if (-e $filename) {
+ &logthis("Unable to tie hash (save cache item): $name ($!)");
+ unlink($filename);
+ }
}
untie(%hash);
flock(DB,LOCK_UN);
@@ -968,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("<font color='red'>load_cache blew up :$@:$name</font>");
+ unlink($filename);
+ }
} else {
- &logthis("Unable to tie hash");
+ if (-e $filename) {
+ &logthis("Unable to tie hash (load cache item): $name ($!)");
+ unlink($filename);
+ }
}
untie(%hash);
flock(DB,LOCK_UN);
@@ -1071,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);
@@ -1082,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
@@ -1117,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");
@@ -1174,8 +1159,8 @@ sub ssi_body {
my ($filelink,%form)=@_;
my $output=($filelink=~/^http\:/?&externalssi($filelink):
&ssi($filelink,%form));
- $output=~s/^.*\<body[^\>]*\>//si;
- $output=~s/\<\/body\s*\>.*$//si;
+ $output=~s/^.*?\<body[^\>]*\>//si;
+ $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;
$output=~
s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs;
return $output;
@@ -1279,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
#
@@ -1354,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};
+ }
}
}
#
@@ -1396,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();
}
}
@@ -1421,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 {
@@ -1504,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
'<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'.
@@ -2020,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{$_}).'&';
@@ -2053,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{$_}).'&';
@@ -2387,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 {
@@ -2478,7 +2508,7 @@ sub customaccess {
sub allowed {
my ($priv,$uri)=@_;
-
+ $uri=&deversion($uri);
my $orguri=$uri;
$uri=&declutter($uri);
@@ -2763,6 +2793,7 @@ sub allowed {
sub is_on_map {
my $uri=&declutter(shift);
+ $uri=~s/\.\d+\.(\w+)$/\.$1/;
my @uriparts=split(/\//,$uri);
my $filename=$uriparts[$#uriparts];
my $pathname=$uri;
@@ -2774,10 +2805,7 @@ sub is_on_map {
if ($match) {
return (1,$1);
} else {
- my ($name,$ext)=($filename=~/^(.+)\.(\w+)$/);
- $ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
- /\&(\Q$name\E\.\d+\.$ext)\:([\d\|]+)\&/;
- return (0,$2,$pathname.'/'.$1);
+ return (0,0);
}
}
@@ -2889,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);
}
@@ -3848,18 +3876,25 @@ sub metadata {
$lcmetacache{':packages'}=$package.$keyroot;
}
foreach (keys %packagetab) {
- if ($_=~/^$package\&/) {
+ my $part=$keyroot;
+ $part=~s/^\_//;
+ if ($_=~/^\Q$package\E\&/ ||
+ $_=~/^\Q$package\E_0\&/) {
my ($pack,$name,$subp)=split(/\&/,$_);
# ignore package.tab specified default values
# here &package_tab_default() will fetch those
if ($subp eq 'default') { next; }
my $value=$packagetab{$_};
- my $part=$keyroot;
- $part=~s/^\_//;
+ my $unikey;
+ if ($pack =~ /_0$/) {
+ $unikey='parameter_0_'.$name;
+ $part=0;
+ } else {
+ $unikey='parameter'.$keyroot.'_'.$name;
+ }
if ($subp eq 'display') {
$value.=' [Part: '.$part.']';
}
- my $unikey='parameter'.$keyroot.'_'.$name;
$lcmetacache{':'.$unikey.'.part'}=$part;
$metathesekeys{$unikey}=1;
unless (defined($lcmetacache{':'.$unikey.'.'.$subp})) {
@@ -4017,13 +4052,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';
@@ -4037,14 +4072,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;
@@ -4100,11 +4137,33 @@ sub decode_symb {
sub fixversion {
my $fn=shift;
if ($fn=~/^(adm|uploaded|public)/) { return $fn; }
- my ($match,$cond,$versioned)=&is_on_map($fn);
- unless ($match) {
- $fn=$versioned;
- }
- 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') ||
+ ($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
@@ -4204,7 +4263,7 @@ sub numval {
}
sub latest_rnd_algorithm_id {
- return '64bit';
+ return '64bit2';
}
sub rndseed {
@@ -4221,6 +4280,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);
}
@@ -4264,14 +4325,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");
@@ -4327,7 +4410,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;
@@ -4412,20 +4496,28 @@ sub mod_perl_version {
}
return 1;
}
+
+sub correct_line_ends {
+ my ($result)=@_;
+ $$result =~s/\r\n/\n/mg;
+ $$result =~s/\r/\n/mg;
+}
# ================================================================ Main Program
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;
@@ -4435,7 +4527,7 @@ BEGIN {
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf
unless ($readit) {
{
- my $config=Apache::File->new("/etc/httpd/conf/loncapa.conf");
+ open(my $config,"</etc/httpd/conf/loncapa.conf");
while (my $configline=<$config>) {
if ($configline =~ /^[^\#]*PerlSetVar/) {
@@ -4444,9 +4536,10 @@ BEGIN {
$perlvar{$varname}=$varvalue;
}
}
+ close($config);
}
{
- my $config=Apache::File->new("/etc/httpd/conf/loncapa_apache.conf");
+ open(my $config,"</etc/httpd/conf/loncapa_apache.conf");
while (my $configline=<$config>) {
if ($configline =~ /^[^\#]*PerlSetVar/) {
@@ -4455,16 +4548,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 /^\#/;
@@ -4479,16 +4572,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*$)/);
@@ -4506,11 +4600,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);
@@ -4518,46 +4613,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
@@ -5176,6 +5275,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)