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.435 and 1.460

version 1.435, 2003/10/30 00:26:25	version 1.460, 2004/01/12 19:53:54
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 367 sub userload {	Line 395 sub userload {
while ($filename=readdir(LONIDS)) {	while ($filename=readdir(LONIDS)) {
if ($filename eq '.' \|\| $filename eq '..') {next;}	if ($filename eq '.' \|\| $filename eq '..') {next;}
my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];	my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
if ($curtime-$mtime < 3600) { $numusers++; }	if ($curtime-$mtime < 1800) { $numusers++; }
}	}
closedir(LONIDS);	closedir(LONIDS);
}	}
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 477 sub changepass {	Line 506 sub changepass {

sub queryauthenticate {	sub queryauthenticate {
my ($uname,$udom)=@_;	my ($uname,$udom)=@_;
if (($perlvar{'lonRole'} eq 'library') &&	my $uhome=&homeserver($uname,$udom);
($udom eq $perlvar{'lonDefDomain'})) {	if (!$uhome) {
my $answer=reply("encrypt:currentauth:$udom:$uname",	&logthis("User $uname at $udom is unknown when looking for authentication mechanism");
$perlvar{'lonHostID'});	return 'no_host';
unless ($answer eq 'unknown_user' or $answer eq 'refused') {	}
if (length($answer)) {	my $answer=reply("encrypt:currentauth:$udom:$uname",$uhome);
return $answer;	if ($answer =~ /^(unknown_user\|refused\|con_lost)/) {
}	&logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
else {
&logthis("User $uname at $udom lacks an authentication mechanism");
return 'no_host';
}
}
}

my $tryserver;
foreach $tryserver (keys %libserv) {
if ($hostdom{$tryserver} eq $udom) {
my $answer=reply("encrypt:currentauth:$udom:$uname",$tryserver);
unless ($answer eq 'unknown_user' or $answer eq 'refused') {
if (length($answer)) {
return $answer;
}
else {
&logthis("User $uname at $udom lacks an authentication mechanism");
return 'no_host';
}
}
}
}	}
&logthis("User $uname at $udom lacks an authentication mechanism");	return $answer;
return 'no_host';
}	}

# --------- Try to authenticate user from domain's lib servers (first this one)	# --------- Try to authenticate user from domain's lib servers (first this one)
Line 819 sub getsection {	Line 826 sub getsection {
return '-1';	return '-1';
}	}


	my $disk_caching_disabled=1;

sub devalidate_cache {	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";	if ($disk_caching_disabled) { return; }
	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 887 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)=@_;
	if ($disk_caching_disabled) { return; }
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 939 sub save_cache_item {	Line 919 sub save_cache_item {

sub load_cache_item {	sub load_cache_item {
my ($cache,$name,$id)=@_;	my ($cache,$name,$id)=@_;
	if ($disk_caching_disabled) { return; }
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 1032 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 1045 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 1080 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 1145 sub ssi_body {	Line 1137 sub ssi_body {
my ($filelink,%form)=@_;	my ($filelink,%form)=@_;
my $output=($filelink=~/^http\:/?&externalssi($filelink):	my $output=($filelink=~/^http\:/?&externalssi($filelink):
&ssi($filelink,%form));	&ssi($filelink,%form));
$output=~s/^.\<body[^\>]\>//si;	$output=~s/^.?\<body[^\>]\>//si;
$output=~s/\<\/body\s\>.$//si;	$output=~s/(.)\<\/body\s\>.*?$/$1/si;
$output=~	$output=~
s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs;	s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs;
return $output;	return $output;
Line 1250 sub finishuserfileupload {	Line 1242 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 1318 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=$_;	if ($entry =~ /___count$/) {
$entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/;	my ($dom,$name);
my %temphash=($entry => $accesshash{$entry});	($dom,$name,undef)=($entry=~m:___(\w+)/(\w+)/(.*)___count$:);
if (&Apache::lonnet::put('nohist_resevaldata',\%temphash,$1,$2) eq 'ok') {	if (! defined($dom) \|\| $dom eq '' \|\|
delete $accesshash{$entry};	! defined($name) \|\| $name eq '') {
	my $cid = $ENV{'request.course.id'};
	$dom = $ENV{'request.'.$cid.'.domain'};
	$name = $ENV{'request.'.$cid.'.num'};
	}
	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 ($dom,$name) = ($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:);
	my %temphash=($entry => $accesshash{$entry});
	if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
	delete $accesshash{$entry};
	}
}	}
}	}
#	#
Line 1389 sub courseacclog {	Line 1405 sub courseacclog {

sub countacc {	sub countacc {
my $url=&declutter(shift);	my $url=&declutter(shift);
	return if (! defined($url) \|\| $url eq '');
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 1488 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 2005 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 2042 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 2379 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 2449 sub customaccess {	Line 2494 sub customaccess {

sub allowed {	sub allowed {
my ($priv,$uri)=@_;	my ($priv,$uri)=@_;
	$uri=&deversion($uri);
my $orguri=$uri;	my $orguri=$uri;
$uri=&declutter($uri);	$uri=&declutter($uri);

Line 2858 sub get_query_reply {	Line 2903 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 3085 sub modifyuser {	Line 3130 sub modifyuser {

sub modifystudent {	sub modifystudent {
my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,	my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
$end,$start,$forceid,$desiredhome,$email)=@_;	$end,$start,$forceid,$desiredhome,$email,$type,$cid)=@_;
my $cid='';	if (!$cid) {
unless ($cid=$ENV{'request.course.id'}) {	unless ($cid=$ENV{'request.course.id'}) {
return 'not_in_class';	return 'not_in_class';
	}
}	}
# --------------------------------------------------------------- Make the user	# --------------------------------------------------------------- Make the user
my $reply=&modifyuser	my $reply=&modifyuser
Line 3098 sub modifystudent {	Line 3144 sub modifystudent {
# This will cause &modify_student_enrollment to get the uid from the	# This will cause &modify_student_enrollment to get the uid from the
# students environment	# students environment
$uid = undef if (!$forceid);	$uid = undef if (!$forceid);
$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,	$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
$last,$gene,$usec,$end,$start);	$gene,$usec,$end,$start,$type,$cid);
return $reply;	return $reply;
}	}

sub modify_student_enrollment {	sub modify_student_enrollment {
my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start) = @_;	my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,
# Get the course id from the environment	$cid) = @_;
my $cid='';	my ($cdom,$cnum,$chome);
unless ($cid=$ENV{'request.course.id'}) {	if (!$cid) {
return 'not_in_class';	unless ($cid=$ENV{'request.course.id'}) {
	return 'not_in_class';
	}
	$cdom=$ENV{'course.'.$cid.'.domain'};
	$cnum=$ENV{'course.'.$cid.'.num'};
	} else {
	($cdom,$cnum)=split(/_/,$cid);
	}
	$chome=$ENV{'course.'.$cid.'.home'};
	if (!$chome) {
	$chome=&homeserver($cnum,$cdom);
}	}
	if (!$chome) { return 'unknown_course'; }
# Make sure the user exists	# Make sure the user exists
my $uhome=&homeserver($uname,$udom);	my $uhome=&homeserver($uname,$udom);
if (($uhome eq '') \|\| ($uhome eq 'no_host')) {	if (($uhome eq '') \|\| ($uhome eq 'no_host')) {
return 'error: no such user';	return 'error: no such user';
}	}
#
# Get student data if we were not given enough information	# Get student data if we were not given enough information
if (!defined($first) \|\| $first eq '' \|\|	if (!defined($first) \|\| $first eq '' \|\|
!defined($last) \|\| $last eq '' \|\|	!defined($last) \|\| $last eq '' \|\|
Line 3128 sub modify_student_enrollment {	Line 3184 sub modify_student_enrollment {
['firstname','middlename','lastname', 'generation','id']	['firstname','middlename','lastname', 'generation','id']
,$udom,$uname);	,$udom,$uname);

foreach (keys(%tmp)) {	#foreach (keys(%tmp)) {
&logthis("key $_ = ".$tmp{$_});	# &logthis("key $_ = ".$tmp{$_});
}	#}
$first = $tmp{'firstname'} if (!defined($first) \|\| $first eq '');	$first = $tmp{'firstname'} if (!defined($first) \|\| $first eq '');
$middle = $tmp{'middlename'} if (!defined($middle) \|\| $middle eq '');	$middle = $tmp{'middlename'} if (!defined($middle) \|\| $middle eq '');
$last = $tmp{'lastname'} if (!defined($last) \|\| $last eq '');	$last = $tmp{'lastname'} if (!defined($last) \|\| $last eq '');
Line 3139 sub modify_student_enrollment {	Line 3195 sub modify_student_enrollment {
}	}
my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene,	my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene,
$first,$middle);	$first,$middle);
my $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'.	my $value=&escape($uname.':'.$udom).'='.
$ENV{'course.'.$cid.'.num'}.':classlist:'.	&escape(join(':',$end,$start,$uid,$usec,$fullname,$type));
&escape($uname.':'.$udom).'='.	my $reply=critical('put:'.$cdom.':'.$cnum.':classlist:'.$value,$chome);
&escape(join(':',$end,$start,$uid,$usec,$fullname)),
$ENV{'course.'.$cid.'.home'});
unless (($reply eq 'ok') \|\| ($reply eq 'delayed')) {	unless (($reply eq 'ok') \|\| ($reply eq 'delayed')) {
return 'error: '.$reply;	return 'error: '.$reply;
}	}
Line 3635 sub EXT {	Line 3689 sub EXT {
my $hashid="$udom:$uname";	my $hashid="$udom:$uname";
my ($result,$cached)=&is_cached(\%userresdatacache,$hashid,	my ($result,$cached)=&is_cached(\%userresdatacache,$hashid,
'userres');	'userres');
if (!defined($cached)) {	if (!defined($cached)) {
my %resourcedata=&get('resourcedata',	my %resourcedata=&dump('resourcedata',$udom,$uname);
[$courselevelr,$courselevelm,
$courselevel],$udom,$uname);
$result=\%resourcedata;	$result=\%resourcedata;
&do_cache(\%userresdatacache,$hashid,$result,'userres');	&do_cache(\%userresdatacache,$hashid,$result,'userres');
}	}
Line 3651 sub EXT {	Line 3703 sub EXT {
if ($$result{$courselevel}) {	if ($$result{$courselevel}) {
return $$result{$courselevel}; }	return $$result{$courselevel}; }
} else {	} else {
if ($tmp!~/No such file/) {	#error 2 occurs when the .db doesn't exist
	if ($tmp!~/error: 2 /) {
&logthis("<font color=blue>WARNING:".	&logthis("<font color=blue>WARNING:".
" Trying to get resource data for ".	" Trying to get resource data for ".
$uname." at ".$udom.": ".	$uname." at ".$udom.": ".
$tmp."</font>");	$tmp."</font>");
} elsif ($tmp=~/error:No such file/) {	} elsif ($tmp=~/error: 2 /) {
&EXT_cache_set($udom,$uname);	&EXT_cache_set($udom,$uname);
} elsif ($tmp =~ /^(con_lost\|no_such_host)/) {	} elsif ($tmp =~ /^(con_lost\|no_such_host)/) {
return $tmp;	return $tmp;
Line 3787 sub metadata {	Line 3840 sub metadata {
#	#
# Is this a recursive call for a library?	# Is this a recursive call for a library?
#	#
my %lcmetacache;	if (! exists($metacache{$uri})) {
	$metacache{$uri}={};
	}
if ($liburi) {	if ($liburi) {
$liburi=&declutter($liburi);	$liburi=&declutter($liburi);
$filename=$liburi;	$filename=$liburi;
Line 3811 sub metadata {	Line 3866 sub metadata {
if (defined($token->[2]->{'id'})) {	if (defined($token->[2]->{'id'})) {
$keyroot.='_'.$token->[2]->{'id'};	$keyroot.='_'.$token->[2]->{'id'};
}	}
if ($lcmetacache{':packages'}) {	if ($metacache{$uri}->{':packages'}) {
$lcmetacache{':packages'}.=','.$package.$keyroot;	$metacache{$uri}->{':packages'}.=','.$package.$keyroot;
} else {	} else {
$lcmetacache{':packages'}=$package.$keyroot;	$metacache{$uri}->{':packages'}=$package.$keyroot;
}	}
foreach (keys %packagetab) {	foreach (keys %packagetab) {
my $part=$keyroot;	my $part=$keyroot;
Line 3836 sub metadata {	Line 3891 sub metadata {
if ($subp eq 'display') {	if ($subp eq 'display') {
$value.=' [Part: '.$part.']';	$value.=' [Part: '.$part.']';
}	}
$lcmetacache{':'.$unikey.'.part'}=$part;	$metacache{$uri}->{':'.$unikey.'.part'}=$part;
$metathesekeys{$unikey}=1;	$metathesekeys{$unikey}=1;
unless (defined($lcmetacache{':'.$unikey.'.'.$subp})) {	unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) {
$lcmetacache{':'.$unikey.'.'.$subp}=$value;	$metacache{$uri}->{':'.$unikey.'.'.$subp}=$value;
}	}
if (defined($lcmetacache{':'.$unikey.'.default'})) {	if (defined($metacache{$uri}->{':'.$unikey.'.default'})) {
$lcmetacache{':'.$unikey}=	$metacache{$uri}->{':'.$unikey}=
$lcmetacache{':'.$unikey.'.default'};	$metacache{$uri}->{':'.$unikey.'.default'};
}	}
}	}
}	}
Line 3876 sub metadata {	Line 3931 sub metadata {
foreach (sort(split(/\,/,&metadata($uri,'keys',	foreach (sort(split(/\,/,&metadata($uri,'keys',
$location,$unikey,	$location,$unikey,
$depthcount+1)))) {	$depthcount+1)))) {
	$metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_};
$metathesekeys{$_}=1;	$metathesekeys{$_}=1;
}	}
}	}
Line 3886 sub metadata {	Line 3942 sub metadata {
}	}
$metathesekeys{$unikey}=1;	$metathesekeys{$unikey}=1;
foreach (@{$token->[3]}) {	foreach (@{$token->[3]}) {
$lcmetacache{':'.$unikey.'.'.$_}=$token->[2]->{$_};	$metacache{$uri}->{':'.$unikey.'.'.$_}=$token->[2]->{$_};
}	}
my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));	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$/) {	if ( $internaltext =~ /^\s$/ && $default !~ /^\s$/) {
# only ws inside the tag, and not in default, so use default	# only ws inside the tag, and not in default, so use default
# as value	# as value
$lcmetacache{':'.$unikey}=$default;	$metacache{$uri}->{':'.$unikey}=$default;
} else {	} else {
# either something interesting inside the tag or default	# either something interesting inside the tag or default
# uninteresting	# uninteresting
$lcmetacache{':'.$unikey}=$internaltext;	$metacache{$uri}->{':'.$unikey}=$internaltext;
}	}
# end of not-a-package not-a-library import	# end of not-a-package not-a-library import
}	}
Line 3907 sub metadata {	Line 3963 sub metadata {
}	}
}	}
# are there custom rights to evaluate	# are there custom rights to evaluate
if ($lcmetacache{':copyright'} eq 'custom') {	if ($metacache{$uri}->{':copyright'} eq 'custom') {

#	#
# Importing a rights file here	# Importing a rights file here
#	#
unless ($depthcount) {	unless ($depthcount) {
my $location=$lcmetacache{':customdistributionfile'};	my $location=$metacache{$uri}->{':customdistributionfile'};
my $dir=$filename;	my $dir=$filename;
$dir=~s\|[^/]*$\|\|;	$dir=~s\|[^/]*$\|\|;
$location=&filelocation($dir,$location);	$location=&filelocation($dir,$location);
foreach (sort(split(/\,/,&metadata($uri,'keys',	foreach (sort(split(/\,/,&metadata($uri,'keys',
$location,'_rights',	$location,'_rights',
$depthcount+1)))) {	$depthcount+1)))) {
	$metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_};
$metathesekeys{$_}=1;	$metathesekeys{$_}=1;
}	}
}	}
}	}
$lcmetacache{':keys'}=join(',',keys %metathesekeys);	$metacache{$uri}->{':keys'}=join(',',keys %metathesekeys);
&metadata_generate_part0(\%metathesekeys,\%lcmetacache,$uri);	&metadata_generate_part0(\%metathesekeys,$metacache{$uri},$uri);
$lcmetacache{':allpossiblekeys'}=join(',',keys %metathesekeys);	$metacache{$uri}->{':allpossiblekeys'}=join(',',keys %metathesekeys);
&do_cache(\%metacache,$uri,\%lcmetacache,'meta');	&do_cache(\%metacache,$uri,$metacache{$uri},'meta');
# this is the end of "was not already recently cached	# this is the end of "was not already recently cached
}	}
return $metacache{$uri}->{':'.$what};	return $metacache{$uri}->{':'.$what};
Line 3993 sub gettitle {	Line 4050 sub gettitle {

sub symblist {	sub symblist {
my ($mapname,%newhash)=@_;	my ($mapname,%newhash)=@_;
$mapname=declutter($mapname);	$mapname=&deversion(&declutter($mapname));
my %hash;	my %hash;
if (($ENV{'request.course.fn'}) && (%newhash)) {	if (($ENV{'request.course.fn'}) && (%newhash)) {
if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',	if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
&GDBM_WRCREAT(),0640)) {	&GDBM_WRCREAT(),0640)) {
foreach (keys %newhash) {	foreach (keys %newhash) {
$hash{declutter($_)}=$mapname.'___'.$newhash{$_};	$hash{declutter($_)}=$mapname.'___'.&deversion($newhash{$_});
}	}
if (untie(%hash)) {	if (untie(%hash)) {
return 'ok';	return 'ok';
Line 4013 sub symblist {	Line 4070 sub symblist {

sub symbverify {	sub symbverify {
my ($symb,$thisfn)=@_;	my ($symb,$thisfn)=@_;
$thisfn=&symbclean(&declutter($thisfn));	$thisfn=&declutter($thisfn);
# direct jump to resource in page or to a sequence - will construct own symbs	# direct jump to resource in page or to a sequence - will construct own symbs
if ($thisfn=~/\.(page\|sequence)$/) { return 1; }	if ($thisfn=~/\.(page\|sequence)$/) { return 1; }
# check URL part	# check URL part
my ($map,$resid,$url)=&decode_symb($symb);	my ($map,$resid,$url)=&decode_symb($symb);

unless ($url eq $thisfn) { return 0; }	unless ($url eq $thisfn) { return 0; }

$symb=&symbclean($symb);	$symb=&symbclean($symb);
	$thisfn=&deversion($thisfn);

my %bighash;	my %bighash;
my $okay=0;	my $okay=0;
Line 4078 sub fixversion {	Line 4137 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 {
	my $url=shift;
	$url=~s/\.\d+\.(\w+)$/\.$1/;
	return $url;
}	}

# ------------------------------------------------------ Return symb list entry	# ------------------------------------------------------ Return symb list entry
Line 4188 sub numval {	Line 4261 sub numval {
}	}

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

sub rndseed {	sub rndseed {
Line 4205 sub rndseed {	Line 4278 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 4248 sub rndseed_64bit {	Line 4323 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 4311 sub getfile {	Line 4408 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 4343 sub filelocation {	Line 4441 sub filelocation {

sub hreflocation {	sub hreflocation {
my ($dir,$file)=@_;	my ($dir,$file)=@_;
unless (($file=~/^http:\/\//i) \|\| ($file=~/^\//)) {	unless (($file=~m-^http://-i) \|\| ($file=~m-^/-)) {
my $finalpath=filelocation($dir,$file);	my $finalpath=filelocation($dir,$file);
$finalpath=~s/^\/home\/httpd\/html//;	$finalpath=~s-^/home/httpd/html--;
$finalpath=~s-/home/(\w+)/public_html/-/~$1/-;	$finalpath=~s-/home/(\w+)/public_html/-/~$1/-;
return $finalpath;	return $finalpath;
} else {	} elsif ($file=~m-^/home-) {
return $file;	$file=~s-^/home/httpd/html--;
	$file=~s-/home/(\w+)/public_html/-/~$1/-;
	return $file;
}	}
}	}

Line 4396 sub mod_perl_version {	Line 4496 sub mod_perl_version {
}	}
return 1;	return 1;
}	}

	sub correct_line_ends {
	my ($result)=@_;
	$$result =~s/\r\n/\n/mg;
	$$result =~s/\r/\n/mg;
	}
# ================================================================ Main Program	# ================================================================ Main Program

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 4419 BEGIN {	Line 4527 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 4428 BEGIN {	Line 4536 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 4439 BEGIN {	Line 4548 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 4463 BEGIN {	Line 4572 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 4490 BEGIN {	Line 4600 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 4502 BEGIN {	Line 4613 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 5160 dumps the complete (or key matching rege	Line 5275 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.435
changed lines
	Added in v.1.460