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.397 and 1.488

version 1.397, 2003/08/06 16:43:36	version 1.488, 2004/04/23 19:36:46
Line 25	Line 25
#	#
# http://www.lon-capa.org/	# 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;	package Apache::lonnet;

use strict;	use strict;
use Apache::File;
use LWP::UserAgent();	use LWP::UserAgent();
use HTTP::Headers;	use HTTP::Headers;
	use HTTP::Date;
	# use Date::Parse;
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
%domaindescription %domain_auth_def %domain_auth_arg_def $tmpdir);	%userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def
	%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir);

use IO::Socket;	use IO::Socket;
use GDBM_File;	use GDBM_File;
use Apache::Constants qw(:common :http);	use Apache::Constants qw(:common :http);
use HTML::LCParser;	use HTML::LCParser;
use Fcntl qw(:flock);	use Fcntl qw(:flock);
use Apache::loncoursedata;	use Apache::loncoursedata;
	use Apache::lonlocal;
	use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw);
	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 103 sub logthis {	Line 93 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 113 sub logperm {	Line 105 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 166 sub reconlonc {	Line 160 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 214 sub critical {	Line 208 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 243 sub critical {	Line 239 sub critical {
}	}
return $answer;	return $answer;
}	}

	#
	# -------------- Remove all key from the env that start witha lowercase letter
	# (Which is always a lon-capa value)

	sub cleanenv {
	# unless (defined(&Apache::exists_config_define("MODPERL2"))) { return; }
	# unless (&Apache::exists_config_define("MODPERL2")) { return; }
	foreach my $key (keys(%ENV)) {
	if ($key =~ /^[a-z]/) {
	delete($ENV{$key});
	}
	}
	}

# ------------------------------------------- Transfer profile into environment	# ------------------------------------------- Transfer profile into environment

Line 250 sub transfer_profile_to_env {	Line 260 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;
for ($envi=0;$envi<=$#profile;$envi++) {	for ($envi=0;$envi<=$#profile;$envi++) {
chomp($profile[$envi]);	chomp($profile[$envi]);
my ($envname,$envvalue)=split(/=/,$profile[$envi]);	my ($envname,$envvalue)=split(/=/,$profile[$envi]);
$ENV{$envname} = $envvalue;	$ENV{$envname} = $envvalue;
	if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
	if ($time < time-300) {
	$Remove{$key}++;
	}
	}
}	}
$ENV{'user.environment'} = "$lonidsdir/$handle.id";	$ENV{'user.environment'} = "$lonidsdir/$handle.id";
	foreach my $expired_key (keys(%Remove)) {
	&delenv($expired_key);
	}
}	}

# ---------------------------------------------------------- Append Environment	# ---------------------------------------------------------- Append Environment
Line 280 sub appenv {	Line 299 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 335 sub delenv {	Line 354 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 $_; }	if ($_=~/^$delthis/) {
}	my ($key,undef) = split('=',$_);
$fh->close();	delete($ENV{$key});
	} else {
	print $fh $_;
	}
	}
	close($fh);
}	}
return 'ok';	return 'ok';
}	}
Line 377 sub userload {	Line 401 sub userload {
my $curtime=time;	my $curtime=time;
while ($filename=readdir(LONIDS)) {	while ($filename=readdir(LONIDS)) {
if ($filename eq '.' \|\| $filename eq '..') {next;}	if ($filename eq '.' \|\| $filename eq '..') {next;}
my ($atime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[8];	my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
if ($curtime-$atime < 3600) { $numusers++; }	if ($curtime-$mtime < 1800) { $numusers++; }
}	}
closedir(LONIDS);	closedir(LONIDS);
}	}
Line 398 sub overloaderror {	Line 422 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 424 sub spareserver {	Line 449 sub spareserver {
my $lowestserver=$loadpercent > $userloadpercent?	my $lowestserver=$loadpercent > $userloadpercent?
$loadpercent : $userloadpercent;	$loadpercent : $userloadpercent;
foreach $tryserver (keys %spareid) {	foreach $tryserver (keys %spareid) {
my $loadans=reply('load',$tryserver);	my $loadans=reply('load',$tryserver);
my $userloadans=reply('userload',$tryserver);	my $userloadans=reply('userload',$tryserver);
if ($userloadans !~ /\d/) { $userloadans=0; }	if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
my $answer=$loadans > $userloadans?	next; #didn't get a number from the server
$loadans : $userloadans;	}
if (($answer =~ /\d/) && ($answer<$lowestserver)) {	my $answer;
$spareserver="http://$hostname{$tryserver}";	if ($loadans =~ /\d/) {
$lowestserver=$answer;	if ($userloadans =~ /\d/) {
}	#both are numbers, pick the bigger one
	$answer=$loadans > $userloadans?
	$loadans : $userloadans;
	} else {
	$answer = $loadans;
	}
	} else {
	$answer = $userloadans;
	}
	if (($answer =~ /\d/) && ($answer<$lowestserver)) {
	$spareserver="http://$hostname{$tryserver}";
	$lowestserver=$answer;
	}
}	}
return $spareserver;	return $spareserver;
}	}
Line 476 sub changepass {	Line 513 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 516 sub authenticate {	Line 531 sub authenticate {
my ($uname,$upass,$udom)=@_;	my ($uname,$upass,$udom)=@_;
$upass=escape($upass);	$upass=escape($upass);
$uname=~s/\W//g;	$uname=~s/\W//g;
if (($perlvar{'lonRole'} eq 'library') &&	my $uhome=&homeserver($uname,$udom);
($udom eq $perlvar{'lonDefDomain'})) {	if (!$uhome) {
my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'});	&logthis("User $uname at $udom is unknown in authenticate");
if ($answer =~ /authorized/) {	return 'no_host';
if ($answer eq 'authorized') {	}
&logthis("User $uname at $udom authorized by local server");	my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome);
return $perlvar{'lonHostID'};	if ($answer eq 'authorized') {
}	&logthis("User $uname at $udom authorized by $uhome");
if ($answer eq 'non_authorized') {	return $uhome;
&logthis("User $uname at $udom rejected by local server");	}
return 'no_host';	if ($answer eq 'non_authorized') {
}	&logthis("User $uname at $udom rejected by $uhome");
}	return 'no_host';
}

my $tryserver;
foreach $tryserver (keys %libserv) {
if ($hostdom{$tryserver} eq $udom) {
my $answer=reply("encrypt:auth:$udom:$uname:$upass",$tryserver);
if ($answer =~ /authorized/) {
if ($answer eq 'authorized') {
&logthis("User $uname at $udom authorized by $tryserver");
return $tryserver;
}
if ($answer eq 'non_authorized') {
&logthis("User $uname at $udom rejected by $tryserver");
return 'no_host';
}
}
}
}	}
&logthis("User $uname at $udom could not be authenticated");	&logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
return 'no_host';	return 'no_host';
}	}

Line 556 sub authenticate {	Line 554 sub authenticate {
sub homeserver {	sub homeserver {
my ($uname,$udom,$ignoreBadCache)=@_;	my ($uname,$udom,$ignoreBadCache)=@_;
my $index="$uname:$udom";	my $index="$uname:$udom";
if ($homecache{$index}) {
return "$homecache{$index}";	my ($result,$cached)=&is_cached(\%homecache,$index,'home',86400);
}	if (defined($cached)) { return $result; }
my $tryserver;	my $tryserver;
foreach $tryserver (keys %libserv) {	foreach $tryserver (keys %libserv) {
next if ($ignoreBadCache ne 'true' &&	next if ($ignoreBadCache ne 'true' &&
Line 566 sub homeserver {	Line 564 sub homeserver {
if ($hostdom{$tryserver} eq $udom) {	if ($hostdom{$tryserver} eq $udom) {
my $answer=reply("home:$udom:$uname",$tryserver);	my $answer=reply("home:$udom:$uname",$tryserver);
if ($answer eq 'found') {	if ($answer eq 'found') {
$homecache{$index}=$tryserver;	return &do_cache(\%homecache,$index,$tryserver,'home');
return $tryserver;
} elsif ($answer eq 'no_host') {	} elsif ($answer eq 'no_host') {
$badServerCache{$tryserver}=1;	$badServerCache{$tryserver}=1;
}	}
Line 620 sub idput {	Line 617 sub idput {
my ($udom,%ids)=@_;	my ($udom,%ids)=@_;
my %servers=();	my %servers=();
foreach (keys %ids) {	foreach (keys %ids) {
	&cput('environment',{'id'=>$ids{$_}},$udom,$_);
my $uhom=&homeserver($_,$udom);	my $uhom=&homeserver($_,$udom);
if ($uhom ne 'no_host') {	if ($uhom ne 'no_host') {
my $id=&escape($ids{$_});	my $id=&escape($ids{$_});
Line 630 sub idput {	Line 628 sub idput {
} else {	} else {
$servers{$uhom}=$id.'='.$unam;	$servers{$uhom}=$id.'='.$unam;
}	}
&critical('put:'.$udom.':'.$unam.':environment:id='.$id,$uhom);
}	}
}	}
foreach (keys %servers) {	foreach (keys %servers) {
Line 654 sub assign_access_key {	Line 651 sub assign_access_key {
$uname=$ENV{'user.domain'} unless (defined($uname));	$uname=$ENV{'user.domain'} unless (defined($uname));
my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);	my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
if (($existing{$ckey}=~/^\#(.*)$/) \|\| # - new key	if (($existing{$ckey}=~/^\#(.*)$/) \|\| # - new key
($existing{$ckey}=~/^$uname\:$udom\#(.*)$/)) {	($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#(.*)$/)) {
# assigned to this person	# assigned to this person
# - this should not happen,	# - this should not happen,
# unless something went wrong	# unless something went wrong
Line 761 sub validate_access_key {	Line 758 sub validate_access_key {
$udom=$ENV{'user.name'} unless (defined($udom));	$udom=$ENV{'user.name'} unless (defined($udom));
$uname=$ENV{'user.domain'} unless (defined($uname));	$uname=$ENV{'user.domain'} unless (defined($uname));
my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);	my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
return ($existing{$ckey}=~/^$uname\:$udom\#/);	return ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#/);
}	}

# ------------------------------------- Find the section of student in a course	# ------------------------------------- Find the section of student in a course
Line 789 sub getsection {	Line 786 sub getsection {
&homeserver($unam,$udom)))) {	&homeserver($unam,$udom)))) {
my ($key,$value)=split(/\=/,$_);	my ($key,$value)=split(/\=/,$_);
$key=&unescape($key);	$key=&unescape($key);
next if ($key !~/^$courseid(?:\/)(\w+)\_st$/);	next if ($key !~/^\Q$courseid\E(?:\/)(\w+)\_st$/);
my $section=$1;	my $section=$1;
if ($key eq $courseid.'_st') { $section=''; }	if ($key eq $courseid.'_st') { $section=''; }
my ($dummy,$end,$start)=split(/\_/,&unescape($value));	my ($dummy,$end,$start)=split(/\_/,&unescape($value));
Line 819 sub getsection {	Line 816 sub getsection {
return '-1';	return '-1';
}	}


	my $disk_caching_disabled=1;

	sub devalidate_cache {
	my ($cache,$id,$name) = @_;
	delete $$cache{$id.'.time'};
	delete $$cache{$id};
	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)) {
	eval <<'EVALBLOCK';
	delete($hash{$id});
	delete($hash{$id.'.time'});
	EVALBLOCK
	if ($@) {
	&logthis("<font color='red'>devalidate_cache blew up :$@:$name</font>");
	unlink($filename);
	}
	} else {
	if (-e $filename) {
	&logthis("Unable to tie hash (devalidate cache): $name");
	unlink($filename);
	}
	}
	untie(%hash);
	flock(DB,LOCK_UN);
	close(DB);
	}

	sub is_cached {
	my ($cache,$id,$name,$time) = @_;
	if (!$time) { $time=300; }
	if (!exists($$cache{$id.'.time'})) {
	&load_cache_item($cache,$name,$id);
	}
	if (!exists($$cache{$id.'.time'})) {
	# &logthis("Didn't find $id");
	return (undef,undef);
	} else {
	if (time-($$cache{$id.'.time'})>$time) {
	# &logthis("Devalidating $id - ".time-($$cache{$id.'.time'}));
	&devalidate_cache($cache,$id,$name);
	return (undef,undef);
	}
	}
	return ($$cache{$id},1);
	}

	sub do_cache {
	my ($cache,$id,$value,$name) = @_;
	$$cache{$id.'.time'}=time;
	$$cache{$id}=$value;
	# &logthis("Caching $id as :$value:");
	&save_cache_item($cache,$name,$id);
	# do_cache implictly return the set value
	$$cache{$id};
	}

	sub save_cache_item {
	my ($cache,$name,$id)=@_;
	if ($disk_caching_disabled) { return; }
	my $starttime=&Time::HiRes::time();
	# &logthis("Saving :$name:$id");
	my %hash;
	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)) {
	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 {
	if (-e $filename) {
	&logthis("Unable to tie hash (save cache item): $name ($!)");
	unlink($filename);
	}
	}
	untie(%hash);
	flock(DB,LOCK_UN);
	close(DB);
	# &logthis("save_cache_item $name took ".(&Time::HiRes::time()-$starttime));
	}

	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/lonnet_internal_cache_'.$name.".db";
	open(DB,"$filename.lock");
	flock(DB,LOCK_SH);
	if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) {
	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'};
	}
	EVALBLOCK
	if ($@) {
	&logthis("<font color='red'>load_cache blew up :$@:$name</font>");
	unlink($filename);
	}
	} else {
	if (-e $filename) {
	&logthis("Unable to tie hash (load cache item): $name ($!)");
	unlink($filename);
	}
	}
	untie(%hash);
	flock(DB,LOCK_UN);
	close(DB);
	# &logthis("After Loading $name size is ".scalar(%$cache));
	# &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime));
	}

sub usection {	sub usection {
my ($udom,$unam,$courseid)=@_;	my ($udom,$unam,$courseid)=@_;
	my $hashid="$udom:$unam:$courseid";

	my ($result,$cached)=&is_cached(\%usectioncache,$hashid,'usection');
	if (defined($cached)) { return $result; }
$courseid=~s/\_/\//g;	$courseid=~s/\_/\//g;
$courseid=~s/^(\w)/\/$1/;	$courseid=~s/^(\w)/\/$1/;
foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',	foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
&homeserver($unam,$udom)))) {	&homeserver($unam,$udom)))) {
my ($key,$value)=split(/\=/,$_);	my ($key,$value)=split(/\=/,$_);
$key=&unescape($key);	$key=&unescape($key);
if ($key=~/^$courseid(?:\/)(\w+)\_st$/) {	if ($key=~/^\Q$courseid\E(?:\/)(\w+)\_st$/) {
my $section=$1;	my $section=$1;
if ($key eq $courseid.'_st') { $section=''; }	if ($key eq $courseid.'_st') { $section=''; }
my ($dummy,$end,$start)=split(/\_/,&unescape($value));	my ($dummy,$end,$start)=split(/\_/,&unescape($value));
Line 839 sub usection {	Line 977 sub usection {
if ($end) {	if ($end) {
if ($now>$end) { $notactive=1; }	if ($now>$end) { $notactive=1; }
}	}
unless ($notactive) { return $section; }	unless ($notactive) {
	return &do_cache(\%usectioncache,$hashid,$section,'usection');
	}
}	}
}	}
return '-1';	return &do_cache(\%usectioncache,$hashid,'-1','usection');
}	}

# ------------------------------------- Read an entry from a user's environment	# ------------------------------------- Read an entry from a user's environment
Line 882 sub getversion {	Line 1022 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 893 sub currentversion {	Line 1035 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 928 sub repcopy {	Line 1070 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 985 sub ssi_body {	Line 1127 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 1031 sub tokenwrapper {	Line 1173 sub tokenwrapper {
$uri=~s/^\///;	$uri=~s/^\///;
$ENV{'user.environment'}=~/\/([^\/]+)\.id/;	$ENV{'user.environment'}=~/\/([^\/]+)\.id/;
my $token=$1;	my $token=$1;
if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.)$/) {	# if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.)$/) {
	if ($uri=~m\|^uploaded/([^/]+)/([^/]+)/(.+)(\?\.)$\|) {
&appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});	&appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});
return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.	return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.
(($uri=~/\?/)?'&':'?').'token='.$token.	(($uri=~/\?/)?'&':'?').'token='.$token.
Line 1040 sub tokenwrapper {	Line 1183 sub tokenwrapper {
return '/adm/notfound.html';	return '/adm/notfound.html';
}	}
}	}

	# --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
	# input: action, courseID, current domain, home server for course, intended
	# path to file, source of file.
	# output: url to file (if action was uploaddoc),
	# ok if successful, or diagnostic message otherwise (if action was propagate or copy)
	#
	# Allows directory structure to be used within lonUsers/../userfiles/ for a
	# course.
	#
	# action = propagate - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
	# will be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles in
	# course's home server.
	#
	# action = copy - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file will
	# be copied from $source (current location) to
	# /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
	# and will then be copied to
	# /home/httpd/lonUsers/$domain/1/2/3/$course/userfiles/$file in
	# course's home server.
	#
	# action = uploaddoc - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
	# will be retrived from $ENV{form.uploaddoc} (from DOCS interface) to
	# /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
	# and will then be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles/$file
	# in course's home server.


	sub process_coursefile {
	my ($action,$docuname,$docudom,$docuhome,$file,$source)=@_;
	my $fetchresult;
	if ($action eq 'propagate') {
	$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file
	,$docuhome);
	} else {
	my $fetchresult = '';
	my $fpath = '';
	my $fname = $file;
	($fpath,$fname) = ($file =~ m\|^(.*)/([^/]+)$\|);
	$fpath=$docudom.'/'.$docuname.'/'.$fpath;
	my $filepath=$perlvar{'lonDocRoot'}.'/userfiles';
	unless ($fpath eq '') {
	my @parts=split('/',$fpath);
	foreach my $part (@parts) {
	$filepath.= '/'.$part;
	if ((-e $filepath)!=1) {
	mkdir($filepath,0777);
	}
	}
	}
	if ($action eq 'copy') {
	if ($source eq '') {
	$fetchresult = 'no source file';
	return $fetchresult;
	} else {
	my $destination = $filepath.'/'.$fname;
	rename($source,$destination);
	$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
	$docuhome);
	}
	} elsif ($action eq 'uploaddoc') {
	open(my $fh,'>'.$filepath.'/'.$fname);
	print $fh $ENV{'form.'.$source};
	close($fh);
	$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
	$docuhome);
	if ($fetchresult eq 'ok') {
	return '/uploaded/'.$fpath.'/'.$fname;
	} else {
	&logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
	' to host '.$docuhome.': '.$fetchresult);
	return '/adm/notfound.html';
	}
	}
	}
	unless ( $fetchresult eq 'ok') {
	&logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
	' to host '.$docuhome.': '.$fetchresult);
	}
	return $fetchresult;
	}

# --------------- Take an uploaded file and put it into the userfiles directory	# --------------- Take an uploaded file and put it into the userfiles directory
# input: name of form element, coursedoc=1 means this is for the course	# input: name of form element, coursedoc=1 means this is for the course
# output: url of file in userspace	# output: url of file in userspace
Line 1067 sub userfileupload {	Line 1291 sub userfileupload {
$docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'};	$docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'};
$docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'};	$docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'};
$docuhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};	$docuhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
	if ($ENV{'form.folder'} =~ m/^default/) {
	return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);
	} else {
	$fname=$ENV{'form.folder'}.'/'.$fname;
	return &process_coursefile('uploaddoc',$docuname,$docudom,$docuhome,$fname,$formname);
	}
} else {	} else {
$docuname=$ENV{'user.name'};	$docuname=$ENV{'user.name'};
$docudom=$ENV{'user.domain'};	$docudom=$ENV{'user.domain'};
$docuhome=$ENV{'user.home'};	$docuhome=$ENV{'user.home'};
	return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);
}	}
return
&finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);
}	}

sub finishuserfileupload {	sub finishuserfileupload {
Line 1090 sub finishuserfileupload {	Line 1319 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
#	#
	my $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,
my $fetchresult=	$docuhome);
&reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome);
if ($fetchresult eq 'ok') {	if ($fetchresult eq 'ok') {
#	#
# Return the URL to it	# Return the URL to it
Line 1165 sub flushcourselogs {	Line 1394 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 1216 sub courseacclog {	Line 1468 sub courseacclog {
my $fnsymb=shift;	my $fnsymb=shift;
unless ($ENV{'request.course.id'}) { return ''; }	unless ($ENV{'request.course.id'}) { return ''; }
my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'};	my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'};
if ($fnsymb=~/(problem\|exam\|quiz\|assess\|survey\|form)$/) {	if ($fnsymb=~/(problem\|exam\|quiz\|assess\|survey\|form\|page)$/) {
$what.=':POST';	$what.=':POST';
foreach (keys %ENV) {	foreach (keys %ENV) {
if ($_=~/^form\.(.*)/) {	if ($_=~/^form\.(.*)/) {
Line 1229 sub courseacclog {	Line 1481 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 1251 sub userrolelog {	Line 1500 sub userrolelog {
my ($trole,$username,$domain,$area,$tstart,$tend)=@_;	my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
if (($trole=~/^ca/) \|\| ($trole=~/^in/) \|\|	if (($trole=~/^ca/) \|\| ($trole=~/^in/) \|\|
($trole=~/^cc/) \|\| ($trole=~/^ep/) \|\|	($trole=~/^cc/) \|\| ($trole=~/^ep/) \|\|
($trole=~/^cr/)) {	($trole=~/^cr/) \|\| ($trole=~/^ta/)) {
my (undef,$rudom,$runame,$rsec)=split(/\//,$area);	my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
$userrolehash	$userrolehash
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}	{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
Line 1263 sub get_course_adv_roles {	Line 1512 sub get_course_adv_roles {
my $cid=shift;	my $cid=shift;
$cid=$ENV{'request.course.id'} unless (defined($cid));	$cid=$ENV{'request.course.id'} unless (defined($cid));
my %coursehash=&coursedescription($cid);	my %coursehash=&coursedescription($cid);
	my %nothide=();
	foreach (split(/\s\,\s/,$coursehash{'nothideprivileged'})) {
	$nothide{join(':',split(/[\@\:]/,$_))}=1;
	}
my %returnhash=();	my %returnhash=();
my %dumphash=	my %dumphash=
&dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});	&dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
Line 1273 sub get_course_adv_roles {	Line 1526 sub get_course_adv_roles {
if (($tend) && ($tend<$now)) { next; }	if (($tend) && ($tend<$now)) { next; }
if (($tstart) && ($now<$tstart)) { next; }	if (($tstart) && ($now<$tstart)) { next; }
my ($role,$username,$domain,$section)=split(/\:/,$_);	my ($role,$username,$domain,$section)=split(/\:/,$_);
	if ((&privileged($username,$domain)) &&
	(!$nothide{$username.':'.$domain})) { next; }
my $key=&plaintext($role);	my $key=&plaintext($role);
if ($section) { $key.=' (Sec/Grp '.$section.')'; }	if ($section) { $key.=' (Sec/Grp '.$section.')'; }
if ($returnhash{$key}) {	if ($returnhash{$key}) {
Line 1284 sub get_course_adv_roles {	Line 1539 sub get_course_adv_roles {
return %returnhash;	return %returnhash;
}	}

	sub get_my_roles {
	my ($uname,$udom)=@_;
	unless (defined($uname)) { $uname=$ENV{'user.name'}; }
	unless (defined($udom)) { $udom=$ENV{'user.domain'}; }
	my %dumphash=
	&dump('nohist_userroles',$udom,$uname);
	my %returnhash=();
	my $now=time;
	foreach (keys %dumphash) {
	my ($tend,$tstart)=split(/\:/,$dumphash{$_});
	if (($tstart) && ($tstart<0)) { next; }
	if (($tend) && ($tend<$now)) { next; }
	if (($tstart) && ($now<$tstart)) { next; }
	my ($role,$username,$domain,$section)=split(/\:/,$_);
	$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
	}
	return %returnhash;
	}

	# ----------------------------------------------------- Frontpage Announcements
	#
	#

	sub postannounce {
	my ($server,$text)=@_;
	unless (&allowed('psa',$hostdom{$server})) { return 'refused'; }
	unless ($text=~/\w/) { $text=''; }
	return &reply('setannounce:'.&escape($text),$server);
	}

	sub getannounce {

	if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) {
	my $announcement='';
	while (<$fh>) { $announcement .=$_; }
	close($fh);
	if ($announcement=~/\w/) {
	return
	'<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'.
	'<tr><td bgcolor="#FFFFFF"><pre>'.$announcement.'</pre></td></tr></table>';
	} else {
	return '';
	}
	} else {
	return '';
	}
	}

# ---------------------------------------------------------- Course ID routines	# ---------------------------------------------------------- Course ID routines
# Deal with domain's nohist_courseid.db files	# Deal with domain's nohist_courseid.db files
#	#
Line 1784 sub store {	Line 2087 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 1817 sub cstore {	Line 2124 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 1899 sub coursedescription {	Line 2209 sub coursedescription {
return %returnhash;	return %returnhash;
}	}

	# -------------------------------------------------See if a user is privileged

	sub privileged {
	my ($username,$domain)=@_;
	my $rolesdump=&reply("dump:$domain:$username:roles",
	&homeserver($username,$domain));
	if (($rolesdump eq 'con_lost') \|\| ($rolesdump eq '')) { return 0; }
	my $now=time;
	if ($rolesdump ne '') {
	foreach (split(/&/,$rolesdump)) {
	if ($_!~/^rolesdef\&/) {
	my ($area,$role)=split(/=/,$_);
	$area=~s/\_\w\w$//;
	my ($trole,$tend,$tstart)=split(/_/,$role);
	if (($trole eq 'dc') \|\| ($trole eq 'su')) {
	my $active=1;
	if ($tend) {
	if ($tend<$now) { $active=0; }
	}
	if ($tstart) {
	if ($tstart>$now) { $active=0; }
	}
	if ($active) { return 1; }
	}
	}
	}
	}
	return 0;
	}

# -------------------------------------------------------- Get user privileges	# -------------------------------------------------------- Get user privileges

sub rolesinit {	sub rolesinit {
Line 2077 sub dump {	Line 2417 sub dump {
return %returnhash;	return %returnhash;
}	}

	# -------------------------------------------------------------- keys interface

	sub getkeys {
	my ($namespace,$udomain,$uname)=@_;
	if (!$udomain) { $udomain=$ENV{'user.domain'}; }
	if (!$uname) { $uname=$ENV{'user.name'}; }
	my $uhome=&homeserver($uname,$udomain);
	my $rep=reply("keys:$udomain:$uname:$namespace",$uhome);
	my @keyarray=();
	foreach (split(/\&/,$rep)) {
	push (@keyarray,&unescape($_));
	}
	return @keyarray;
	}

# --------------------------------------------------------------- currentdump	# --------------------------------------------------------------- currentdump
sub currentdump {	sub currentdump {
my ($courseid,$sdom,$sname)=@_;	my ($courseid,$sdom,$sname)=@_;
Line 2096 sub currentdump {	Line 2451 sub currentdump {
return if ($tmp[0] =~ /^(error:\|no_such_host)/);	return if ($tmp[0] =~ /^(error:\|no_such_host)/);
my %hash = @tmp;	my %hash = @tmp;
@tmp=();	@tmp=();
# Code ripped from lond, essentially. The only difference	%returnhash = %{&convert_dump_to_currentdump(\%hash)};
# here is the unescaping done by lonnet::dump(). Conceivably
# we might run in to problems with parameter names =~ /^v\./
while (my ($key,$value) = each(%hash)) {
my ($v,$symb,$param) = split(/:/,$key);
next if ($v eq 'version' \|\| $symb eq 'keys');
next if (exists($returnhash{$symb}) &&
exists($returnhash{$symb}->{$param}) &&
$returnhash{$symb}->{'v.'.$param} > $v);
$returnhash{$symb}->{$param}=$value;
$returnhash{$symb}->{'v.'.$param}=$v;
}
#
# Remove all of the keys in the hashes which keep track of
# the version of the parameter.
while (my ($symb,$param_hash) = each(%returnhash)) {
# use a foreach because we are going to delete from the hash.
foreach my $key (keys(%$param_hash)) {
delete($param_hash->{$key}) if ($key =~ /^v\./);
}
}
} else {	} else {
my @pairs=split(/\&/,$rep);	my @pairs=split(/\&/,$rep);
foreach (@pairs) {	foreach (@pairs) {
Line 2129 sub currentdump {	Line 2464 sub currentdump {
return %returnhash;	return %returnhash;
}	}

	sub convert_dump_to_currentdump{
	my %hash = %{shift()};
	my %returnhash;
	# Code ripped from lond, essentially. The only difference
	# here is the unescaping done by lonnet::dump(). Conceivably
	# we might run in to problems with parameter names =~ /^v\./
	while (my ($key,$value) = each(%hash)) {
	my ($v,$symb,$param) = split(/:/,$key);
	next if ($v eq 'version' \|\| $symb eq 'keys');
	next if (exists($returnhash{$symb}) &&
	exists($returnhash{$symb}->{$param}) &&
	$returnhash{$symb}->{'v.'.$param} > $v);
	$returnhash{$symb}->{$param}=$value;
	$returnhash{$symb}->{'v.'.$param}=$v;
	}
	#
	# Remove all of the keys in the hashes which keep track of
	# the version of the parameter.
	while (my ($symb,$param_hash) = each(%returnhash)) {
	# use a foreach because we are going to delete from the hash.
	foreach my $key (keys(%$param_hash)) {
	delete($param_hash->{$key}) if ($key =~ /^v\./);
	}
	}
	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 2209 sub customaccess {	Line 2595 sub customaccess {
$access=($effect eq 'allow');	$access=($effect eq 'allow');
last;	last;
}	}
	if ($realm eq '' && $role eq '') {
	$access=($effect eq 'allow');
	}
}	}
return $access;	return $access;
}	}
Line 2217 sub customaccess {	Line 2606 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);

	if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; }
# Free bre access to adm and meta resources	# Free bre access to adm and meta resources

if ((($uri=~/^adm\//) \|\| ($uri=~/\.meta$/)) && ($priv eq 'bre')) {	if ((($uri=~/^adm\//) \|\| ($uri=~/\.meta$/)) && ($priv eq 'bre')) {
Line 2269 sub allowed {	Line 2659 sub allowed {

# Course	# Course

if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/$priv\&([^\:]*)/) {	if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) {
$thisallowed.=$1;	$thisallowed.=$1;
}	}

# Domain	# Domain

if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}	if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}
=~/$priv\&([^\:]*)/) {	=~/\Q$priv\E\&([^\:]*)/) {
$thisallowed.=$1;	$thisallowed.=$1;
}	}

Line 2286 sub allowed {	Line 2676 sub allowed {
$courseuri=~s/^([^\/])/\/$1/;	$courseuri=~s/^([^\/])/\/$1/;

if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri}	if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri}
=~/$priv\&([^\:]*)/) {	=~/\Q$priv\E\&([^\:]*)/) {
$thisallowed.=$1;	$thisallowed.=$1;
}	}

Line 2304 sub allowed {	Line 2694 sub allowed {

# If this is generating or modifying users, exit with special codes	# If this is generating or modifying users, exit with special codes

if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:$priv\:/) {	if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:\Q$priv\E\:/) {
return $thisallowed;	return $thisallowed;
}	}
#	#
Line 2325 sub allowed {	Line 2715 sub allowed {
if ($match) {	if ($match) {
$statecond=$cond;	$statecond=$cond;
if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}	if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}
=~/$priv\&([^\:]*)/) {	=~/\Q$priv\E\&([^\:]*)/) {
$thisallowed.=$1;	$thisallowed.=$1;
$checkreferer=0;	$checkreferer=0;
}	}
Line 2353 sub allowed {	Line 2743 sub allowed {
if ($match) {	if ($match) {
my $refstatecond=$cond;	my $refstatecond=$cond;
if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}	if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}
=~/$priv\&([^\:]*)/) {	=~/\Q$priv\E\&([^\:]*)/) {
$thisallowed.=$1;	$thisallowed.=$1;
$uri=$refuri;	$uri=$refuri;
$statecond=$refstatecond;	$statecond=$refstatecond;
Line 2406 sub allowed {	Line 2796 sub allowed {
if ((time-$ENV{$prefix.'last_cache'})>$expiretime) {	if ((time-$ENV{$prefix.'last_cache'})>$expiretime) {
&coursedescription($courseid);	&coursedescription($courseid);
}	}
if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,$csec\,/)	if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/)
\|\| ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {	\|\| ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {
if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) {	if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) {
&log($ENV{'user.domain'},$ENV{'user.name'},	&log($ENV{'user.domain'},$ENV{'user.name'},
Line 2417 sub allowed {	Line 2807 sub allowed {
return '';	return '';
}	}
}	}
if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,$csec\,/)	if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/)
\|\| ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {	\|\| ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {
if ($ENV{'priv.'.$priv.'.lock.expire'}>time) {	if ($ENV{'priv.'.$priv.'.lock.expire'}>time) {
&log($ENV{'user.domain'},$ENV{'user.name'},	&log($ENV{'user.domain'},$ENV{'user.name'},
Line 2451 sub allowed {	Line 2841 sub allowed {
my $rolecode=(split(/\./,$ENV{'request.role'}))[0];	my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
my $unamedom=$ENV{'user.name'}.':'.$ENV{'user.domain'};	my $unamedom=$ENV{'user.name'}.':'.$ENV{'user.domain'};
if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'}	if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'}
=~/$rolecode/) {	=~/\Q$rolecode\E/) {
&log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},	&log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.	'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
$ENV{'request.course.id'});	$ENV{'request.course.id'});
Line 2459 sub allowed {	Line 2849 sub allowed {
}	}

if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.users.denied'}	if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.users.denied'}
=~/$unamedom/) {	=~/\Q$unamedom\E/) {
&log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},	&log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.	'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
$ENV{'request.course.id'});	$ENV{'request.course.id'});
Line 2471 sub allowed {	Line 2861 sub allowed {

if ($thisallowed=~/R/) {	if ($thisallowed=~/R/) {
my $rolecode=(split(/\./,$ENV{'request.role'}))[0];	my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
if (&metadata($uri,'roledeny')=~/$rolecode/) {	if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {
&log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},	&log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);	'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
return '';	return '';
Line 2483 sub allowed {	Line 2873 sub allowed {
if ($thisallowed=~/X/) {	if ($thisallowed=~/X/) {
if ($ENV{'acc.randomout'}) {	if ($ENV{'acc.randomout'}) {
my $symb=&symbread($uri,1);	my $symb=&symbread($uri,1);
if (($symb) && ($ENV{'acc.randomout'}=~/\&$symb\&/)) {	if (($symb) && ($ENV{'acc.randomout'}=~/\&\Q$symb\E\&/)) {
return '';	return '';
}	}
}	}
Line 2501 sub allowed {	Line 2891 sub allowed {

sub is_on_map {	sub is_on_map {
my $uri=&declutter(shift);	my $uri=&declutter(shift);
	$uri=~s/\.\d+\.(\w+)$/\.$1/;
my @uriparts=split(/\//,$uri);	my @uriparts=split(/\//,$uri);
my $filename=$uriparts[$#uriparts];	my $filename=$uriparts[$#uriparts];
my $pathname=$uri;	my $pathname=$uri;
Line 2516 sub is_on_map {	Line 2907 sub is_on_map {
}	}
}	}

	# --------------------------------------------------------- Get symb from alias

	sub get_symb_from_alias {
	my $symb=shift;
	my ($map,$resid,$url)=&decode_symb($symb);
	# Already is a symb
	if ($url) { return $symb; }
	# Must be an alias
	my $aliassymb='';
	my %bighash;
	if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
	&GDBM_READER(),0640)) {
	my $rid=$bighash{'mapalias_'.$symb};
	if ($rid) {
	my ($mapid,$resid)=split(/\./,$rid);
	$aliassymb=&encode_symb($bighash{'map_id_'.$mapid},
	$resid,$bighash{'src_'.$rid});
	}
	untie %bighash;
	}
	return $aliassymb;
	}

# ----------------------------------------------------------------- Define Role	# ----------------------------------------------------------------- Define Role

sub definerole {	sub definerole {
Line 2523 sub definerole {	Line 2937 sub definerole {
my ($rolename,$sysrole,$domrole,$courole)=@_;	my ($rolename,$sysrole,$domrole,$courole)=@_;
foreach (split(':',$sysrole)) {	foreach (split(':',$sysrole)) {
my ($crole,$cqual)=split(/\&/,$_);	my ($crole,$cqual)=split(/\&/,$_);
if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; }	if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; }
if ($pr{'cr:s'}=~/$crole\&/) {	if ($pr{'cr:s'}=~/\Q$crole\E\&/) {
if ($pr{'cr:s'}!~/$crole\&\w*$cqual/) {	if ($pr{'cr:s'}!~/\Q$crole\E\&\w*\Q$cqual\E/) {
return "refused:s:$crole&$cqual";	return "refused:s:$crole&$cqual";
}	}
}	}
}	}
foreach (split(':',$domrole)) {	foreach (split(':',$domrole)) {
my ($crole,$cqual)=split(/\&/,$_);	my ($crole,$cqual)=split(/\&/,$_);
if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; }	if ($pr{'cr:d'}!~/\Q$crole\E/) { return "refused:d:$crole"; }
if ($pr{'cr:d'}=~/$crole\&/) {	if ($pr{'cr:d'}=~/\Q$crole\E\&/) {
if ($pr{'cr:d'}!~/$crole\&\w*$cqual/) {	if ($pr{'cr:d'}!~/\Q$crole\W\&\w*\Q$cqual\E/) {
return "refused:d:$crole&$cqual";	return "refused:d:$crole&$cqual";
}	}
}	}
}	}
foreach (split(':',$courole)) {	foreach (split(':',$courole)) {
my ($crole,$cqual)=split(/\&/,$_);	my ($crole,$cqual)=split(/\&/,$_);
if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; }	if ($pr{'cr:c'}!~/\Q$crole\E/) { return "refused:c:$crole"; }
if ($pr{'cr:c'}=~/$crole\&/) {	if ($pr{'cr:c'}=~/\Q$crole\E\&/) {
if ($pr{'cr:c'}!~/$crole\&\w*$cqual/) {	if ($pr{'cr:c'}!~/\Q$crole\E\&\w*\Q$cqual\E/) {
return "refused:c:$crole&$cqual";	return "refused:c:$crole&$cqual";
}	}
}	}
Line 2590 sub log_query {	Line 3004 sub log_query {
my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys %filters));	my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys %filters));
my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,	my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,
$uhome);	$uhome);
unless ($queryid=~/^$uhost\_/) { return 'error: '.$queryid; }	unless ($queryid=~/^\Q$uhost\E\_/) { return 'error: '.$queryid; }
return get_query_reply($queryid);	return get_query_reply($queryid);
}	}

Line 2601 sub get_query_reply {	Line 3015 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 2642 sub userlog_query {	Line 3056 sub userlog_query {

sub plaintext {	sub plaintext {
my $short=shift;	my $short=shift;
return $prp{$short};	return &mt($prp{$short});
}	}

# ----------------------------------------------------------------- Assign Role	# ----------------------------------------------------------------- Assign Role
Line 2746 sub modifyuser {	Line 3160 sub modifyuser {
' in domain '.$ENV{'request.role.domain'});	' in domain '.$ENV{'request.role.domain'});
my $uhome=&homeserver($uname,$udom,'true');	my $uhome=&homeserver($uname,$udom,'true');
# ----------------------------------------------------------------- Create User	# ----------------------------------------------------------------- Create User
if (($uhome eq 'no_host') && ($umode) && ($upass)) {	if (($uhome eq 'no_host') &&
	(($umode && $upass) \|\| ($umode eq 'localauth'))) {
my $unhome='';	my $unhome='';
if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) {	if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) {
$unhome = $desiredhome;	$unhome = $desiredhome;
Line 2827 sub modifyuser {	Line 3242 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 2840 sub modifystudent {	Line 3256 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 2870 sub modify_student_enrollment {	Line 3296 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 2881 sub modify_student_enrollment {	Line 3307 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 $reply=cput('classlist',
$ENV{'course.'.$cid.'.num'}.':classlist:'.	{"$uname:$udom" =>
&escape($uname.':'.$udom).'='.	join(':',$end,$start,$uid,$usec,$fullname,$type) },
&escape(join(':',$end,$start,$uid,$usec,$fullname)),	$cdom,$cnum);
$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 3086 sub dirlist {	Line 3511 sub dirlist {
# when it was last modified. It will also return an error of -1	# when it was last modified. It will also return an error of -1
# if an error occurs	# if an error occurs

	##
	## FIXME: This subroutine assumes its caller knows something about the
	## directory structure of the home server for the student ($root).
	## Not a good assumption to make. Since this is for looking up files
	## in user directories, the full path should be constructed by lond, not
	## whatever machine we request data from.
	##
sub GetFileTimestamp {	sub GetFileTimestamp {
my ($studentDomain,$studentName,$filename,$root)=@_;	my ($studentDomain,$studentName,$filename,$root)=@_;
$studentDomain=~s/\W//g;	$studentDomain=~s/\W//g;
Line 3162 sub condval {	Line 3594 sub condval {
sub devalidatecourseresdata {	sub devalidatecourseresdata {
my ($coursenum,$coursedomain)=@_;	my ($coursenum,$coursedomain)=@_;
my $hashid=$coursenum.':'.$coursedomain;	my $hashid=$coursenum.':'.$coursedomain;
delete $courseresdatacache{$hashid.'.time'};	&devalidate_cache(\%courseresdatacache,$hashid,'courseres');
}	}

# --------------------------------------------------- Course Resourcedata Query	# --------------------------------------------------- Course Resourcedata Query
Line 3171 sub courseresdata {	Line 3603 sub courseresdata {
my ($coursenum,$coursedomain,@which)=@_;	my ($coursenum,$coursedomain,@which)=@_;
my $coursehom=&homeserver($coursenum,$coursedomain);	my $coursehom=&homeserver($coursenum,$coursedomain);
my $hashid=$coursenum.':'.$coursedomain;	my $hashid=$coursenum.':'.$coursedomain;
my $dodump=0;	my ($result,$cached)=&is_cached(\%courseresdatacache,$hashid,'courseres');
if (!defined($courseresdatacache{$hashid.'.time'})) {	unless (defined($cached)) {
$dodump=1;
} else {
if (time-$courseresdatacache{$hashid.'.time'}>300) { $dodump=1; }
}
if ($dodump) {
my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum);	my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum);
	$result=\%dumpreply;
my ($tmp) = keys(%dumpreply);	my ($tmp) = keys(%dumpreply);
if ($tmp !~ /^(con_lost\|error\|no_such_host)/i) {	if ($tmp !~ /^(con_lost\|error\|no_such_host)/i) {
$courseresdatacache{$hashid.'.time'}=time;	&do_cache(\%courseresdatacache,$hashid,$result,'courseres');
$courseresdatacache{$hashid}=\%dumpreply;
} elsif ($tmp =~ /^(con_lost\|no_such_host)/) {	} elsif ($tmp =~ /^(con_lost\|no_such_host)/) {
return $tmp;	return $tmp;
	} elsif ($tmp =~ /^(error)/) {
	$result=undef;
	&do_cache(\%courseresdatacache,$hashid,$result,'courseres');
}	}
}	}
foreach my $item (@which) {	foreach my $item (@which) {
if (defined($courseresdatacache{$hashid}->{$item})) {	if (defined($result->{$item})) {
return $courseresdatacache{$hashid}->{$item};	return $result->{$item};
}	}
}	}
return undef;	return undef;
Line 3228 sub EXT {	Line 3658 sub EXT {
#get real user name/domain, courseid and symb	#get real user name/domain, courseid and symb
my $courseid;	my $courseid;
my $publicuser;	my $publicuser;
	if ($symbparm) {
	$symbparm=&get_symb_from_alias($symbparm);
	}
if (!($uname && $udom)) {	if (!($uname && $udom)) {
(my $cursymb,$courseid,$udom,$uname,$publicuser)=	(my $cursymb,$courseid,$udom,$uname,$publicuser)=
&Apache::lonxml::whichuser($symbparm);	&Apache::lonxml::whichuser($symbparm);
Line 3313 sub EXT {	Line 3746 sub EXT {
} elsif ($realm eq 'request') {	} elsif ($realm eq 'request') {
# ------------------------------------------------------------- request.browser	# ------------------------------------------------------------- request.browser
if ($space eq 'browser') {	if ($space eq 'browser') {
return $ENV{'browser.'.$qualifier};	if ($qualifier eq 'textremote') {
	if (&mt('textual_remote_display') eq 'on') {
	return 1;
	} else {
	return 0;
	}
	} else {
	return $ENV{'browser.'.$qualifier};
	}
# ------------------------------------------------------------ request.filename	# ------------------------------------------------------------ request.filename
} else {	} else {
return $ENV{'request.'.$spacequalifierrest};	return $ENV{'request.'.$spacequalifierrest};
Line 3331 sub EXT {	Line 3772 sub EXT {
# ----------------------------------------------------- Cascading lookup scheme	# ----------------------------------------------------- Cascading lookup scheme
if (!$symbparm) { $symbparm=&symbread(); }	if (!$symbparm) { $symbparm=&symbread(); }
my $symbp=$symbparm;	my $symbp=$symbparm;
my $mapp=(split(/\_\_\_/,$symbp))[0];	my $mapp=(&decode_symb($symbp))[0];

my $symbparm=$symbp.'.'.$spacequalifierrest;	my $symbparm=$symbp.'.'.$spacequalifierrest;
my $mapparm=$mapp.'___(all).'.$spacequalifierrest;	my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
Line 3357 sub EXT {	Line 3798 sub EXT {

# ----------------------------------------------------------- first, check user	# ----------------------------------------------------------- first, check user
#most student don\'t have any data set, check if there is some data	#most student don\'t have any data set, check if there is some data
#every thirty minutes
if (! &EXT_cache_status($udom,$uname)) {	if (! &EXT_cache_status($udom,$uname)) {
my %resourcedata=&get('resourcedata',	my $hashid="$udom:$uname";
[$courselevelr,$courselevelm,$courselevel],	my ($result,$cached)=&is_cached(\%userresdatacache,$hashid,
$udom,$uname);	'userres');
my ($tmp)=keys(%resourcedata);	if (!defined($cached)) {
	my %resourcedata=&dump('resourcedata',$udom,$uname);
	$result=\%resourcedata;
	&do_cache(\%userresdatacache,$hashid,$result,'userres');
	}
	my ($tmp)=keys(%$result);
if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {	if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {
if ($resourcedata{$courselevelr}) {	if ($$result{$courselevelr}) {
return $resourcedata{$courselevelr}; }	return $$result{$courselevelr}; }
if ($resourcedata{$courselevelm}) {	if ($$result{$courselevelm}) {
return $resourcedata{$courselevelm}; }	return $$result{$courselevelm}; }
if ($resourcedata{$courselevel}) {	if ($$result{$courselevel}) {
return $resourcedata{$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 3410 sub EXT {	Line 3856 sub EXT {
my $filename;	my $filename;
if (!$symbparm) { $symbparm=&symbread(); }	if (!$symbparm) { $symbparm=&symbread(); }
if ($symbparm) {	if ($symbparm) {
$filename=(split(/\_\_\_/,$symbparm))[2];	$filename=(&decode_symb($symbparm))[2];
} else {	} else {
$filename=$ENV{'request.filename'};	$filename=$ENV{'request.filename'};
}	}
Line 3458 sub packages_tab_default {	Line 3904 sub packages_tab_default {
my $packages=&metadata($uri,'packages');	my $packages=&metadata($uri,'packages');
foreach my $package (split(/,/,$packages)) {	foreach my $package (split(/,/,$packages)) {
my ($pack_type,$pack_part)=split(/_/,$package,2);	my ($pack_type,$pack_part)=split(/_/,$package,2);
if ($pack_part eq $part) {	if (defined($packagetab{"$pack_type&$name&default"})) {
return $packagetab{"$pack_type&$name&default"};	return $packagetab{"$pack_type&$name&default"};
}	}
	if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) {
	return $packagetab{$pack_type."_".$pack_part."&$name&default"};
	}
}	}
return undef;	return undef;
}	}
Line 3485 sub add_prefix_and_part {	Line 3934 sub add_prefix_and_part {

sub metadata {	sub metadata {
my ($uri,$what,$liburi,$prefix,$depthcount)=@_;	my ($uri,$what,$liburi,$prefix,$depthcount)=@_;

$uri=&declutter($uri);	$uri=&declutter($uri);
# if it is a non metadata possible uri return quickly	# if it is a non metadata possible uri return quickly
if (($uri eq '') \|\| (($uri =~ m\|^/*adm/\|) && ($uri !~ m\|^adm/includes\|)) \|\|	if (($uri eq '') \|\| (($uri =~ m\|^/*adm/\|) && ($uri !~ m\|^adm/includes\|)) \|\|
($uri =~ m\|/$\|) \|\| ($uri =~ m\|/.meta$\|)) {	($uri =~ m\|/$\|) \|\| ($uri =~ m\|/.meta$\|) \|\| ($uri =~ /^~/) \|\|
return '';	($uri =~ m\|home/[^/]+/public_html/\|) \|\| ($uri =~ m\|^uploaded/\|)) {
	return undef;
}	}
my $filename=$uri;	my $filename=$uri;
$uri=~s/\.meta$//;	$uri=~s/\.meta$//;
Line 3499 sub metadata {	Line 3948 sub metadata {
# Look at timestamp of caching	# Look at timestamp of caching
# Everything is cached by the main uri, libraries are never directly cached	# Everything is cached by the main uri, libraries are never directly cached
#	#
unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600 && !defined($liburi)) {	if (!defined($liburi)) {
	my ($result,$cached)=&is_cached(\%metacache,$uri,'meta');
	if (defined($cached)) { return $result->{':'.$what}; }
	}
	{
#	#
# Is this a recursive call for a library?	# Is this a recursive call for a library?
#	#
	if (! exists($metacache{$uri})) {
	$metacache{$uri}={};
	}
if ($liburi) {	if ($liburi) {
$liburi=&declutter($liburi);	$liburi=&declutter($liburi);
$filename=$liburi;	$filename=$liburi;
}	} else {
	&devalidate_cache(\%metacache,$uri,'meta');
	}
my %metathesekeys=();	my %metathesekeys=();
unless ($filename=~/\.meta$/) { $filename.='.meta'; }	unless ($filename=~/\.meta$/) { $filename.='.meta'; }
my $metastring=&getfile(&filelocation('',&clutter($filename)));	my $metastring=&getfile(&filelocation('',&clutter($filename)));
my $parser=HTML::LCParser->new(\$metastring);	my $parser=HTML::LCParser->new(\$metastring);
my $token;	my $token;
undef %metathesekeys;	undef %metathesekeys;
delete($metacache{$uri.':packages'});
while ($token=$parser->get_token) {	while ($token=$parser->get_token) {
if ($token->[0] eq 'S') {	if ($token->[0] eq 'S') {
if (defined($token->[2]->{'package'})) {	if (defined($token->[2]->{'package'})) {
Line 3525 sub metadata {	Line 3982 sub metadata {
if (defined($token->[2]->{'id'})) {	if (defined($token->[2]->{'id'})) {
$keyroot.='_'.$token->[2]->{'id'};	$keyroot.='_'.$token->[2]->{'id'};
}	}
if ($metacache{$uri.':packages'}) {	if ($metacache{$uri}->{':packages'}) {
$metacache{$uri.':packages'}.=','.$package.$keyroot;	$metacache{$uri}->{':packages'}.=','.$package.$keyroot;
} else {	} else {
$metacache{$uri.':packages'}=$package.$keyroot;	$metacache{$uri}->{':packages'}=$package.$keyroot;
}	}
foreach (keys %packagetab) {	foreach (keys %packagetab) {
if ($_=~/^$package\&/) {	my $part=$keyroot;
	$part=~s/^\_//;
	if ($_=~/^\Q$package\E\&/ \|\|
	$_=~/^\Q$package\E_0\&/) {
my ($pack,$name,$subp)=split(/\&/,$_);	my ($pack,$name,$subp)=split(/\&/,$_);
# ignore package.tab specified default values	# ignore package.tab specified default values
# here &package_tab_default() will fetch those	# here &package_tab_default() will fetch those
if ($subp eq 'default') { next; }	if ($subp eq 'default') { next; }
my $value=$packagetab{$_};	my $value=$packagetab{$_};
my $part=$keyroot;	my $unikey;
$part=~s/^\_//;	if ($pack =~ /_0$/) {
	$unikey='parameter_0_'.$name;
	$part=0;
	} else {
	$unikey='parameter'.$keyroot.'_'.$name;
	}
if ($subp eq 'display') {	if ($subp eq 'display') {
$value.=' [Part: '.$part.']';	$value.=' [Part: '.$part.']';
}	}
my $unikey='parameter'.$keyroot.'_'.$name;	$metacache{$uri}->{':'.$unikey.'.part'}=$part;
$metacache{$uri.':'.$unikey.'.part'}=$part;
$metathesekeys{$unikey}=1;	$metathesekeys{$unikey}=1;
unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {	unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) {
$metacache{$uri.':'.$unikey.'.'.$subp}=$value;	$metacache{$uri}->{':'.$unikey.'.'.$subp}=$value;
}	}
if (defined($metacache{$uri.':'.$unikey.'.default'})) {	if (defined($metacache{$uri}->{':'.$unikey.'.default'})) {
$metacache{$uri.':'.$unikey}=	$metacache{$uri}->{':'.$unikey}=
$metacache{$uri.':'.$unikey.'.default'};	$metacache{$uri}->{':'.$unikey.'.default'};
}	}
}	}
}	}
Line 3583 sub metadata {	Line 4047 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 3593 sub metadata {	Line 4058 sub metadata {
}	}
$metathesekeys{$unikey}=1;	$metathesekeys{$unikey}=1;
foreach (@{$token->[3]}) {	foreach (@{$token->[3]}) {
$metacache{$uri.':'.$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=$metacache{$uri.':'.$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
$metacache{$uri.':'.$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
$metacache{$uri.':'.$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 3613 sub metadata {	Line 4078 sub metadata {
# the next is the end of "start tag"	# the next is the end of "start tag"
}	}
}	}
	my ($extension) = ($uri =~ /\.(\w+)$/);
	foreach my $key (sort(keys(%packagetab))) {
	#&logthis("extsion1 $extension $key !!");
	#no specific packages #how's our extension
	if ($key!~/^extension_\Q$extension\E&/) { next; }
	&metadata_create_package_def($uri,$key,'extension_'.$extension,
	\%metathesekeys);
	}
	if (!exists($metacache{$uri}->{':packages'})) {
	foreach my $key (sort(keys(%packagetab))) {
	#no specific packages well let's get default then
	if ($key!~/^default&/) { next; }
	&metadata_create_package_def($uri,$key,'default',
	\%metathesekeys);
	}
	}
# are there custom rights to evaluate	# are there custom rights to evaluate
if ($metacache{$uri.':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=$metacache{$uri.':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;
}	}
}	}
}	}
$metacache{$uri.':keys'}=join(',',keys %metathesekeys);	$metacache{$uri}->{':keys'}=join(',',keys %metathesekeys);
&metadata_generate_part0(\%metathesekeys,\%metacache,$uri);	&metadata_generate_part0(\%metathesekeys,$metacache{$uri},$uri);
$metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys);	$metacache{$uri}->{':allpossiblekeys'}=join(',',keys %metathesekeys);
$metacache{$uri.':cachedtimestamp'}=time;	&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};
	}

	sub metadata_create_package_def {
	my ($uri,$key,$package,$metathesekeys)=@_;
	my ($pack,$name,$subp)=split(/\&/,$key);
	if ($subp eq 'default') { next; }

	if (defined($metacache{$uri}->{':packages'})) {
	$metacache{$uri}->{':packages'}.=','.$package;
	} else {
	$metacache{$uri}->{':packages'}=$package;
	}
	my $value=$packagetab{$key};
	my $unikey;
	$unikey='parameter_0_'.$name;
	$metacache{$uri}->{':'.$unikey.'.part'}=0;
	$$metathesekeys{$unikey}=1;
	unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) {
	$metacache{$uri}->{':'.$unikey.'.'.$subp}=$value;
	}
	if (defined($metacache{$uri}->{':'.$unikey.'.default'})) {
	$metacache{$uri}->{':'.$unikey}=
	$metacache{$uri}->{':'.$unikey.'.default'};
	}
}	}

sub metadata_generate_part0 {	sub metadata_generate_part0 {
Line 3645 sub metadata_generate_part0 {	Line 4151 sub metadata_generate_part0 {
my %allnames;	my %allnames;
foreach my $metakey (sort keys %$metadata) {	foreach my $metakey (sort keys %$metadata) {
if ($metakey=~/^parameter\_(.*)/) {	if ($metakey=~/^parameter\_(.*)/) {
my $part=$$metacache{$uri.':'.$metakey.'.part'};	my $part=$$metacache{':'.$metakey.'.part'};
my $name=$$metacache{$uri.':'.$metakey.'.name'};	my $name=$$metacache{':'.$metakey.'.name'};
if (! exists($$metadata{'parameter_0_'.$name.'.name'})) {	if (! exists($$metadata{'parameter_0_'.$name.'.name'})) {
$allnames{$name}=$part;	$allnames{$name}=$part;
}	}
Line 3654 sub metadata_generate_part0 {	Line 4160 sub metadata_generate_part0 {
}	}
foreach my $name (keys(%allnames)) {	foreach my $name (keys(%allnames)) {
$$metadata{"parameter_0_$name"}=1;	$$metadata{"parameter_0_$name"}=1;
my $key="$uri:parameter_0_$name";	my $key=":parameter_0_$name";
$$metacache{"$key.part"}='0';	$$metacache{"$key.part"}='0';
$$metacache{"$key.name"}=$name;	$$metacache{"$key.name"}=$name;
$$metacache{"$key.type"}=$$metacache{$uri.':parameter_'.	$$metacache{"$key.type"}=$$metacache{':parameter_'.
$allnames{$name}.'_'.$name.	$allnames{$name}.'_'.$name.
'.type'};	'.type'};
my $olddis=$$metacache{$uri.':parameter_'.$allnames{$name}.'_'.$name.	my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name.
'.display'};	'.display'};
my $expr='\\[Part: '.$allnames{$name}.'\\]';	my $expr='\\[Part: '.$allnames{$name}.'\\]';
$olddis=~s/$expr/\[Part: 0\]/;	$olddis=~s/\Q$expr\E/\[Part: 0\]/;
$$metacache{"$key.display"}=$olddis;	$$metacache{"$key.display"}=$olddis;
}	}
}	}
Line 3677 sub gettitle {	Line 4183 sub gettitle {
unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; }	unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; }
return &metadata($urlsymb,'title');	return &metadata($urlsymb,'title');
}	}
if ($titlecache{$symb}) {	my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);
if (time < ($titlecache{$symb}[1] + 600)) {	if (defined($cached)) { return $result; }
return $titlecache{$symb}[0];	my ($map,$resid,$url)=&decode_symb($symb);
} else {
delete($titlecache{$symb});
}
}
my ($map,$resid,$url)=split(/\_\_\_/,$symb);
my $title='';	my $title='';
my %bighash;	my %bighash;
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',	if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
Line 3695 sub gettitle {	Line 4196 sub gettitle {
}	}
$title=~s/\&colon\;/\:/gs;	$title=~s/\&colon\;/\:/gs;
if ($title) {	if ($title) {
$titlecache{$symb}=[$title,time];	return &do_cache(\%titlecache,$symb,$title,'title');
return $title;
} else {	} else {
return &metadata($urlsymb,'title');	return &metadata($urlsymb,'title');
}	}
Line 3706 sub gettitle {	Line 4206 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 3730 sub symbverify {	Line 4230 sub symbverify {
# 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)=split(/\_\_\_/,$symb);	my ($map,$resid,$url)=&decode_symb($symb);
unless (&symbclean($url) eq &symbclean($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;

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)) {
my $ids=$bighash{'ids_'.&clutter($thisfn)};	my $ids=$bighash{'ids_'.&clutter($thisfn)};
Line 3773 sub symbclean {	Line 4276 sub symbclean {
return $symb;	return $symb;
}	}

	# ---------------------------------------------- Split symb to find map and url

	sub encode_symb {
	my ($map,$resid,$url)=@_;
	return &symbclean(&declutter($map).'___'.$resid.'___'.&declutter($url));
	}

	sub decode_symb {
	my ($map,$resid,$url)=split(/\_\_\_/,shift);
	return (&fixversion($map),$resid,&fixversion($url));
	}

	sub fixversion {
	my $fn=shift;
	if ($fn=~/^(adm\|uploaded\|public)/) { return $fn; }
	my %bighash;
	my $uri=&clutter($fn);
	my $key=$ENV{'request.course.id'}.'_'.$uri;
	# is this cached?
	my ($result,$cached)=&is_cached(\%courseresversioncache,$key,
	'courseresversion',600);
	if (defined($cached)) { return $result; }
	# unfortunately not cached, or expired
	if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
	&GDBM_READER(),0640)) {
	if ($bighash{'version_'.$uri}) {
	my $version=$bighash{'version_'.$uri};
	unless (($version eq 'mostrecent') \|\|
	($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	# ------------------------------------------------------ Return symb list entry

sub symbread {	sub symbread {
Line 3791 sub symbread {	Line 4338 sub symbread {
my %bighash;	my %bighash;
my $syval='';	my $syval='';
if (($ENV{'request.course.fn'}) && ($thisfn)) {	if (($ENV{'request.course.fn'}) && ($thisfn)) {
	my $targetfn = $thisfn;
	if ( ($thisfn =~ m/^uploaded\//) && ($thisfn !~ m/\.(page\|sequence)$/) ) {
	$targetfn = 'adm/wrapper/'.$thisfn;
	}
if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',	if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
&GDBM_READER(),0640)) {	&GDBM_READER(),0640)) {
$syval=$hash{$thisfn};	$syval=$hash{$targetfn};
untie(%hash);	untie(%hash);
}	}
# ---------------------------------------------------------- There was an entry	# ---------------------------------------------------------- There was an entry
Line 3845 sub symbread {	Line 4396 sub symbread {
}	}
}	}
untie(%bighash)	untie(%bighash)
}	}
}	}
if ($syval) {	if ($syval) {
return &symbclean($syval.'___'.$thisfn);	return &symbclean($syval.'___'.$thisfn);
Line 3869 sub numval {	Line 4420 sub numval {
return int($txt);	return int($txt);
}	}

	sub numval2 {
	my $txt=shift;
	$txt=~tr/A-J/0-9/;
	$txt=~tr/a-j/0-9/;
	$txt=~tr/K-T/0-9/;
	$txt=~tr/k-t/0-9/;
	$txt=~tr/U-Z/0-5/;
	$txt=~tr/u-z/0-5/;
	$txt=~s/\D//g;
	my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt);
	my $total;
	foreach my $val (@txts) { $total+=$val; }
	return int($total);
	}

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

sub rndseed {	sub rndseed {
Line 3884 sub rndseed {	Line 4450 sub rndseed {
if (!$domain) { $domain=$wdomain; }	if (!$domain) { $domain=$wdomain; }
if (!$username) { $username=$wusername }	if (!$username) { $username=$wusername }
my $which=$ENV{"course.$courseid.rndseed"};	my $which=$ENV{"course.$courseid.rndseed"};
my $CODE=$ENV{'scantron.CODE'};	my $CODE=$ENV{'form.CODE'};
if (defined($CODE)) {	if (defined($CODE)) {
&rndseed_CODE_64bit($symb,$courseid,$domain,$username);	return &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 3930 sub rndseed_64bit {	Line 4498 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=numval2($symb);
my $CODEseed=numval($ENV{'scantron.CODE'}) << 16;	my $CODEchck=unpack("%32S*",$ENV{'form.CODE'}.' ') << 16;
my $courseseed=unpack("%32S*",$courseid);	my $CODEseed=numval($ENV{'form.CODE'});
my $num1=$symbseed+$CODEseed;	my $courseseed=unpack("%32S*",$courseid.' ');
my $num2=$courseseed+$symbchck;	my $num1=$symbseed+$CODEchck;
#&Apache::lonxml::debug("$symbseed:$CODEseed\|$courseseed:$symbchck");	my $num2=$CODEseed+$courseseed+$symbchck;
	#&Apache::lonxml::debug("$symbseed:$CODEchck\|$CODEseed:$courseseed:$symbchck");
#&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");	#&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");
return "$num1,$num2";	return "$num1,$num2";
}	}
Line 3956 sub setup_random_from_rndseed {	Line 4547 sub setup_random_from_rndseed {
}	}
}	}

	sub latest_receipt_algorithm_id {
	return 'receipt2';
	}

	sub recunique {
	my $fucourseid=shift;
	my $unique;
	if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2') {
	$unique=$ENV{"course.$fucourseid.internal.encseed"};
	} else {
	$unique=$perlvar{'lonReceipt'};
	}
	return unpack("%32C*",$unique);
	}

	sub recprefix {
	my $fucourseid=shift;
	my $prefix;
	if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2') {
	$prefix=$ENV{"course.$fucourseid.internal.encpref"};
	} else {
	$prefix=$perlvar{'lonHostID'};
	}
	return unpack("%32C*",$prefix);
	}

sub ireceipt {	sub ireceipt {
my ($funame,$fudom,$fucourseid,$fusymb)=@_;	my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_;
my $cuname=unpack("%32C*",$funame);	my $cuname=unpack("%32C*",$funame);
my $cudom=unpack("%32C*",$fudom);	my $cudom=unpack("%32C*",$fudom);
my $cucourseid=unpack("%32C*",$fucourseid);	my $cucourseid=unpack("%32C*",$fucourseid);
my $cusymb=unpack("%32C*",$fusymb);	my $cusymb=unpack("%32C*",$fusymb);
my $cunique=unpack("%32C*",$perlvar{'lonReceipt'});	my $cunique=&recunique($fucourseid);
return unpack("%32C*",$perlvar{'lonHostID'}).'-'.	my $cpart=unpack("%32S*",$part);
($cunique%$cuname+	my $return =&recprefix($fucourseid).'-';
$cunique%$cudom+	if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2' \|\|
$cusymb%$cuname+	$ENV{'request.state'} eq 'construct') {
$cusymb%$cudom+	&Apache::lonxml::debug("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname).
$cucourseid%$cuname+	" and ".($cpart%$cudom));
$cucourseid%$cudom);
	$return.= ($cunique%$cuname+
	$cunique%$cudom+
	$cusymb%$cuname+
	$cusymb%$cudom+
	$cucourseid%$cuname+
	$cucourseid%$cudom+
	$cpart%$cuname+
	$cpart%$cudom);
	} else {
	$return.= ($cunique%$cuname+
	$cunique%$cudom+
	$cusymb%$cuname+
	$cusymb%$cudom+
	$cucourseid%$cuname+
	$cucourseid%$cudom);
	}
	return $return;
}	}

sub receipt {	sub receipt {
my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser();	my ($part)=@_;
return &ireceipt($name,$domain,$courseid,$symb);	my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser();
	return &ireceipt($name,$domain,$courseid,$symb,$part);
}	}

# ------------------------------------------------------------ Serves up a file	# ------------------------------------------------------------ Serves up a file
# returns either the contents of the file or a -1	# returns either the contents of the file or
	# -1 if the file doesn't exist
	#
	# if the target is a file that was uploaded via DOCS,
	# a check will be made to see if a current copy exists on the local server,
	# if it does this will be served, otherwise a copy will be retrieved from
	# the home server for the course and stored in /home/httpd/html/userfiles on
	# the local server.

sub getfile {	sub getfile {
my $file=shift;	my ($file,$caller) = @_;
if ($file=~/^\/*uploaded\//) { # user file
	if ($file !~ m\|^/*uploaded/(\w+)/(\w+)/(.+)$\|) {
	# normal file from res space
	&repcopy($file);
	return &readfile($file);
	}

	my $info;
	my $cdom = $1;
	my $cnum = $2;
	my $filename = $3;
	my $path = $Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles';
	my ($lwpresp,$rtncode);
	my $localfile = $path.'/'.$cdom.'/'.$cnum.'/'.$filename;
	if (-e "$localfile") {
	my @fileinfo = stat($localfile);
	$lwpresp = &getuploaded('HEAD',$file,$cdom,$cnum,\$info,\$rtncode);
	if ($lwpresp ne 'ok') {
	if ($rtncode eq '404') {
	unlink($localfile);
	}
	return -1;
	}
	if ($info < $fileinfo[9]) {
	return &readfile($localfile);
	}
	$info = '';
	$lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode);
	if ($lwpresp ne 'ok') {
	return -1;
	}
	} else {
	$lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode);
	if ($lwpresp ne 'ok') {
	return -1;
	}
	my @parts = ($cdom,$cnum);
	if ($filename =~ m\|^(.+)/[^/]+$\|) {
	push @parts, split(/\//,$1);
	}
	foreach my $part (@parts) {
	$path .= '/'.$part;
	if (!-e $path) {
	mkdir($path,0770);
	}
	}
	}
	open (FILE,">$localfile");
	print FILE $info;
	close(FILE);
	if ($caller eq 'uploadrep') {
	return 'ok';
	}
	return $info;
	}

	sub getuploaded {
	my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
	$uri=~s/^\///;
	$uri = 'http://'.$hostname{ &homeserver($cnum,$cdom)}.'/raw/'.$uri;
my $ua=new LWP::UserAgent;	my $ua=new LWP::UserAgent;
my $request=new HTTP::Request('GET',&tokenwrapper($file));	my $request=new HTTP::Request($reqtype,$uri);
my $response=$ua->request($request);	my $response=$ua->request($request);
if ($response->is_success()) {	$$rtncode = $response->code;
return $response->content;	if (! $response->is_success()) {
} else {	return 'failed';
return -1;	}
}	if ($reqtype eq 'HEAD') {
} else { # normal file from res space	$$info = &HTTP::Date::str2time( $response->header('Last-modified') );
&repcopy($file);	} elsif ($reqtype eq 'GET') {
if (! -e $file ) { return -1; };	$$info = $response->content;
my $fh=Apache::File->new($file);	}
my $a='';	return 'ok';
while (<$fh>) { $a .=$_; }	}
return $a;
}	sub readfile {
	my $file = shift;
	if ( (! -e $file ) \|\| ($file eq '') ) { return -1; };
	my $fh;
	open($fh,"<$file");
	my $a='';
	while (<$fh>) { $a .=$_; }
	return $a;
}	}

sub filelocation {	sub filelocation {
Line 4010 sub filelocation {	Line 4719 sub filelocation {
} elsif ($file=~/^\/*uploaded/) { # is an uploaded file	} elsif ($file=~/^\/*uploaded/) { # is an uploaded file
$location=$file;	$location=$file;
} else {	} else {
$file=~s/^$perlvar{'lonDocRoot'}//;	$file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
$file=~s:^/*res::;	$file=~s:^/res/:/:;
if ( !( $file =~ m:^/:) ) {	if ( !( $file =~ m:^/:) ) {
$location = $dir. '/'.$file;	$location = $dir. '/'.$file;
} else {	} else {
Line 4020 sub filelocation {	Line 4729 sub filelocation {
}	}
$location=~s://+:/:g; # remove duplicate /	$location=~s://+:/:g; # remove duplicate /
while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..	while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
	while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./
return $location;	return $location;
}	}

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;
	}
	return $file;
	}

	sub current_machine_domains {
	my $hostname=$hostname{$perlvar{'lonHostID'}};
	my @domains;
	while( my($id, $name) = each(%hostname)) {
	# &logthis("-$id-$name-$hostname-");
	if ($hostname eq $name) {
	push(@domains,$hostdom{$id});
	}
}	}
	return @domains;
	}

	sub current_machine_ids {
	my $hostname=$hostname{$perlvar{'lonHostID'}};
	my @ids;
	while( my($id, $name) = each(%hostname)) {
	# &logthis("-$id-$name-$hostname-");
	if ($hostname eq $name) {
	push(@ids,$id);
	}
	}
	return @ids;
}	}

# ------------------------------------------------------------- Declutters URLs	# ------------------------------------------------------------- Declutters URLs

sub declutter {	sub declutter {
my $thisfn=shift;	my $thisfn=shift;
$thisfn=~s/^$perlvar{'lonDocRoot'}//;	$thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;
$thisfn=~s/^\///;	$thisfn=~s/^\///;
$thisfn=~s/^res\///;	$thisfn=~s/^res\///;
$thisfn=~s/\?.+$//;	$thisfn=~s/\?.+$//;
Line 4072 sub unescape {	Line 4809 sub unescape {
return $str;	return $str;
}	}

	sub mod_perl_version {
	if (defined($perlvar{'MODPERL2'})) {
	return 2;
	}
	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 and probably shouldn't be
	&logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache)));
	#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();	&flushcourselogs();
&logthis("Shutting down");	&logthis("Shutting down");
return DONE;	return DONE;
Line 4085 BEGIN {	Line 4846 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=~/\S/ && $configline =~ /^[^\#]*PerlSetVar/) {
my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);	my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
chomp($varvalue);	chomp($varvalue);
$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 4105 BEGIN {	Line 4867 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 /^\#/;
chomp;	chomp;
my ($domain, $domain_description, $def_auth, $def_auth_arg)	my ($domain, $domain_description, $def_auth, $def_auth_arg,
= split(/:/,$_,4);	$def_lang, $city, $longi, $lati) = split(/:/,$_);
$domain_auth_def{$domain}=$def_auth;	$domain_auth_def{$domain}=$def_auth;
$domain_auth_arg_def{$domain}=$def_auth_arg;	$domain_auth_arg_def{$domain}=$def_auth_arg;
$domaindescription{$domain}=$domain_description;	$domaindescription{$domain}=$domain_description;
# &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");	$domain_lang_def{$domain}=$def_lang;
	$domain_city{$domain}=$city;
	$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 ".$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 4151 BEGIN {	Line 4919 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 4163 BEGIN {	Line 4932 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);	if ($configline !~ /\S/ \|\| $configline=~/^#/) { next; }
my ($short,$plain)=split(/:/,$configline);	chomp($configline);
my ($pack,$name)=split(/\&/,$short);	my ($short,$plain)=split(/:/,$configline);
if ($plain ne '') {	my ($pack,$name)=split(/\&/,$short);
$packagetab{$pack.'&'.$name.'&name'}=$name;	if ($plain ne '') {
$packagetab{$short}=$plain;	$packagetab{$pack.'&'.$name.'&name'}=$name;
}	$packagetab{$short}=$plain;
	}
}	}
	close($config);
}	}

# ------------- set up temporary directory	# ------------- set up temporary directory
Line 4821 dumps the complete (or key matching rege	Line 5595 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)

Line 4931 messages of critical importance should g	Line 5713 messages of critical importance should g

=item *	=item *

getfile($file) : returns the entire contents of a file or -1; it	getfile($file,$caller) : two cases - requests for files in /res or in /uploaded.
properly subscribes to and replicates the file if neccessary.	(a) files in /uploaded
	(i) If a local copy of the file exists -
	compares modification date of local copy with last-modified date for
	definitive version stored on home server for course. If local copy is
	stale, requests a new version from the home server and stores it.
	If the original has been removed from the home server, then local copy
	is unlinked.
	(ii) If local copy does not exist -
	requests the file from the home server and stores it.

	If $caller is 'uploadrep':
	This indicates a call from lonuploadrep.pm (PerlHeaderParserHandler phase)
	for request for files originally uploaded via DOCS.
	- returns 'ok' if fresh local copy now available, -1 otherwise.

	Otherwise:
	This indicates a call from the content generation phase of the request.
	- returns the entire contents of the file or -1.

	(b) files in /res
	- returns the entire contents of a file or -1;
	it properly subscribes to and replicates the file if neccessary.

=item *	=item *

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

Removed from v.1.397
changed lines
	Added in v.1.488