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.444 and 1.543

version 1.444, 2003/11/10 21:50:21	version 1.543, 2004/09/20 19:54:47
Line 30	Line 30
package Apache::lonnet;	package Apache::lonnet;

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

Line 49 use Fcntl qw(:flock);	Line 50 use Fcntl qw(:flock);
use Apache::loncoursedata;	use Apache::loncoursedata;
use Apache::lonlocal;	use Apache::lonlocal;
use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw);	use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw);
use Time::HiRes();	use Time::HiRes qw( gettimeofday tv_interval );
my $readit;	my $readit;

	=pod

	=head1 Package Variables

	These are largely undocumented, so if you decipher one please note it here.

	=over 4

	=item $processmarker

	Contains the time this process was started and this servers host id.

	=item $dumpcount

	Counts the number of times a message log flush has been attempted (regardless
	of success) by this process. Used as part of the filename when messages are
	delayed.

	=back

	=cut


# --------------------------------------------------------------------- Logging	# --------------------------------------------------------------------- Logging

sub logtouch {	sub logtouch {
my $execdir=$perlvar{'lonDaemons'};	my $execdir=$perlvar{'lonDaemons'};
unless (-e "$execdir/logs/lonnet.log") {	unless (-e "$execdir/logs/lonnet.log") {
my $fh=Apache::File->new(">>$execdir/logs/lonnet.log");	open(my $fh,">>$execdir/logs/lonnet.log");
close $fh;	close $fh;
}	}
my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];	my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];
Line 69 sub logthis {	Line 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 79 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 132 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 180 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 230 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;	my %Remove;
Line 247 sub transfer_profile_to_env {	Line 277 sub transfer_profile_to_env {
}	}
}	}
}	}
	$ENV{'user.environment'} = "$lonidsdir/$handle.id";
foreach my $expired_key (keys(%Remove)) {	foreach my $expired_key (keys(%Remove)) {
&delenv($expired_key);	&delenv($expired_key);
}	}
$ENV{'user.environment'} = "$lonidsdir/$handle.id";
}	}

# ---------------------------------------------------------- Append Environment	# ---------------------------------------------------------- Append Environment
Line 269 sub appenv {	Line 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 324 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 387 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 398 sub overloaderror {	Line 434 sub overloaderror {
if ($overload>0) {	if ($overload>0) {
$r->err_headers_out->{'Retry-After'}=$overload;	$r->err_headers_out->{'Retry-After'}=$overload;
$r->log_error('Overload of '.$overload.' on '.$checkserver);	$r->log_error('Overload of '.$overload.' on '.$checkserver);
return 413;	return 409;
}	}
return '';	return '';
}	}
Line 477 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 517 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 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 645 sub assign_access_key {	Line 642 sub assign_access_key {
# a valid key looks like uname:udom#comments	# a valid key looks like uname:udom#comments
# comments are being appended	# comments are being appended
#	#
my ($ckey,$cdom,$cnum,$udom,$uname,$logentry)=@_;	my ($ckey,$kdom,$knum,$cdom,$cnum,$udom,$uname,$logentry)=@_;
	$kdom=
	$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($kdom));
	$knum=
	$ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($knum));
$cdom=	$cdom=
$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));	$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
$cnum=	$cnum=
$ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));	$ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
$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],$kdom,$knum);
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
# the first time around	# the first time around
# ready to assign	# ready to assign
$logentry=$1.'; '.$logentry;	$logentry=$1.'; '.$logentry;
if (&put('accesskey',{$ckey=>$uname.':'.$udom.'#'.$logentry},	if (&put('accesskeys',{$ckey=>$uname.':'.$udom.'#'.$logentry},
$cdom,$cnum) eq 'ok') {	$kdom,$knum) eq 'ok') {
# key now belongs to user	# key now belongs to user
my $envkey='key.'.$cdom.'_'.$cnum;	my $envkey='key.'.$cdom.'_'.$cnum;
if (&put('environment',{$envkey => $ckey}) eq 'ok') {	if (&put('environment',{$envkey => $ckey}) eq 'ok') {
Line 758 sub validate_access_key {	Line 759 sub validate_access_key {
$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));	$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
$cnum=	$cnum=
$ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));	$ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
$udom=$ENV{'user.name'} unless (defined($udom));	$udom=$ENV{'user.domain'} unless (defined($udom));
$uname=$ENV{'user.domain'} unless (defined($uname));	$uname=$ENV{'user.name'} 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 790 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 820 sub getsection {
return '-1';	return '-1';
}	}


	my $disk_caching_disabled=1;

sub devalidate_cache {	sub devalidate_cache {
my ($cache,$id,$name) = @_;	my ($cache,$id,$name) = @_;
delete $$cache{$id.'.time'};	delete $$cache{$id.'.time'};
	delete $$cache{$id.'.file'};
delete $$cache{$id};	delete $$cache{$id};
	if (1 \|\| $disk_caching_disabled) { return; }
my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";	my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
open(DB,"$filename.lock");	if (!-e $filename) { return; }
	open(DB,">$filename.lock");
flock(DB,LOCK_EX);	flock(DB,LOCK_EX);
my %hash;	my %hash;
if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {	if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
Line 851 sub is_cached {	Line 858 sub is_cached {
my ($cache,$id,$name,$time) = @_;	my ($cache,$id,$name,$time) = @_;
if (!$time) { $time=300; }	if (!$time) { $time=300; }
if (!exists($$cache{$id.'.time'})) {	if (!exists($$cache{$id.'.time'})) {
&load_cache_item($cache,$name,$id);	&load_cache_item($cache,$name,$id,$time);
}	}
if (!exists($$cache{$id.'.time'})) {	if (!exists($$cache{$id.'.time'})) {
# &logthis("Didn't find $id");	# &logthis("Didn't find $id");
return (undef,undef);	return (undef,undef);
} else {	} else {
if (time-($$cache{$id.'.time'})>$time) {	if (time-($$cache{$id.'.time'})>$time) {
# &logthis("Devalidating $id - ".time-($$cache{$id.'.time'}));	if (exists($$cache{$id.'.file'})) {
&devalidate_cache($cache,$id,$name);	foreach my $filename (@{ $$cache{$id.'.file'} }) {
return (undef,undef);	my $mtime=(stat($filename))[9];
	#+1 is to take care of edge effects
	if ($mtime && (($mtime+1) < ($$cache{$id.'.time'}))) {
	# &logthis("Upping $mtime - ".$$cache{$id.'.time'}.
	# "$id because of $filename");
	} else {
	&logthis("Devalidating $filename $id - ".(time-($$cache{$id.'.time'})));
	&devalidate_cache($cache,$id,$name);
	return (undef,undef);
	}
	}
	$$cache{$id.'.time'}=time;
	} else {
	# &logthis("Devalidating $id - ".time-($$cache{$id.'.time'}));
	&devalidate_cache($cache,$id,$name);
	return (undef,undef);
	}
}	}
}	}
return ($$cache{$id},1);	return ($$cache{$id},1);
Line 876 sub do_cache {	Line 899 sub do_cache {
$$cache{$id};	$$cache{$id};
}	}

	my %do_save_item;
	my %do_save;
sub save_cache_item {	sub save_cache_item {
my ($cache,$name,$id)=@_;	my ($cache,$name,$id)=@_;
my $starttime=&Time::HiRes::time();	if ($disk_caching_disabled) { return; }
# &logthis("Saving :$name:$id");	$do_save{$name}=$cache;
my %hash;	if (!exists($do_save_item{$name})) { $do_save_item{$name}={} }
my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";	$do_save_item{$name}->{$id}=1;
open(DB,"$filename.lock");	return;
flock(DB,LOCK_EX);	}
if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
eval <<'EVALBLOCK';	sub save_cache {
$hash{$id.'.time'}=$$cache{$id.'.time'};	if ($disk_caching_disabled) { return; }
$hash{$id}=freeze({'item'=>$$cache{$id}});	my ($cache,$name,$id);
	foreach $name (keys(%do_save)) {
	$cache=$do_save{$name};

	my $starttime=&Time::HiRes::time();
	&logthis("Saving :$name:");
	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)) {
	foreach $id (keys(%{ $do_save_item{$name} })) {
	eval <<'EVALBLOCK';
	$hash{$id.'.time'}=$$cache{$id.'.time'};
	$hash{$id}=freeze({'item'=>$$cache{$id}});
EVALBLOCK	EVALBLOCK
if ($@) {	if ($@) {
&logthis("<font color='red'>save_cache blew up :$@:$name</font>");	&logthis("<font color='red'>save_cache blew up :$@:$name</font>");
unlink($filename);	unlink($filename);
}	last;
} else {	}
if (-e $filename) {	}
&logthis("Unable to tie hash (save cache item): $name");	} else {
unlink($filename);	if (-e $filename) {
	&logthis("Unable to tie hash (save cache): $name ($!)");
	unlink($filename);
	}
}	}
	untie(%hash);
	flock(DB,LOCK_UN);
	close(DB);
	&logthis("save_cache $name took ".(&Time::HiRes::time()-$starttime));
}	}
untie(%hash);	undef(%do_save);
flock(DB,LOCK_UN);	undef(%do_save_item);
close(DB);
# &logthis("save_cache_item $name took ".(&Time::HiRes::time()-$starttime));
}	}

sub load_cache_item {	sub load_cache_item {
my ($cache,$name,$id)=@_;	my ($cache,$name,$id,$time)=@_;
	if ($disk_caching_disabled) { return; }
my $starttime=&Time::HiRes::time();	my $starttime=&Time::HiRes::time();
# &logthis("Before Loading $name for $id size is ".scalar(%$cache));	# &logthis("Before Loading $name for $id size is ".scalar(%$cache));
my %hash;	my %hash;
my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";	my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
open(DB,"$filename.lock");	if (!-e $filename) { return; }
	open(DB,">$filename.lock");
flock(DB,LOCK_SH);	flock(DB,LOCK_SH);
if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) {	if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) {
eval <<'EVALBLOCK';	eval <<'EVALBLOCK';
Line 928 sub load_cache_item {	Line 975 sub load_cache_item {
}	}
# &logthis("Initial load: $count");	# &logthis("Initial load: $count");
} else {	} else {
my $hashref=thaw($hash{$id});	if (($$cache{$id.'.time'}+$time) < time) {
$$cache{$id}=$hashref->{'item'};	$$cache{$id.'.time'}=$hash{$id.'.time'};
$$cache{$id.'.time'}=$hash{$id.'.time'};	my $hashref=thaw($hash{$id});
	$$cache{$id}=$hashref->{'item'};
	}
}	}
EVALBLOCK	EVALBLOCK
if ($@) {	if ($@) {
Line 939 EVALBLOCK	Line 988 EVALBLOCK
}	}
} else {	} else {
if (-e $filename) {	if (-e $filename) {
&logthis("Unable to tie hash (load cache item): $name");	&logthis("Unable to tie hash (load cache item): $name ($!)");
unlink($filename);	unlink($filename);
}	}
}	}
Line 962 sub usection {	Line 1011 sub usection {
&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 1040 sub currentversion {	Line 1089 sub currentversion {
sub subscribe {	sub subscribe {
my $fname=shift;	my $fname=shift;
if ($fname=~/\/(aboutme\|syllabus\|bulletinboard\|smppg)$/) { return ''; }	if ($fname=~/\/(aboutme\|syllabus\|bulletinboard\|smppg)$/) { return ''; }
	$fname=~s/[\n\r]//g;
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 1059 sub subscribe {	Line 1109 sub subscribe {
sub repcopy {	sub repcopy {
my $filename=shift;	my $filename=shift;
$filename=~s/\/+/\//g;	$filename=~s/\/+/\//g;
if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; }	if ($filename=~m\|^/home/httpd/html/adm/\|) { return OK; }
	if ($filename=~m\|^/home/httpd/html/lonUsers/\|) { return OK; }
	if ($filename=~m\|^/home/httpd/html/userfiles/\| or
	$filename=~m\|^/*uploaded/\|) {
	return &repcopy_userfile($filename);
	}
	$filename=~s/[\n\r]//g;
my $transname="$filename.in.transfer";	my $transname="$filename.in.transfer";
if ((-e $filename) \|\| (-e $transname)) { return OK; }	if ((-e $filename) \|\| (-e $transname)) { return OK; }
my $remoteurl=subscribe($filename);	my $remoteurl=subscribe($filename);
Line 1124 sub ssi_body {	Line 1180 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\s\>.$//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;
	$output=~s/^.?\<body[^\>]\>//si;
	$output=~s/(.)\<\/body\s\>.*?$/$1/si;
return $output;	return $output;
}	}

Line 1162 sub externalssi {	Line 1218 sub externalssi {
return $response->content;	return $response->content;
}	}

# ------- Add a token to a remote URI's query string to vouch for access rights	# -------------------------------- Allow a /uploaded/ URI to be vouched for

sub tokenwrapper {	sub allowuploaded {
my $uri=shift;	my ($srcurl,$url)=@_;
$uri=~s/^http\:\/\/([^\/]+)//;	$url=&clutter(&declutter($url));
$uri=~s/^\///;	my $dir=$url;
$ENV{'user.environment'}=~/\/([^\/]+)\.id/;	$dir=~s/\/[^\/]+$//;
my $token=$1;	my %httpref=();
if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.)$/) {	my $httpurl=&hreflocation('',$url);
&appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});	$httpref{'httpref.'.$httpurl}=$srcurl;
return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.	&Apache::lonnet::appenv(%httpref);
(($uri=~/\?/)?'&':'?').'token='.$token.	}
'&tokenissued='.$perlvar{'lonHostID'};
	# --------- 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 {	} else {
return '/adm/notfound.html';	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

sub userfileupload {	sub clean_filename {
my ($formname,$coursedoc)=@_;	my ($fname)=@_;
my $fname=$ENV{'form.'.$formname.'.filename'};
# Replace Windows backslashes by forward slashes	# Replace Windows backslashes by forward slashes
$fname=~s/\\/\//g;	$fname=~s/\\/\//g;
# Get rid of everything but the actual filename	# Get rid of everything but the actual filename
Line 1195 sub userfileupload {	Line 1326 sub userfileupload {
$fname=~s/\s+/\_/g;	$fname=~s/\s+/\_/g;
# Replace all other weird characters by nothing	# Replace all other weird characters by nothing
$fname=~s/[^\w\.\-]//g;	$fname=~s/[^\w\.\-]//g;
	# Replace all .\d. sequences with _\d. so they no longer look like version
	# numbers
	$fname=~s/\.(\d+)(?=\.)/_$1/g;
	return $fname;
	}

	sub userfileupload {
	my ($formname,$coursedoc,$subdir)=@_;
	if (!defined($subdir)) { $subdir='unknown'; }
	my $fname=$ENV{'form.'.$formname.'.filename'};
	$fname=&clean_filename($fname);
# See if there is anything left	# See if there is anything left
unless ($fname) { return 'error: no uploaded file'; }	unless ($fname) { return 'error: no uploaded file'; }
chop($ENV{'form.'.$formname});	chop($ENV{'form.'.$formname});
	if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { #files uploaded to help request form are handled differently
	my $now = time;
	my $filepath = 'tmp/helprequests/'.$now;
	my @parts=split(/\//,$filepath);
	my $fullpath = $perlvar{'lonDaemons'};
	for (my $i=0;$i<@parts;$i++) {
	$fullpath .= '/'.$parts[$i];
	if ((-e $fullpath)!=1) {
	mkdir($fullpath,0777);
	}
	}
	open(my $fh,'>'.$fullpath.'/'.$fname);
	print $fh $ENV{'form.'.$formname};
	close($fh);
	return $fullpath.'/'.$fname;
	}
# Create the directory if not present	# Create the directory if not present
my $docuname='';	my $docuname='';
my $docudom='';	my $docudom='';
my $docuhome='';	my $docuhome='';
	$fname="$subdir/$fname";
if ($coursedoc) {	if ($coursedoc) {
$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 {
my ($docuname,$docudom,$docuhome,$formname,$fname)=@_;	my ($docuname,$docudom,$docuhome,$formname,$fname)=@_;
my $path=$docudom.'/'.$docuname.'/';	my $path=$docudom.'/'.$docuname.'/';
my $filepath=$perlvar{'lonDocRoot'};	my $filepath=$perlvar{'lonDocRoot'};
	my ($fnamepath,$file);
	$file=$fname;
	if ($fname=~m\|/\|) {
	($fnamepath,$file) = ($fname =~ m\|^(.*)/([^/]+)$\|);
	$path.=$fnamepath.'/';
	}
my @parts=split(/\//,$filepath.'/userfiles/'.$path);	my @parts=split(/\//,$filepath.'/userfiles/'.$path);
my $count;	my $count;
for ($count=4;$count<=$#parts;$count++) {	for ($count=4;$count<=$#parts;$count++) {
Line 1229 sub finishuserfileupload {	Line 1399 sub finishuserfileupload {
}	}
# Save the file	# Save the file
{	{
my $fh=Apache::File->new('>'.$filepath.'/'.$fname);	#&Apache::lonnet::logthis("Saving to $filepath $file");
	open(my $fh,'>'.$filepath.'/'.$file);
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:'.$path.$file,$docuhome);
my $fetchresult=
&reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome);
if ($fetchresult eq 'ok') {	if ($fetchresult eq 'ok') {
#	#
# Return the URL to it	# Return the URL to it
return '/uploaded/'.$path.$fname;	return '/uploaded/'.$path.$file;
} else {	} else {
&logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$fname.	&logthis('Failed to transfer '.$path.$file.' to host '.$docuhome.
' to host '.$docuhome.': '.$fetchresult);	': '.$fetchresult);
return '/adm/notfound.html';	return '/adm/notfound.html';
}	}
}	}

	sub removeuploadedurl {
	my ($url)=@_;
	my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);
	return &Apache::lonnet::removeuserfile($uname,$udom,$fname);
	}

	sub removeuserfile {
	my ($docuname,$docudom,$fname)=@_;
	my $home=&homeserver($docuname,$docudom);
	return &reply("removeuserfile:$docudom/$docuname/$fname",$home);
	}

	sub mkdiruserfile {
	my ($docuname,$docudom,$dir)=@_;
	my $home=&homeserver($docuname,$docudom);
	return &reply("mkdiruserfile:".&escape("$docudom/$docuname/$dir"),$home);
	}

	sub renameuserfile {
	my ($docuname,$docudom,$old,$new)=@_;
	my $home=&homeserver($docuname,$docudom);
	return &reply("renameuserfile:$docudom:$docuname:".&escape("$old").':'.
	&escape("$new"),$home);
	}

# ------------------------------------------------------------------------- Log	# ------------------------------------------------------------------------- Log

sub log {	sub log {
Line 1287 sub flushcourselogs {	Line 1482 sub flushcourselogs {
}	}
if ($courseidbuffer{$coursehombuf{$crsid}}) {	if ($courseidbuffer{$coursehombuf{$crsid}}) {
$courseidbuffer{$coursehombuf{$crsid}}.='&'.	$courseidbuffer{$coursehombuf{$crsid}}.='&'.
&escape($crsid).'='.&escape($coursedescrbuf{$crsid});	&escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
	'='.&escape($courseinstcodebuf{$crsid});
} else {	} else {
$courseidbuffer{$coursehombuf{$crsid}}=	$courseidbuffer{$coursehombuf{$crsid}}=
&escape($crsid).'='.&escape($coursedescrbuf{$crsid});	&escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
	'='.&escape($courseinstcodebuf{$crsid});
}	}
}	}
#	#
Line 1304 sub flushcourselogs {	Line 1501 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 1341 sub courselog {	Line 1561 sub courselog {
$ENV{'course.'.$ENV{'request.course.id'}.'.home'};	$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
$coursedescrbuf{$ENV{'request.course.id'}}=	$coursedescrbuf{$ENV{'request.course.id'}}=
$ENV{'course.'.$ENV{'request.course.id'}.'.description'};	$ENV{'course.'.$ENV{'request.course.id'}.'.description'};
	$courseinstcodebuf{$ENV{'request.course.id'}}=
	$ENV{'course.'.$ENV{'request.course.id'}.'.internal.coursecode'};
if (defined $courselogs{$ENV{'request.course.id'}}) {	if (defined $courselogs{$ENV{'request.course.id'}}) {
$courselogs{$ENV{'request.course.id'}}.='&'.$what;	$courselogs{$ENV{'request.course.id'}}.='&'.$what;
} else {	} else {
Line 1368 sub courseacclog {	Line 1590 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 1390 sub userrolelog {	Line 1609 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 1402 sub get_course_adv_roles {	Line 1621 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 1412 sub get_course_adv_roles {	Line 1635 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 1454 sub postannounce {	Line 1679 sub postannounce {
}	}

sub getannounce {	sub getannounce {
if (my $fh=Apache::File->new($perlvar{'lonDocRoot'}.'/announcement.txt')) {
	if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) {
my $announcement='';	my $announcement='';
while (<$fh>) { $announcement .=$_; }	while (<$fh>) { $announcement .=$_; }
$fh->close();	close($fh);
if ($announcement=~/\w/) {	if ($announcement=~/\w/) {
return	return
'<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'.	'<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'.
'<tr><td bgcolor="#FFFFFF"><pre>'.$announcement.'</pre></td></tr></table>';	'<tr><td bgcolor="#FFFFFF"><tt>'.$announcement.'</tt></td></tr></table>';
} else {	} else {
return '';	return '';
}	}
Line 1480 sub courseidput {	Line 1706 sub courseidput {
}	}

sub courseiddump {	sub courseiddump {
my ($domfilter,$descfilter,$sincefilter)=@_;	my ($domfilter,$descfilter,$sincefilter,$hostidflag,$hostidref)=@_;
my %returnhash=();	my %returnhash=();
unless ($domfilter) { $domfilter=''; }	unless ($domfilter) { $domfilter=''; }
foreach my $tryserver (keys %libserv) {	foreach my $tryserver (keys %libserv) {
if ((!$domfilter) \|\| ($hostdom{$tryserver} eq $domfilter)) {	if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) \|\| (!defined($hostidflag)) ) {
foreach (	if ((!$domfilter) \|\| ($hostdom{$tryserver} eq $domfilter)) {
split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.	foreach (
	split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.
$sincefilter.':'.&escape($descfilter),	$sincefilter.':'.&escape($descfilter),
$tryserver))) {	$tryserver))) {
my ($key,$value)=split(/\=/,$_);	my ($key,$value)=split(/\=/,$_);
if (($key) && ($value)) {	if (($key) && ($value)) {
$returnhash{&unescape($key)}=&unescape($value);	$returnhash{&unescape($key)}=$value;
	}
}	}
}	}

}	}
}	}
return %returnhash;	return %returnhash;
Line 1503 sub courseiddump {	Line 1730 sub courseiddump {
#	#
# ----------------------------------------------------------- Check out an item	# ----------------------------------------------------------- Check out an item

	sub get_first_access {
	my ($type,$argsymb)=@_;
	my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
	if ($argsymb) { $symb=$argsymb; }
	my ($map,$id,$res)=&decode_symb($symb);
	if ($type eq 'map') { $res=$map; }
	my %times=&get('firstaccesstimes',[$res],$udom,$uname);
	return $times{$res};
	}

	sub set_first_access {
	my ($type)=@_;
	my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
	my ($map,$id,$res)=&decode_symb($symb);
	if ($type eq 'map') { $res=$map; }
	my $firstaccess=&get_first_access($type);
	if (!$firstaccess) {
	return &put('firstaccesstimes',{$res=>time},$udom,$uname);
	}
	return 'already_set';
	}

sub checkout {	sub checkout {
my ($symb,$tuname,$tudom,$tcrsid)=@_;	my ($symb,$tuname,$tudom,$tcrsid)=@_;
my $now=time;	my $now=time;
Line 1681 sub hash2str {	Line 1930 sub hash2str {
sub hashref2str {	sub hashref2str {
my ($hashref)=@_;	my ($hashref)=@_;
my $result='__HASH_REF__';	my $result='__HASH_REF__';
foreach (keys(%$hashref)) {	foreach (sort(keys(%$hashref))) {
if (ref($_) eq 'ARRAY') {	if (ref($_) eq 'ARRAY') {
$result.=&arrayref2str($_).'=';	$result.=&arrayref2str($_).'=';
} elsif (ref($_) eq 'HASH') {	} elsif (ref($_) eq 'HASH') {
Line 1970 sub store {	Line 2219 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 2003 sub cstore {	Line 2256 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 2085 sub coursedescription {	Line 2341 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 2337 sub convert_dump_to_currentdump{	Line 2623 sub convert_dump_to_currentdump{
return \%returnhash;	return \%returnhash;
}	}

	# --------------------------------------------------------------- inc interface

	sub inc {
	my ($namespace,$store,$udomain,$uname) = @_;
	if (!$udomain) { $udomain=$ENV{'user.domain'}; }
	if (!$uname) { $uname=$ENV{'user.name'}; }
	my $uhome=&homeserver($uname,$udomain);
	my $items='';
	if (! ref($store)) {
	# got a single value, so use that instead
	$items = &escape($store).'=&';
	} elsif (ref($store) eq 'SCALAR') {
	$items = &escape($$store).'=&';
	} elsif (ref($store) eq 'ARRAY') {
	$items = join('=&',map {&escape($_);} @{$store});
	} elsif (ref($store) eq 'HASH') {
	while (my($key,$value) = each(%{$store})) {
	$items.= &escape($key).'='.&escape($value).'&';
	}
	}
	$items=~s/\&$//;
	return &reply("inc:$udomain:$uname:$namespace:$items",$uhome);
	}

# --------------------------------------------------------------- put interface	# --------------------------------------------------------------- put interface

sub put {	sub put {
Line 2352 sub put {	Line 2662 sub put {
return &reply("put:$udomain:$uname:$namespace:$items",$uhome);	return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
}	}

	# ---------------------------------------------------------- putstore interface

	sub putstore {
	my ($namespace,$storehash,$udomain,$uname)=@_;
	if (!$udomain) { $udomain=$ENV{'user.domain'}; }
	if (!$uname) { $uname=$ENV{'user.name'}; }
	my $uhome=&homeserver($uname,$udomain);
	my $items='';
	my %allitems = ();
	foreach (keys %$storehash) {
	if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {
	my $key = $1.':keys:'.$2;
	$allitems{$key} .= $3.':';
	}
	$items.=$_.'='.&escape($$storehash{$_}).'&';
	}
	foreach (keys %allitems) {
	$allitems{$_} =~ s/\:$//;
	$items.= $_.'='.$allitems{$_}.'&';
	}
	$items=~s/\&$//;
	return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
	}

# ------------------------------------------------------ critical put interface	# ------------------------------------------------------ critical put interface

sub cput {	sub cput {
Line 2434 sub allowed {	Line 2768 sub allowed {

if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; }	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 !~ m\|/bulletinboard$\|))
if ((($uri=~/^adm\//) \|\| ($uri=~/\.meta$/)) && ($priv eq 'bre')) {	\|\| ($uri=~/\.meta$/)) && ($priv eq 'bre')) {
return 'F';	return 'F';
}	}

Line 2481 sub allowed {	Line 2815 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 2498 sub allowed {	Line 2832 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;
}	}

# URI is an uploaded document for this course	# URI is an uploaded document for this course

if (($priv eq 'bre') &&	if (($priv eq 'bre') && ($uri=~m\|^uploaded/\|)) {
($uri=~/^uploaded\/$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}\/$ENV{'course.'.$ENV{'request.course.id'}.'.num'}/)) {	my $refuri=$ENV{'httpref.'.$orguri};
return 'F';	if ($refuri) {
	if ($refuri =~ m\|^/adm/\|) {
	$thisallowed='F';
	}
	}
}	}

# Full access at system, domain or course-wide level? Exit.	# Full access at system, domain or course-wide level? Exit.

if ($thisallowed=~/F/) {	if ($thisallowed=~/F/) {
Line 2516 sub allowed {	Line 2855 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 2537 sub allowed {	Line 2876 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 2565 sub allowed {	Line 2904 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 2618 sub allowed {	Line 2957 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 2629 sub allowed {	Line 2968 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 2663 sub allowed {	Line 3002 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 2671 sub allowed {	Line 3010 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 2683 sub allowed {	Line 3022 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 2695 sub allowed {	Line 3034 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 2759 sub definerole {	Line 3098 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 2826 sub log_query {	Line 3165 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);
}	}

	# ------- Request retrieval of institutional classlists for course(s)

	sub fetch_enrollment_query {
	my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;
	my $homeserver;
	if ($context eq 'automated') {
	$homeserver = $perlvar{'lonHostID'};
	} else {
	$homeserver = &homeserver($cnum,$dom);
	}
	my $host=$hostname{$homeserver};
	my $cmd = '';
	foreach (keys %{$affiliatesref}) {
	$cmd .= $_.'='.join(",",@{$$affiliatesref{$_}}).'%%';
	}
	$cmd =~ s/%%$//;
	$cmd = &escape($cmd);
	my $query = 'fetchenrollment';
	my $queryid=&reply("querysend:".$query.':'.$dom.':'.$ENV{'user.name'}.':'.$cmd,$homeserver);
	unless ($queryid=~/^\Q$host\E\_/) {
	&logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum);
	return 'error: '.$queryid;
	}
	my $reply = &get_query_reply($queryid);
	if ( ($reply =~/^timeout/) \|\| ($reply =~/^error/) ) {
	&logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$ENV{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum);
	} else {
	my @responses = split/:/,$reply;
	if ($homeserver eq $perlvar{'lonHostID'}) {
	foreach (@responses) {
	my ($key,$value) = split/=/,$_;
	$$replyref{$key} = $value;
	}
	} else {
	my $pathname = $perlvar{'lonDaemons'}.'/tmp';
	foreach (@responses) {
	my ($key,$value) = split/=/,$_;
	$$replyref{$key} = $value;
	if ($value > 0) {
	foreach (@{$$affiliatesref{$key}}) {
	my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml';
	my $destname = $pathname.'/'.$filename;
	my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver);
	if ($xml_classlist =~ /^error/) {
	&logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum);
	} else {
	if ( open(FILE,">$destname") ) {
	print FILE &unescape($xml_classlist);
	close(FILE);
	} else {
	&logthis('fetch_enrollment_query - error opening classlist file '.$destname.' '.$context.' '.$cnum);
	}
	}
	}
	}
	}
	}
	return 'ok';
	}
	return 'error';
	}

sub get_query_reply {	sub get_query_reply {
my $queryid=shift;	my $queryid=shift;
my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid;	my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid;
Line 2837 sub get_query_reply {	Line 3238 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 2874 sub userlog_query {	Line 3275 sub userlog_query {
return &log_query($uname,$udom,'userlog',%filters);	return &log_query($uname,$udom,'userlog',%filters);
}	}

	#--------- Call auto-enrollment subs in localenroll.pm for homeserver for course

	sub auto_run {
	my ($cnum,$cdom) = @_;
	my $homeserver = &homeserver($cnum,$cdom);
	my $response = &reply('autorun:'.$cdom,$homeserver);
	return $response;
	}

	sub auto_get_sections {
	my ($cnum,$cdom,$inst_coursecode) = @_;
	my $homeserver = &homeserver($cnum,$cdom);
	my @secs = ();
	my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));
	unless ($response eq 'refused') {
	@secs = split/:/,$response;
	}
	return @secs;
	}

	sub auto_new_course {
	my ($cnum,$cdom,$inst_course_id,$owner) = @_;
	my $homeserver = &homeserver($cnum,$cdom);
	my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver));
	return $response;
	}

	sub auto_validate_courseID {
	my ($cnum,$cdom,$inst_course_id) = @_;
	my $homeserver = &homeserver($cnum,$cdom);
	my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver));
	return $response;
	}

	sub auto_create_password {
	my ($cnum,$cdom,$authparam) = @_;
	my $homeserver = &homeserver($cnum,$cdom);
	my $create_passwd = 0;
	my $authchk = '';
	my $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver));
	if ($response eq 'refused') {
	$authchk = 'refused';
	} else {
	($authparam,$create_passwd,$authchk) = split/:/,$response;
	}
	return ($authparam,$create_passwd,$authchk);
	}

	sub auto_instcode_format {
	my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_;
	my $courses = '';
	my $homeserver;
	if ($caller eq 'global') {
	$homeserver = $perlvar{'lonHostID'};
	} else {
	$homeserver = &homeserver($caller,$codedom);
	}
	my $host=$hostname{$homeserver};
	foreach (keys %{$instcodes}) {
	$courses .= &escape($_).'='.&escape($$instcodes{$_}).'&';
	}
	chop($courses);
	my $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$homeserver);
	unless ($response =~ /(con_lost\|error\|no_such_host\|refused)/) {
	my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = split/:/,$response;
	%{$codes} = &str2hash($codes_str);
	@{$codetitles} = &str2array($codetitles_str);
	%{$cat_titles} = &str2hash($cat_titles_str);
	%{$cat_order} = &str2hash($cat_order_str);
	return 'ok';
	}
	return $response;
	}

# ------------------------------------------------------------------ Plain Text	# ------------------------------------------------------------------ Plain Text

sub plaintext {	sub plaintext {
Line 3064 sub modifyuser {	Line 3539 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,$locktype,$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 3077 sub modifystudent {	Line 3553 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,$locktype,$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,$locktype,$cid) = @_;
# Get the course id from the environment	my ($cdom,$cnum,$chome);
my $cid='';	if (!$cid) {
unless ($cid=$ENV{'request.course.id'}) {	unless ($cid=$ENV{'request.course.id'}) {
return 'not_in_class';	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 3107 sub modify_student_enrollment {	Line 3592 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 3118 sub modify_student_enrollment {	Line 3603 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,$locktype) },
&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 3157 sub writecoursepref {	Line 3641 sub writecoursepref {
# ---------------------------------------------------------- Make/modify course	# ---------------------------------------------------------- Make/modify course

sub createcourse {	sub createcourse {
my ($udom,$description,$url,$course_server,$nonstandard)=@_;	my ($udom,$description,$url,$course_server,$nonstandard,$inst_code)=@_;
$url=&declutter($url);	$url=&declutter($url);
my $cid='';	my $cid='';
unless (&allowed('ccc',$udom)) {	unless (&allowed('ccc',$udom)) {
Line 3190 sub createcourse {	Line 3674 sub createcourse {
return 'error: no such course';	return 'error: no such course';
}	}
# ----------------------------------------------------------------- Course made	# ----------------------------------------------------------------- Course made
# log existance	# log existence
&courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description),	&courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).
$uhome);	'='.&escape($inst_code),$uhome);
&flushcourselogs();	&flushcourselogs();
# set toplevel url	# set toplevel url
my $topurl=$url;	my $topurl=$url;
Line 3245 sub revokecustomrole {	Line 3729 sub revokecustomrole {
$deleteflag);	$deleteflag);
}	}

	# ------------------------------------------------------------ Disk usage
	sub diskusage {
	my ($udom,$uname,$directoryRoot)=@_;
	$directoryRoot =~ s/\/$//;
	my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom));
	return $listing;
	}


# ------------------------------------------------------------ Directory lister	# ------------------------------------------------------------ Directory lister

sub dirlist {	sub dirlist {
Line 3578 sub EXT {	Line 4071 sub EXT {

my $section;	my $section;
if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) {	if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) {
	if (!$symbparm) { $symbparm=&symbread(); }
	}
	if ($symbparm && defined($courseid) &&
	$courseid eq $ENV{'request.course.id'}) {

#print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;	#print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;

# ----------------------------------------------------- Cascading lookup scheme	# ----------------------------------------------------- Cascading lookup scheme
if (!$symbparm) { $symbparm=&symbread(); }
my $symbp=$symbparm;	my $symbp=$symbparm;
my $mapp=(&decode_symb($symbp))[0];	my $mapp=(&decode_symb($symbp))[0];

Line 3593 sub EXT {	Line 4089 sub EXT {
($ENV{'user.domain'} eq $udom)) {	($ENV{'user.domain'} eq $udom)) {
$section=$ENV{'request.course.sec'};	$section=$ENV{'request.course.sec'};
} else {	} else {
if (! defined($usection)) {	if (! defined($usection)) {
$section=&usection($udom,$uname,$courseid);	$section=&usection($udom,$uname,$courseid);
} else {	} else {
$section = $usection;	$section = $usection;
}	}
}	}

my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;	my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
Line 3614 sub EXT {	Line 4110 sub EXT {
my $hashid="$udom:$uname";	my $hashid="$udom:$uname";
my ($result,$cached)=&is_cached(\%userresdatacache,$hashid,	my ($result,$cached)=&is_cached(\%userresdatacache,$hashid,
'userres');	'userres');
if (!defined($cached)) {	if (!defined($cached)) {
my %resourcedata=&get('resourcedata',	my %resourcedata=&dump('resourcedata',$udom,$uname);
[$courselevelr,$courselevelm,
$courselevel],$udom,$uname);
$result=\%resourcedata;	$result=\%resourcedata;
&do_cache(\%userresdatacache,$hashid,$result,'userres');	&do_cache(\%userresdatacache,$hashid,$result,'userres');
}	}
Line 3630 sub EXT {	Line 4124 sub EXT {
if ($$result{$courselevel}) {	if ($$result{$courselevel}) {
return $$result{$courselevel}; }	return $$result{$courselevel}; }
} else {	} else {
if ($tmp!~/No such file/) {	#error 2 occurs when the .db doesn't exist
	if ($tmp!~/error: 2 /) {
&logthis("<font color=blue>WARNING:".	&logthis("<font color=blue>WARNING:".
" Trying to get resource data for ".	" Trying to get resource data for ".
$uname." at ".$udom.": ".	$uname." at ".$udom.": ".
$tmp."</font>");	$tmp."</font>");
} elsif ($tmp=~/error:No such file/) {	} elsif ($tmp=~/error: 2 /) {
&EXT_cache_set($udom,$uname);	&EXT_cache_set($udom,$uname);
} elsif ($tmp =~ /^(con_lost\|no_such_host)/) {	} elsif ($tmp =~ /^(con_lost\|no_such_host)/) {
return $tmp;	return $tmp;
}	}
Line 3646 sub EXT {	Line 4141 sub EXT {
# -------------------------------------------------------- second, check course	# -------------------------------------------------------- second, check course

my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'},	my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'},
$ENV{'course.'.$courseid.'.domain'},	$ENV{'course.'.$courseid.'.domain'},
($seclevelr,$seclevelm,$seclevel,	($seclevelr,$seclevelm,$seclevel,
$courselevelr,$courselevelm,	$courselevelr,$courselevelm,
$courselevel));	$courselevel));
if (defined($coursereply)) { return $coursereply; }	if (defined($coursereply)) { return $coursereply; }

# ------------------------------------------------------ third, check map parms	# ------------------------------------------------------ third, check map parms
Line 3717 sub packages_tab_default {	Line 4212 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 3746 sub metadata {	Line 4244 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\|/bulletinboard$\|)) \|\|
($uri =~ m\|/$\|) \|\| ($uri =~ m\|/.meta$\|) \|\| ($uri =~ /^~/) \|\|	($uri =~ m\|/$\|) \|\| ($uri =~ m\|/.meta$\|) \|\| ($uri =~ /^~/) \|\|
($uri =~ m\|home/[^/]+/public_html/\|)) {	($uri =~ m\|home/[^/]+/public_html/\|)) {
return '';	return undef;
}	}
my $filename=$uri;	my $filename=$uri;
$uri=~s/\.meta$//;	$uri=~s/\.meta$//;
Line 3766 sub metadata {	Line 4266 sub metadata {
#	#
# Is this a recursive call for a library?	# Is this a recursive call for a library?
#	#
my %lcmetacache;	if (! exists($metacache{$uri})) {
	$metacache{$uri}={};
	}
if ($liburi) {	if ($liburi) {
$liburi=&declutter($liburi);	$liburi=&declutter($liburi);
$filename=$liburi;	$filename=$liburi;
Line 3775 sub metadata {	Line 4277 sub metadata {
}	}
my %metathesekeys=();	my %metathesekeys=();
unless ($filename=~/\.meta$/) { $filename.='.meta'; }	unless ($filename=~/\.meta$/) { $filename.='.meta'; }
my $metastring=&getfile(&filelocation('',&clutter($filename)));	my $metastring;
	if ($uri !~ m\|^uploaded/\|) {
	my $file=&filelocation('',&clutter($filename));
	push(@{$metacache{$uri.'.file'}},$file);
	$metastring=&getfile($file);
	}
my $parser=HTML::LCParser->new(\$metastring);	my $parser=HTML::LCParser->new(\$metastring);
my $token;	my $token;
undef %metathesekeys;	undef %metathesekeys;
Line 3790 sub metadata {	Line 4297 sub metadata {
if (defined($token->[2]->{'id'})) {	if (defined($token->[2]->{'id'})) {
$keyroot.='_'.$token->[2]->{'id'};	$keyroot.='_'.$token->[2]->{'id'};
}	}
if ($lcmetacache{':packages'}) {	if ($metacache{$uri}->{':packages'}) {
$lcmetacache{':packages'}.=','.$package.$keyroot;	$metacache{$uri}->{':packages'}.=','.$package.$keyroot;
} else {	} else {
$lcmetacache{':packages'}=$package.$keyroot;	$metacache{$uri}->{':packages'}=$package.$keyroot;
}	}
foreach (keys %packagetab) {	foreach (keys %packagetab) {
my $part=$keyroot;	my $part=$keyroot;
Line 3815 sub metadata {	Line 4322 sub metadata {
if ($subp eq 'display') {	if ($subp eq 'display') {
$value.=' [Part: '.$part.']';	$value.=' [Part: '.$part.']';
}	}
$lcmetacache{':'.$unikey.'.part'}=$part;	$metacache{$uri}->{':'.$unikey.'.part'}=$part;
$metathesekeys{$unikey}=1;	$metathesekeys{$unikey}=1;
unless (defined($lcmetacache{':'.$unikey.'.'.$subp})) {	unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) {
$lcmetacache{':'.$unikey.'.'.$subp}=$value;	$metacache{$uri}->{':'.$unikey.'.'.$subp}=$value;
}	}
if (defined($lcmetacache{':'.$unikey.'.default'})) {	if (defined($metacache{$uri}->{':'.$unikey.'.default'})) {
$lcmetacache{':'.$unikey}=	$metacache{$uri}->{':'.$unikey}=
$lcmetacache{':'.$unikey.'.default'};	$metacache{$uri}->{':'.$unikey.'.default'};
}	}
}	}
}	}
Line 3855 sub metadata {	Line 4362 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 3865 sub metadata {	Line 4373 sub metadata {
}	}
$metathesekeys{$unikey}=1;	$metathesekeys{$unikey}=1;
foreach (@{$token->[3]}) {	foreach (@{$token->[3]}) {
$lcmetacache{':'.$unikey.'.'.$_}=$token->[2]->{$_};	$metacache{$uri}->{':'.$unikey.'.'.$_}=$token->[2]->{$_};
}	}
my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));	my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
my $default=$lcmetacache{':'.$unikey.'.default'};	my $default=$metacache{$uri}->{':'.$unikey.'.default'};
if ( $internaltext =~ /^\s$/ && $default !~ /^\s$/) {	if ( $internaltext =~ /^\s$/ && $default !~ /^\s$/) {
# only ws inside the tag, and not in default, so use default	# only ws inside the tag, and not in default, so use default
# as value	# as value
$lcmetacache{':'.$unikey}=$default;	$metacache{$uri}->{':'.$unikey}=$default;
} else {	} else {
# either something interesting inside the tag or default	# either something interesting inside the tag or default
# uninteresting	# uninteresting
$lcmetacache{':'.$unikey}=$internaltext;	$metacache{$uri}->{':'.$unikey}=$internaltext;
}	}
# end of not-a-package not-a-library import	# end of not-a-package not-a-library import
}	}
Line 3885 sub metadata {	Line 4393 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 ($lcmetacache{':copyright'} eq 'custom') {	if ($metacache{$uri}->{':copyright'} eq 'custom') {

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

	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 {
my ($metadata,$metacache,$uri) = @_;	my ($metadata,$metacache,$uri) = @_;
my %allnames;	my %allnames;
Line 3935 sub metadata_generate_part0 {	Line 4484 sub metadata_generate_part0 {
my $olddis=$$metacache{':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 3945 sub metadata_generate_part0 {	Line 4494 sub metadata_generate_part0 {
sub gettitle {	sub gettitle {
my $urlsymb=shift;	my $urlsymb=shift;
my $symb=&symbread($urlsymb);	my $symb=&symbread($urlsymb);
unless ($symb) {	if ($symb) {
unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; }	my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);
return &metadata($urlsymb,'title');	if (defined($cached)) { return $result; }
}	my ($map,$resid,$url)=&decode_symb($symb);
my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);	my $title='';
if (defined($cached)) { return $result; }	my %bighash;
my ($map,$resid,$url)=&decode_symb($symb);	if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
my $title='';	&GDBM_READER(),0640)) {
my %bighash;	my $mapid=$bighash{'map_pc_'.&clutter($map)};
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',	$title=$bighash{'title_'.$mapid.'.'.$resid};
&GDBM_READER(),0640)) {	untie %bighash;
my $mapid=$bighash{'map_pc_'.&clutter($map)};	}
$title=$bighash{'title_'.$mapid.'.'.$resid};	$title=~s/\&colon\;/\:/gs;
untie %bighash;	if ($title) {
}	return &do_cache(\%titlecache,$symb,$title,'title');
$title=~s/\&colon\;/\:/gs;	}
if ($title) {	$urlsymb=$url;
return &do_cache(\%titlecache,$symb,$title,'title');
} else {
return &metadata($urlsymb,'title');
}	}
	my $title=&metadata($urlsymb,'title');
	if (!$title) { $title=(split('/',$urlsymb))[-1]; }
	return $title;
}	}

# ------------------------------------------------- Update symbolic store links	# ------------------------------------------------- Update symbolic store links
Line 3991 sub symblist {	Line 4540 sub symblist {
# --------------------------------------------------------------- Verify a symb	# --------------------------------------------------------------- Verify a symb

sub symbverify {	sub symbverify {
my ($symb,$thisfn)=@_;	my ($symb,$thisurl)=@_;
	my $thisfn=$thisurl;
	# wrapper not part of symbs
	$thisfn=~s/^\/adm\/wrapper//;
$thisfn=&declutter($thisfn);	$thisfn=&declutter($thisfn);
# direct jump to resource in page or to a sequence - will construct own symbs	# direct jump to resource in page or to a sequence - will construct own symbs
if ($thisfn=~/\.(page\|sequence)$/) { return 1; }	if ($thisfn=~/\.(page\|sequence)$/) { return 1; }
Line 4001 sub symbverify {	Line 4553 sub symbverify {
unless ($url eq $thisfn) { return 0; }	unless ($url eq $thisfn) { return 0; }

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

my %bighash;	my %bighash;
Line 4008 sub symbverify {	Line 4561 sub symbverify {

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($thisurl)};
unless ($ids) {	unless ($ids) {
$ids=$bighash{'ids_/'.$thisfn};	$ids=$bighash{'ids_/'.$thisurl};
}	}
if ($ids) {	if ($ids) {
# ------------------------------------------------------------------- Has ID(s)	# ------------------------------------------------------------------- Has ID(s)
Line 4039 sub symbclean {	Line 4592 sub symbclean {
# remove version from URL	# remove version from URL
$symb=~s/\.(\d+)\.(\w+)$/\.$2/;	$symb=~s/\.(\d+)\.(\w+)$/\.$2/;

	# remove wrapper

	$symb=~s/(\_\_\_\d+\_\_\_)adm\/wrapper\/(res\/)*/$1/;
return $symb;	return $symb;
}	}

Line 4090 sub deversion {	Line 4646 sub deversion {

sub symbread {	sub symbread {
my ($thisfn,$donotrecurse)=@_;	my ($thisfn,$donotrecurse)=@_;
	my $cache_str='request.symbread.cached.'.$thisfn;
	if (defined($ENV{$cache_str})) { return $ENV{$cache_str}; }
# no filename provided? try from environment	# no filename provided? try from environment
unless ($thisfn) {	unless ($thisfn) {
if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); }	if ($ENV{'request.symb'}) {
	return $ENV{$cache_str}=&symbclean($ENV{'request.symb'});
	}
$thisfn=$ENV{'request.filename'};	$thisfn=$ENV{'request.filename'};
}	}
# is that filename actually a symb? Verify, clean, and return	# is that filename actually a symb? Verify, clean, and return
if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {	if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {
if (&symbverify($thisfn,$1)) { return &symbclean($thisfn); }	if (&symbverify($thisfn,$1)) {
	return $ENV{$cache_str}=&symbclean($thisfn);
	}
}	}
$thisfn=declutter($thisfn);	$thisfn=declutter($thisfn);
my %hash;	my %hash;
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 4114 sub symbread {	Line 4680 sub symbread {
unless ($syval=~/\_\d+$/) {	unless ($syval=~/\_\d+$/) {
unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {	unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {
&appenv('request.ambiguous' => $thisfn);	&appenv('request.ambiguous' => $thisfn);
return '';	return $ENV{$cache_str}='';
}	}
$syval.=$1;	$syval.=$1;
}	}
Line 4158 sub symbread {	Line 4724 sub symbread {
}	}
}	}
untie(%bighash)	untie(%bighash)
}	}
}	}
if ($syval) {	if ($syval) {
return &symbclean($syval.'___'.$thisfn);	return $ENV{$cache_str}=&symbclean($syval.'___'.$thisfn);
}	}
}	}
&appenv('request.ambiguous' => $thisfn);	&appenv('request.ambiguous' => $thisfn);
return '';	return $ENV{$cache_str}='';
}	}

# ---------------------------------------------------------- Return random seed	# ---------------------------------------------------------- Return random seed
Line 4182 sub numval {	Line 4748 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 '64bit2';	return '64bit3';
	}

	sub get_rand_alg {
	my ($courseid)=@_;
	if (!$courseid) { $courseid=(&Apache::lonxml::whichuser())[1]; }
	if ($courseid) {
	return $ENV{"course.$courseid.rndseed"};
	}
	return &latest_rnd_algorithm_id();
	}

	sub getCODE {
	if (defined($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; }
	if (defined($Apache::lonhomework::parsing_a_problem) &&
	defined($Apache::lonhomework::history{'resource.CODE'})) {
	return $Apache::lonhomework::history{'resource.CODE'};
	}
	return undef;
}	}

sub rndseed {	sub rndseed {
Line 4196 sub rndseed {	Line 4795 sub rndseed {
if (!$courseid) { $courseid=$wcourseid; }	if (!$courseid) { $courseid=$wcourseid; }
if (!$domain) { $domain=$wdomain; }	if (!$domain) { $domain=$wdomain; }
if (!$username) { $username=$wusername }	if (!$username) { $username=$wusername }
my $which=$ENV{"course.$courseid.rndseed"};	my $which=&get_rand_alg();
my $CODE=$ENV{'scantron.CODE'};	if (defined(&getCODE())) {
if (defined($CODE)) {	return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);
&rndseed_CODE_64bit($symb,$courseid,$domain,$username);	} elsif ($which eq '64bit3') {
	return &rndseed_64bit3($symb,$courseid,$domain,$username);
} elsif ($which eq '64bit2') {	} elsif ($which eq '64bit2') {
return &rndseed_64bit2($symb,$courseid,$domain,$username);	return &rndseed_64bit2($symb,$courseid,$domain,$username);
} elsif ($which eq '64bit') {	} elsif ($which eq '64bit') {
Line 4267 sub rndseed_64bit2 {	Line 4867 sub rndseed_64bit2 {
}	}
}	}

	sub rndseed_64bit3 {
	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=numval2($symb) << 10;
	my $namechck=unpack("%32S*",$username.' ');

	my $nameseed=numval2($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*",&getCODE().' ') << 16;
	my $CODEseed=numval(&getCODE());
my $courseseed=unpack("%32S*",$courseid.' ');	my $courseseed=unpack("%32S*",$courseid.' ');
my $num1=$symbseed+$CODEseed;	my $num1=$symbseed+$CODEchck;
my $num2=$courseseed+$symbchck;	my $num2=$CODEseed+$courseseed+$symbchck;
#&Apache::lonxml::debug("$symbseed:$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";
}	}
}	}

sub setup_random_from_rndseed {	sub setup_random_from_rndseed {
my ($rndseed)=@_;	my ($rndseed)=@_;
if ($rndseed =~/,/) {	if ($rndseed =~/([,:])/) {
my ($num1,$num2)=split(/,/,$rndseed);	my ($num1,$num2)=split(/[,:]/,$rndseed);
&Math::Random::random_set_seed(abs($num1),abs($num2));	&Math::Random::random_set_seed(abs($num1),abs($num2));
} else {	} else {
&Math::Random::random_set_seed_from_phrase($rndseed);	&Math::Random::random_set_seed_from_phrase($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) = @_;
if ($file=~/^\/*uploaded\//) { # user file
	if ($file =~ m\|^/*uploaded/\|) { $file=&filelocation("",$file); }
	&repcopy($file);
	return &readfile($file);
	}

	sub repcopy_userfile {
	my ($file)=@_;

	if ($file =~ m\|^/*uploaded/\|) { $file=&filelocation("",$file); }
	if ($file =~ m\|^/home/httpd/html/lonUsers/\|) { return OK; }

	my ($cdom,$cnum,$filename) =
	($file=~m\|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)\|);
	my ($info,$rtncode);
	my $uri="/uploaded/$cdom/$cnum/$filename";
	if (-e "$file") {
	my @fileinfo = stat($file);
	my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode);
	if ($lwpresp ne 'ok') {
	if ($rtncode eq '404') {
	unlink($file);
	}
	#my $ua=new LWP::UserAgent;
	#my $request=new HTTP::Request('GET',&tokenwrapper($uri));
	#my $response=$ua->request($request);
	#if ($response->is_success()) {
	# return $response->content;
	# } else {
	# return -1;
	# }
	return -1;
	}
	if ($info < $fileinfo[9]) {
	return OK;
	}
	$info = '';
	$lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);
	if ($lwpresp ne 'ok') {
	return -1;
	}
	} else {
	my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);
	if ($lwpresp ne 'ok') {
	my $ua=new LWP::UserAgent;
	my $request=new HTTP::Request('GET',&tokenwrapper($uri));
	my $response=$ua->request($request);
	if ($response->is_success()) {
	$info=$response->content;
	} else {
	return -1;
	}
	}
	my @parts = ($cdom,$cnum);
	if ($filename =~ m\|^(.+)/[^/]+$\|) {
	push @parts, split(/\//,$1);
	}
	my $path = $perlvar{'lonDocRoot'}.'/userfiles';
	foreach my $part (@parts) {
	$path .= '/'.$part;
	if (!-e $path) {
	mkdir($path,0770);
	}
	}
	}
	open(FILE,">$file");
	print FILE $info;
	close(FILE);
	return OK;
	}

	sub tokenwrapper {
	my $uri=shift;
	$uri=~s/^http\:\/\/([^\/]+)//;
	$uri=~s/^\///;
	$ENV{'user.environment'}=~/\/([^\/]+)\.id/;
	my $token=$1;
	if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.)$/) {
	&appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});
	return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.
	(($uri=~/\?/)?'&':'?').'token='.$token.
	'&tokenissued='.$perlvar{'lonHostID'};
	} else {
	return '/adm/notfound.html';
	}
	}

	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 4345 sub filelocation {	Line 5117 sub filelocation {
$location = $file;	$location = $file;
$location =~ s:/~(.?)/(.):/home/$1/public_html/$2:;	$location =~ s:/~(.?)/(.):/home/$1/public_html/$2:;
} elsif ($file=~/^\/*uploaded/) { # is an uploaded file	} elsif ($file=~/^\/*uploaded/) { # is an uploaded file
$location=$file;	my ($udom,$uname,$filename)=
	($file=~m\|^/+uploaded/+([^/]+)/+([^/]+)/+(.*)$\|);
	my $home=&homeserver($uname,$udom);
	my $is_me=0;
	my @ids=&current_machine_ids();
	foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
	if ($is_me) {
	$location=&Apache::loncommon::propath($udom,$uname).
	'/userfiles/'.$filename;
	} else {
	$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
	$udom.'/'.$uname.'/'.$filename;
	}
} 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 4357 sub filelocation {	Line 5141 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 4387 sub declutter {	Line 5199 sub declutter {

sub clutter {	sub clutter {
my $thisfn='/'.&declutter(shift);	my $thisfn='/'.&declutter(shift);
unless ($thisfn=~/^\/(uploaded\|adm\|userfiles\|ext\|raw\|priv)\//) {	unless ($thisfn=~/^\/(uploaded\|adm\|userfiles\|ext\|raw\|priv\|public)\//) {
$thisfn='/res'.$thisfn;	$thisfn='/res'.$thisfn;
}	}
return $thisfn;	return $thisfn;
Line 4446 BEGIN {	Line 5258 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 4466 BEGIN {	Line 5279 BEGIN {
$perlvar{$varname}=$varvalue;	$perlvar{$varname}=$varvalue;
}	}
}	}
	close($config);
}	}

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

# &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");	# &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");
# &logthis("Domain.tab: $domain ".$domaindescription{$domain} );	# &logthis("Domain.tab: $domain ".$domaindescription{$domain} );
}	}
}	}
	close ($fh);
}	}


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

while (my $configline=<$config>) {	while (my $configline=<$config>) {
next if ($configline =~ /^(\#\|\s*$)/);	next if ($configline =~ /^(\#\|\s*$)/);
Line 4511 BEGIN {	Line 5325 BEGIN {
$hostip{$id}=$ip;	$hostip{$id}=$ip;
$iphost{$ip}=$id;	$iphost{$ip}=$id;
if ($role eq 'library') { $libserv{$id}=$name; }	if ($role eq 'library') { $libserv{$id}=$name; }
} else {
if ($configline) {
&logthis("Skipping hosts.tab line -$configline-");
}
}	}
}	}
	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 4529 BEGIN {	Line 5340 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 5187 dumps the complete (or key matching rege	Line 6003 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)

=item *	=item *

	putstore($namespace,$storehash,$udomain,$uname) : stores hash in namesp
	keys used in storehash include version information (e.g., 1:$symb:message etc.) as
	used in records written by &store and retrieved by &restore. This function
	was created for use in editing discussion posts, without incrementing the
	version number included in the key for a particular post. The colon
	separated list of attribute names (e.g., the value associated with the key
	1:keys:$symb) is also generated and passed in the ampersand separated
	items sent to lonnet::reply().

	=item *

cput($namespace,$storehash,$udom,$uname) : critical put	cput($namespace,$storehash,$udom,$uname) : critical put
($udom and $uname are optional)	($udom and $uname are optional)

Line 5297 messages of critical importance should g	Line 6132 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.444
changed lines
	Added in v.1.543