loncom/lonnet/perl/lonnet.pm - diff

Return to lonnet.pm CVS log

Up to [LON-CAPA] / loncom / lonnet / perl

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.439 and 1.450

version 1.439, 2003/11/01 16:37:21	version 1.450, 2003/11/12 21:37:33
Line 30	Line 30
package Apache::lonnet;	package Apache::lonnet;

use strict;	use strict;
use Apache::File;
use LWP::UserAgent();	use LWP::UserAgent();
use HTTP::Headers;	use HTTP::Headers;
use vars	use vars
qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom	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	%courselogs %accesshash %userrolehash $processmarker $dumpcount
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache	%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache
%userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def	%userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def
Line 52 use Storable qw(lock_store lock_nstore l	Line 51 use Storable qw(lock_store lock_nstore l
use Time::HiRes();	use Time::HiRes();
my $readit;	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	# --------------------------------------------------------------------- Logging

sub logtouch {	sub logtouch {
my $execdir=$perlvar{'lonDaemons'};	my $execdir=$perlvar{'lonDaemons'};
unless (-e "$execdir/logs/lonnet.log") {	unless (-e "$execdir/logs/lonnet.log") {
my $fh=Apache::File->new(">>$execdir/logs/lonnet.log");	open(my $fh,">>$execdir/logs/lonnet.log");
close $fh;	close $fh;
}	}
my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];	my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];
Line 69 sub logthis {	Line 91 sub logthis {
my $execdir=$perlvar{'lonDaemons'};	my $execdir=$perlvar{'lonDaemons'};
my $now=time;	my $now=time;
my $local=localtime($now);	my $local=localtime($now);
my $fh=Apache::File->new(">>$execdir/logs/lonnet.log");	if (open(my $fh,">>$execdir/logs/lonnet.log")) {
print $fh "$local ($$): $message\n";	print $fh "$local ($$): $message\n";
	close($fh);
	}
return 1;	return 1;
}	}

Line 79 sub logperm {	Line 103 sub logperm {
my $execdir=$perlvar{'lonDaemons'};	my $execdir=$perlvar{'lonDaemons'};
my $now=time;	my $now=time;
my $local=localtime($now);	my $local=localtime($now);
my $fh=Apache::File->new(">>$execdir/logs/lonnet.perm.log");	if (open(my $fh,">>$execdir/logs/lonnet.perm.log")) {
print $fh "$now:$message:$local\n";	print $fh "$now:$message:$local\n";
	close($fh);
	}
return 1;	return 1;
}	}

Line 132 sub reconlonc {	Line 158 sub reconlonc {
my $peerfile=shift;	my $peerfile=shift;
&logthis("Trying to reconnect for $peerfile");	&logthis("Trying to reconnect for $peerfile");
my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";	my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
if (my $fh=Apache::File->new("$loncfile")) {	if (open(my $fh,"<$loncfile")) {
my $loncpid=<$fh>;	my $loncpid=<$fh>;
chomp($loncpid);	chomp($loncpid);
if (kill 0 => $loncpid) {	if (kill 0 => $loncpid) {
Line 180 sub critical {	Line 206 sub critical {
"$perlvar{'lonSockDir'}/delayed/$now.$dumpcount.$$.$middlename.$server";	"$perlvar{'lonSockDir'}/delayed/$now.$dumpcount.$$.$middlename.$server";
$dumpcount++;	$dumpcount++;
{	{
my $dfh;	my $dfh;
if ($dfh=Apache::File->new(">$dfilename")) {	if (open($dfh,">$dfilename")) {
print $dfh "$cmd\n";	print $dfh "$cmd\n";
}	close($dfh);
	}
}	}
sleep 2;	sleep 2;
my $wcmd='';	my $wcmd='';
{	{
my $dfh;	my $dfh;
if ($dfh=Apache::File->new("$dfilename")) {	if (open($dfh,"<$dfilename")) {
$wcmd=<$dfh>;	$wcmd=<$dfh>;
}	close($dfh);
	}
}	}
chomp($wcmd);	chomp($wcmd);
if ($wcmd eq $cmd) {	if ($wcmd eq $cmd) {
Line 230 sub transfer_profile_to_env {	Line 258 sub transfer_profile_to_env {
my ($lonidsdir,$handle)=@_;	my ($lonidsdir,$handle)=@_;
my @profile;	my @profile;
{	{
my $idf=Apache::File->new("$lonidsdir/$handle.id");	open(my $idf,"$lonidsdir/$handle.id");
flock($idf,LOCK_SH);	flock($idf,LOCK_SH);
@profile=<$idf>;	@profile=<$idf>;
$idf->close();	close($idf);
}	}
my $envi;	my $envi;
my %Remove;	my %Remove;
Line 247 sub transfer_profile_to_env {	Line 275 sub transfer_profile_to_env {
}	}
}	}
}	}
	$ENV{'user.environment'} = "$lonidsdir/$handle.id";
foreach my $expired_key (keys(%Remove)) {	foreach my $expired_key (keys(%Remove)) {
&delenv($expired_key);	&delenv($expired_key);
}	}
$ENV{'user.environment'} = "$lonidsdir/$handle.id";
}	}

# ---------------------------------------------------------- Append Environment	# ---------------------------------------------------------- Append Environment
Line 269 sub appenv {	Line 297 sub appenv {
}	}

my $lockfh;	my $lockfh;
unless ($lockfh=Apache::File->new("$ENV{'user.environment'}")) {	unless (open($lockfh,"$ENV{'user.environment'}")) {
return 'error: '.$!;	return 'error: '.$!;
}	}
unless (flock($lockfh,LOCK_EX)) {	unless (flock($lockfh,LOCK_EX)) {
&logthis("<font color=blue>WARNING: ".	&logthis("<font color=blue>WARNING: ".
'Could not obtain exclusive lock in appenv: '.$!);	'Could not obtain exclusive lock in appenv: '.$!);
$lockfh->close();	close($lockfh);
return 'error: '.$!;	return 'error: '.$!;
}	}

my @oldenv;	my @oldenv;
{	{
my $fh;	my $fh;
unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {	unless (open($fh,"$ENV{'user.environment'}")) {
return 'error: '.$!;	return 'error: '.$!;
}	}
@oldenv=<$fh>;	@oldenv=<$fh>;
$fh->close();	close($fh);
}	}
for (my $i=0; $i<=$#oldenv; $i++) {	for (my $i=0; $i<=$#oldenv; $i++) {
chomp($oldenv[$i]);	chomp($oldenv[$i]);
if ($oldenv[$i] ne '') {	if ($oldenv[$i] ne '') {
my ($name,$value)=split(/=/,$oldenv[$i]);	my ($name,$value)=split(/=/,$oldenv[$i]);
unless (defined($newenv{$name})) {	unless (defined($newenv{$name})) {
$newenv{$name}=$value;	$newenv{$name}=$value;
}	}
}	}
}	}
{	{
my $fh;	my $fh;
unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) {	unless (open($fh,">$ENV{'user.environment'}")) {
return 'error';	return 'error';
}	}
my $newname;	my $newname;
foreach $newname (keys %newenv) {	foreach $newname (keys %newenv) {
print $fh "$newname=$newenv{$newname}\n";	print $fh "$newname=$newenv{$newname}\n";
}	}
$fh->close();	close($fh);
}	}

$lockfh->close();	close($lockfh);
return 'ok';	return 'ok';
}	}
# ----------------------------------------------------- Delete from Environment	# ----------------------------------------------------- Delete from Environment
Line 324 sub delenv {	Line 352 sub delenv {
}	}
my @oldenv;	my @oldenv;
{	{
my $fh;	my $fh;
unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {	unless (open($fh,"$ENV{'user.environment'}")) {
return 'error';	return 'error';
}	}
unless (flock($fh,LOCK_SH)) {	unless (flock($fh,LOCK_SH)) {
&logthis("<font color=blue>WARNING: ".	&logthis("<font color=blue>WARNING: ".
'Could not obtain shared lock in delenv: '.$!);	'Could not obtain shared lock in delenv: '.$!);
$fh->close();	close($fh);
return 'error: '.$!;	return 'error: '.$!;
}	}
@oldenv=<$fh>;	@oldenv=<$fh>;
$fh->close();	close($fh);
}	}
{	{
my $fh;	my $fh;
unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) {	unless (open($fh,">$ENV{'user.environment'}")) {
return 'error';	return 'error';
}	}
unless (flock($fh,LOCK_EX)) {	unless (flock($fh,LOCK_EX)) {
&logthis("<font color=blue>WARNING: ".	&logthis("<font color=blue>WARNING: ".
'Could not obtain exclusive lock in delenv: '.$!);	'Could not obtain exclusive lock in delenv: '.$!);
$fh->close();	close($fh);
return 'error: '.$!;	return 'error: '.$!;
}	}
foreach (@oldenv) {	foreach (@oldenv) {
unless ($_=~/^$delthis/) { print $fh $_; }	unless ($_=~/^$delthis/) { print $fh $_; }
}	}
$fh->close();	close($fh);
}	}
return 'ok';	return 'ok';
}	}
Line 387 sub overloaderror {	Line 415 sub overloaderror {
unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; }	unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; }
my $loadavg;	my $loadavg;
if ($checkserver eq $perlvar{'lonHostID'}) {	if ($checkserver eq $perlvar{'lonHostID'}) {
my $loadfile=Apache::File->new('/proc/loadavg');	open(my $loadfile,'/proc/loadavg');
$loadavg=<$loadfile>;	$loadavg=<$loadfile>;
$loadavg =~ s/\s.*//g;	$loadavg =~ s/\s.*//g;
$loadavg = 100*$loadavg/$perlvar{'lonLoadLim'};	$loadavg = 100*$loadavg/$perlvar{'lonLoadLim'};
	close($loadfile);
} else {	} else {
$loadavg=&reply('load',$checkserver);	$loadavg=&reply('load',$checkserver);
}	}
Line 823 sub devalidate_cache {	Line 852 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 905 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 939 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 {	} 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);	untie(%hash);
flock(DB,LOCK_UN);	flock(DB,LOCK_UN);
Line 1042 sub getversion {	Line 1048 sub getversion {

sub currentversion {	sub currentversion {
my $fname=shift;	my $fname=shift;
	my ($result,$cached)=&is_cached(\%resversioncache,$fname,'resversion',600);
	if (defined($cached)) { return $result; }
my $author=$fname;	my $author=$fname;
$author=~s/\/home\/httpd\/html\/res\/([^\/])\/([^\/]).*/$1\/$2/;	$author=~s/\/home\/httpd\/html\/res\/([^\/])\/([^\/]).*/$1\/$2/;
my ($udom,$uname)=split(/\//,$author);	my ($udom,$uname)=split(/\//,$author);
Line 1053 sub currentversion {	Line 1061 sub currentversion {
if (($answer eq 'con_lost') \|\| ($answer eq 'rejected')) {	if (($answer eq 'con_lost') \|\| ($answer eq 'rejected')) {
return -1;	return -1;
}	}
return $answer;	return &do_cache(\%resversioncache,$fname,$answer,'resversion');
}	}

# ----------------------------- Subscribe to a resource, return URL if possible	# ----------------------------- Subscribe to a resource, return URL if possible
Line 1088 sub repcopy {	Line 1096 sub repcopy {
&logthis("Subscribe returned $remoteurl: $filename");	&logthis("Subscribe returned $remoteurl: $filename");
return HTTP_SERVICE_UNAVAILABLE;	return HTTP_SERVICE_UNAVAILABLE;
} elsif ($remoteurl eq 'not_found') {	} elsif ($remoteurl eq 'not_found') {
&logthis("Subscribe returned not_found: $filename");	#&logthis("Subscribe returned not_found: $filename");
return HTTP_NOT_FOUND;	return HTTP_NOT_FOUND;
} elsif ($remoteurl =~ /^rejected by/) {	} elsif ($remoteurl =~ /^rejected by/) {
&logthis("Subscribe returned $remoteurl: $filename");	&logthis("Subscribe returned $remoteurl: $filename");
Line 1250 sub finishuserfileupload {	Line 1258 sub finishuserfileupload {
}	}
# Save the file	# Save the file
{	{
my $fh=Apache::File->new('>'.$filepath.'/'.$fname);	open(my $fh,'>'.$filepath.'/'.$fname);
print $fh $ENV{'form.'.$formname};	print $fh $ENV{'form.'.$formname};
	close($fh);
}	}
# Notify homeserver to grep it	# Notify homeserver to grep it
#	#
Line 1325 sub flushcourselogs {	Line 1334 sub flushcourselogs {
# File accesses	# File accesses
# Writes to the dynamic metadata of resources to get hit counts, etc.	# Writes to the dynamic metadata of resources to get hit counts, etc.
#	#
foreach (keys %accesshash) {	foreach my $entry (keys(%accesshash)) {
my $entry=$_;	my ($dom,$name,undef,$type)=($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:);
$entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/;	if ($type eq 'count'){
my %temphash=($entry => $accesshash{$entry});	my $value = $accesshash{$entry};
if (&Apache::lonnet::put('nohist_resevaldata',\%temphash,$1,$2) eq 'ok') {	my (undef,$url,undef) = ($entry =~ /^(.)___(.)___count$/);
delete $accesshash{$entry};	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};
	}
}	}
}	}
#	#
Line 1367 sub courselog {	Line 1391 sub courselog {
} else {	} else {
$courselogs{$ENV{'request.course.id'}}.=$what;	$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();	&flushcourselogs();
}	}
}	}
Line 1392 sub countacc {	Line 1417 sub countacc {
unless ($ENV{'request.course.id'}) { return ''; }	unless ($ENV{'request.course.id'}) { return ''; }
$accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1;	$accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1;
my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';	my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';
if (defined($accesshash{$key})) {	$accesshash{$key}++;
$accesshash{$key}++;
} else {
$accesshash{$key}=1;
}
}	}

sub linklog {	sub linklog {
Line 1475 sub postannounce {	Line 1496 sub postannounce {
}	}

sub getannounce {	sub getannounce {
if (my $fh=Apache::File->new($perlvar{'lonDocRoot'}.'/announcement.txt')) {
	if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) {
my $announcement='';	my $announcement='';
while (<$fh>) { $announcement .=$_; }	while (<$fh>) { $announcement .=$_; }
$fh->close();	close($fh);
if ($announcement=~/\w/) {	if ($announcement=~/\w/) {
return	return
'<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'.	'<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'.
Line 1991 sub store {	Line 2013 sub store {
}	}
}	}
if (!$home) { $home=$ENV{'user.home'}; }	if (!$home) { $home=$ENV{'user.home'}; }

	$$storehash{'ip'}=$ENV{'REMOTE_ADDR'};
	$$storehash{'host'}=$perlvar{'lonHostID'};

my $namevalue='';	my $namevalue='';
foreach (keys %$storehash) {	foreach (keys %$storehash) {
$namevalue.=escape($_).'='.escape($$storehash{$_}).'&';	$namevalue.=escape($_).'='.escape($$storehash{$_}).'&';
Line 2024 sub cstore {	Line 2050 sub cstore {
}	}
if (!$home) { $home=$ENV{'user.home'}; }	if (!$home) { $home=$ENV{'user.home'}; }

	$$storehash{'ip'}=$ENV{'REMOTE_ADDR'};
	$$storehash{'host'}=$perlvar{'lonHostID'};

my $namevalue='';	my $namevalue='';
foreach (keys %$storehash) {	foreach (keys %$storehash) {
$namevalue.=escape($_).'='.escape($$storehash{$_}).'&';	$namevalue.=escape($_).'='.escape($$storehash{$_}).'&';
Line 2358 sub convert_dump_to_currentdump{	Line 2387 sub convert_dump_to_currentdump{
return \%returnhash;	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	# --------------------------------------------------------------- put interface

sub put {	sub put {
Line 2858 sub get_query_reply {	Line 2911 sub get_query_reply {
for (1..100) {	for (1..100) {
sleep 2;	sleep 2;
if (-e $replyfile.'.end') {	if (-e $replyfile.'.end') {
if (my $fh=Apache::File->new($replyfile)) {	if (open(my $fh,$replyfile)) {
$reply.=<$fh>;	$reply.=<$fh>;
$fh->close;	close($fh);
} else { return 'error: reply_file_error'; }	} else { return 'error: reply_file_error'; }
return &unescape($reply);	return &unescape($reply);
}	}
Line 4080 sub fixversion {	Line 4133 sub fixversion {
if ($fn=~/^(adm\|uploaded\|public)/) { return $fn; }	if ($fn=~/^(adm\|uploaded\|public)/) { return $fn; }
my %bighash;	my %bighash;
my $uri=&clutter($fn);	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',	if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
&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') \|\|
$uri=~s/\.(\w+)$/\.$version\.$1/;	($version==&getversion($uri))) {
}	$uri=~s/\.(\w+)$/\.$version\.$1/;
}	}
untie %bighash;	}
	untie %bighash;
}	}
return &declutter($uri);	return &do_cache
	(\%courseresversioncache,$key,&declutter($uri),'courseresversion');
}	}

sub deversion {	sub deversion {
Line 4196 sub numval {	Line 4257 sub numval {
}	}

sub latest_rnd_algorithm_id {	sub latest_rnd_algorithm_id {
return '64bit';	return '64bit2';
}	}

sub rndseed {	sub rndseed {
Line 4213 sub rndseed {	Line 4274 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 4256 sub rndseed_64bit {	Line 4319 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 4319 sub getfile {	Line 4404 sub getfile {
} else { # normal file from res space	} else { # normal file from res space
&repcopy($file);	&repcopy($file);
if (! -e $file ) { return -1; };	if (! -e $file ) { return -1; };
my $fh=Apache::File->new($file);	my $fh;
	open($fh,"<$file");
my $a='';	my $a='';
while (<$fh>) { $a .=$_; }	while (<$fh>) { $a .=$_; }
return $a;	return $a;
Line 4407 sub mod_perl_version {	Line 4493 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 4415 sub correct_line_ends {	Line 4500 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
&logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache)));	&logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache)));
&logthis(sprintf("%-20s is %s",'%usectioncache',scalar(%usectioncache)));	&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();	&flushcourselogs();
&logthis("Shutting down");	&logthis("Shutting down");
return DONE;	return DONE;
Line 4434 BEGIN {	Line 4521 BEGIN {
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf	# ----------------------------------- Read loncapa.conf and loncapa_apache.conf
unless ($readit) {	unless ($readit) {
{	{
my $config=Apache::File->new("/etc/httpd/conf/loncapa.conf");	open(my $config,"</etc/httpd/conf/loncapa.conf");

while (my $configline=<$config>) {	while (my $configline=<$config>) {
if ($configline =~ /^[^\#]*PerlSetVar/) {	if ($configline =~ /^[^\#]*PerlSetVar/) {
Line 4443 BEGIN {	Line 4530 BEGIN {
$perlvar{$varname}=$varvalue;	$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>) {	while (my $configline=<$config>) {
if ($configline =~ /^[^\#]*PerlSetVar/) {	if ($configline =~ /^[^\#]*PerlSetVar/) {
Line 4454 BEGIN {	Line 4542 BEGIN {
$perlvar{$varname}=$varvalue;	$perlvar{$varname}=$varvalue;
}	}
}	}
	close($config);
}	}

# ------------------------------------------------------------ Read domain file	# ------------------------------------------------------------ Read domain file
{	{
my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
'/domain.tab');
%domaindescription = ();	%domaindescription = ();
%domain_auth_def = ();	%domain_auth_def = ();
%domain_auth_arg_def = ();	%domain_auth_arg_def = ();
if ($fh) {	my $fh;
	if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) {
while (<$fh>) {	while (<$fh>) {
next if (/^(\#\|\s*$)/);	next if (/^(\#\|\s*$)/);
# next if /^\#/;	# next if /^\#/;
Line 4478 BEGIN {	Line 4566 BEGIN {
$domain_longi{$domain}=$longi;	$domain_longi{$domain}=$longi;
$domain_lati{$domain}=$lati;	$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} );	# &logthis("Domain.tab: $domain ".$domaindescription{$domain} );
}	}
}	}
	close ($fh);
}	}


# ------------------------------------------------------------- Read hosts file	# ------------------------------------------------------------- Read hosts file
{	{
my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");	open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");

while (my $configline=<$config>) {	while (my $configline=<$config>) {
next if ($configline =~ /^(\#\|\s*$)/);	next if ($configline =~ /^(\#\|\s*$)/);
Line 4505 BEGIN {	Line 4594 BEGIN {
}	}
}	}
}	}
	close($config);
}	}

# ------------------------------------------------------ Read spare server file	# ------------------------------------------------------ Read spare server file
{	{
my $config=Apache::File->new("$perlvar{'lonTabDir'}/spare.tab");	open(my $config,"<$perlvar{'lonTabDir'}/spare.tab");

while (my $configline=<$config>) {	while (my $configline=<$config>) {
chomp($configline);	chomp($configline);
Line 4517 BEGIN {	Line 4607 BEGIN {
$spareid{$configline}=1;	$spareid{$configline}=1;
}	}
}	}
	close($config);
}	}
# ------------------------------------------------------------ Read permissions	# ------------------------------------------------------------ Read permissions
{	{
my $config=Apache::File->new("$perlvar{'lonTabDir'}/roles.tab");	open(my $config,"<$perlvar{'lonTabDir'}/roles.tab");

while (my $configline=<$config>) {	while (my $configline=<$config>) {
chomp($configline);	chomp($configline);
if ($configline) {	if ($configline) {
my ($role,$perm)=split(/ /,$configline);	my ($role,$perm)=split(/ /,$configline);
if ($perm ne '') { $pr{$role}=$perm; }	if ($perm ne '') { $pr{$role}=$perm; }
}	}
}	}
	close($config);
}	}

# -------------------------------------------- Read plain texts for permissions	# -------------------------------------------- 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>) {	while (my $configline=<$config>) {
chomp($configline);	chomp($configline);
if ($configline) {	if ($configline) {
my ($short,$plain)=split(/:/,$configline);	my ($short,$plain)=split(/:/,$configline);
if ($plain ne '') { $prp{$short}=$plain; }	if ($plain ne '') { $prp{$short}=$plain; }
}	}
}	}
	close($config);
}	}

# ---------------------------------------------------------- Read package table	# ---------------------------------------------------------- Read package table
{	{
my $config=Apache::File->new("$perlvar{'lonTabDir'}/packages.tab");	open(my $config,"<$perlvar{'lonTabDir'}/packages.tab");

while (my $configline=<$config>) {	while (my $configline=<$config>) {
chomp($configline);	chomp($configline);
my ($short,$plain)=split(/:/,$configline);	my ($short,$plain)=split(/:/,$configline);
my ($pack,$name)=split(/\&/,$short);	my ($pack,$name)=split(/\&/,$short);
if ($plain ne '') {	if ($plain ne '') {
$packagetab{$pack.'&'.$name.'&name'}=$name;	$packagetab{$pack.'&'.$name.'&name'}=$name;
$packagetab{$short}=$plain;	$packagetab{$short}=$plain;
}	}
}	}
	close($config);
}	}

# ------------- set up temporary directory	# ------------- set up temporary directory
Line 5175 dumps the complete (or key matching rege	Line 5269 dumps the complete (or key matching rege

=item *	=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	put($namespace,$storehash,$udom,$uname) : stores hash in namesp
($udom and $uname are optional)	($udom and $uname are optional)

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>

Removed from v.1.439
changed lines
	Added in v.1.450