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.387 and 1.454

version 1.387, 2003/07/05 10:07:11	version 1.454, 2003/12/05 00:28:32
Line 25	Line 25
#	#
# http://www.lon-capa.org/	# http://www.lon-capa.org/
#	#
# 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30,
# 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19,
# 11/8,11/16,11/18,11/22,11/23,12/22,
# 01/06,01/13,02/24,02/28,02/29,
# 03/01,03/02,03/06,03/07,03/13,
# 04/05,05/29,05/31,06/01,
# 06/05,06/26 Gerd Kortemeyer
# 06/26 Ben Tyszka
# 06/30,07/15,07/17,07/18,07/20,07/21,07/22,07/25 Gerd Kortemeyer
# 08/14 Ben Tyszka
# 08/22,08/28,08/31,09/01,09/02,09/04,09/05,09/25,09/28,09/30 Gerd Kortemeyer
# 10/04 Gerd Kortemeyer
# 10/04 Guy Albertelli
# 10/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29,
# 10/30,10/31,
# 11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25,11/27,
# 12/02,12/12,12/13,12/14,12/28,12/29 Gerd Kortemeyer
# 05/01/01 Guy Albertelli
# 05/01,06/01,09/01 Gerd Kortemeyer
# 09/01 Guy Albertelli
# 09/01,10/01,11/01 Gerd Kortemeyer
# YEAR=2001
# 3/2 Gerd Kortemeyer
# 3/19,3/20 Gerd Kortemeyer
# 5/26,5/28 Gerd Kortemeyer
# 5/30 H. K. Ng
# 6/1 Gerd Kortemeyer
# July Guy Albertelli
# 8/4,8/7,8/8,8/9,8/11,8/16,8/17,8/18,8/20,8/23,9/20,9/21,9/26,
# 10/2 Gerd Kortemeyer
# 11/17,11/20,11/22,11/29 Gerd Kortemeyer
# 12/5 Matthew Hall
# 12/5 Guy Albertelli
# 12/6,12/7,12/12 Gerd Kortemeyer
# 12/21,12/22,12/27,12/28 Gerd Kortemeyer
# YEAR=2002
# 1/4,2/4,2/7 Gerd Kortemeyer
#
###	###

package Apache::lonnet;	package Apache::lonnet;

use strict;	use strict;
use Apache::File;
use LWP::UserAgent();	use LWP::UserAgent();
use HTTP::Headers;	use HTTP::Headers;
use vars	use vars
qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom	qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom
%libserv %pr %prp %metacache %packagetab %titlecache	%libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache
%courselogs %accesshash %userrolehash $processmarker $dumpcount	%courselogs %accesshash %userrolehash $processmarker $dumpcount
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache	%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache
%domaindescription %domain_auth_def %domain_auth_arg_def $tmpdir);	%userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def
	%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir);

use IO::Socket;	use IO::Socket;
use GDBM_File;	use GDBM_File;
use Apache::Constants qw(:common :http);	use Apache::Constants qw(:common :http);
use HTML::LCParser;	use HTML::LCParser;
use Fcntl qw(:flock);	use Fcntl qw(:flock);
use Apache::loncoursedata;	use Apache::loncoursedata;
	use Apache::lonlocal;
	use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw);
	use Time::HiRes();
my $readit;	my $readit;

	=pod

	=head1 Package Variables

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

	=over 4

	=item $processmarker

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

	=item $dumpcount

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

	=back

	=cut


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

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

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

Line 166 sub reconlonc {	Line 158 sub reconlonc {
my $peerfile=shift;	my $peerfile=shift;
&logthis("Trying to reconnect for $peerfile");	&logthis("Trying to reconnect for $peerfile");
my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";	my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
if (my $fh=Apache::File->new("$loncfile")) {	if (open(my $fh,"<$loncfile")) {
my $loncpid=<$fh>;	my $loncpid=<$fh>;
chomp($loncpid);	chomp($loncpid);
if (kill 0 => $loncpid) {	if (kill 0 => $loncpid) {
Line 214 sub critical {	Line 206 sub critical {
"$perlvar{'lonSockDir'}/delayed/$now.$dumpcount.$$.$middlename.$server";	"$perlvar{'lonSockDir'}/delayed/$now.$dumpcount.$$.$middlename.$server";
$dumpcount++;	$dumpcount++;
{	{
my $dfh;	my $dfh;
if ($dfh=Apache::File->new(">$dfilename")) {	if (open($dfh,">$dfilename")) {
print $dfh "$cmd\n";	print $dfh "$cmd\n";
}	close($dfh);
	}
}	}
sleep 2;	sleep 2;
my $wcmd='';	my $wcmd='';
{	{
my $dfh;	my $dfh;
if ($dfh=Apache::File->new("$dfilename")) {	if (open($dfh,"<$dfilename")) {
$wcmd=<$dfh>;	$wcmd=<$dfh>;
}	close($dfh);
	}
}	}
chomp($wcmd);	chomp($wcmd);
if ($wcmd eq $cmd) {	if ($wcmd eq $cmd) {
Line 243 sub critical {	Line 237 sub critical {
}	}
return $answer;	return $answer;
}	}

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

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

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

Line 250 sub transfer_profile_to_env {	Line 258 sub transfer_profile_to_env {
my ($lonidsdir,$handle)=@_;	my ($lonidsdir,$handle)=@_;
my @profile;	my @profile;
{	{
my $idf=Apache::File->new("$lonidsdir/$handle.id");	open(my $idf,"$lonidsdir/$handle.id");
flock($idf,LOCK_SH);	flock($idf,LOCK_SH);
@profile=<$idf>;	@profile=<$idf>;
$idf->close();	close($idf);
}	}
my $envi;	my $envi;
	my %Remove;
for ($envi=0;$envi<=$#profile;$envi++) {	for ($envi=0;$envi<=$#profile;$envi++) {
chomp($profile[$envi]);	chomp($profile[$envi]);
my ($envname,$envvalue)=split(/=/,$profile[$envi]);	my ($envname,$envvalue)=split(/=/,$profile[$envi]);
$ENV{$envname} = $envvalue;	$ENV{$envname} = $envvalue;
	if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
	if ($time < time-300) {
	$Remove{$key}++;
	}
	}
}	}
$ENV{'user.environment'} = "$lonidsdir/$handle.id";	$ENV{'user.environment'} = "$lonidsdir/$handle.id";
	foreach my $expired_key (keys(%Remove)) {
	&delenv($expired_key);
	}
}	}

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

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

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

$lockfh->close();	close($lockfh);
return 'ok';	return 'ok';
}	}
# ----------------------------------------------------- Delete from Environment	# ----------------------------------------------------- Delete from Environment
Line 335 sub delenv {	Line 352 sub delenv {
}	}
my @oldenv;	my @oldenv;
{	{
my $fh;	my $fh;
unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {	unless (open($fh,"$ENV{'user.environment'}")) {
return 'error';	return 'error';
}	}
unless (flock($fh,LOCK_SH)) {	unless (flock($fh,LOCK_SH)) {
&logthis("<font color=blue>WARNING: ".	&logthis("<font color=blue>WARNING: ".
'Could not obtain shared lock in delenv: '.$!);	'Could not obtain shared lock in delenv: '.$!);
$fh->close();	close($fh);
return 'error: '.$!;	return 'error: '.$!;
}	}
@oldenv=<$fh>;	@oldenv=<$fh>;
$fh->close();	close($fh);
}	}
{	{
my $fh;	my $fh;
unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) {	unless (open($fh,">$ENV{'user.environment'}")) {
return 'error';	return 'error';
}	}
unless (flock($fh,LOCK_EX)) {	unless (flock($fh,LOCK_EX)) {
&logthis("<font color=blue>WARNING: ".	&logthis("<font color=blue>WARNING: ".
'Could not obtain exclusive lock in delenv: '.$!);	'Could not obtain exclusive lock in delenv: '.$!);
$fh->close();	close($fh);
return 'error: '.$!;	return 'error: '.$!;
}	}
foreach (@oldenv) {	foreach (@oldenv) {
unless ($_=~/^$delthis/) { print $fh $_; }	unless ($_=~/^$delthis/) { print $fh $_; }
}	}
$fh->close();	close($fh);
}	}
return 'ok';	return 'ok';
}	}
Line 377 sub userload {	Line 394 sub userload {
my $curtime=time;	my $curtime=time;
while ($filename=readdir(LONIDS)) {	while ($filename=readdir(LONIDS)) {
if ($filename eq '.' \|\| $filename eq '..') {next;}	if ($filename eq '.' \|\| $filename eq '..') {next;}
my ($atime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[8];	my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
if ($curtime-$atime < 3600) { $numusers++; }	if ($curtime-$mtime < 1800) { $numusers++; }
}	}
closedir(LONIDS);	closedir(LONIDS);
}	}
Line 398 sub overloaderror {	Line 415 sub overloaderror {
unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; }	unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; }
my $loadavg;	my $loadavg;
if ($checkserver eq $perlvar{'lonHostID'}) {	if ($checkserver eq $perlvar{'lonHostID'}) {
my $loadfile=Apache::File->new('/proc/loadavg');	open(my $loadfile,'/proc/loadavg');
$loadavg=<$loadfile>;	$loadavg=<$loadfile>;
$loadavg =~ s/\s.*//g;	$loadavg =~ s/\s.*//g;
$loadavg = 100*$loadavg/$perlvar{'lonLoadLim'};	$loadavg = 100*$loadavg/$perlvar{'lonLoadLim'};
	close($loadfile);
} else {	} else {
$loadavg=&reply('load',$checkserver);	$loadavg=&reply('load',$checkserver);
}	}
Line 424 sub spareserver {	Line 442 sub spareserver {
my $lowestserver=$loadpercent > $userloadpercent?	my $lowestserver=$loadpercent > $userloadpercent?
$loadpercent : $userloadpercent;	$loadpercent : $userloadpercent;
foreach $tryserver (keys %spareid) {	foreach $tryserver (keys %spareid) {
my $loadans=reply('load',$tryserver);	my $loadans=reply('load',$tryserver);
my $userloadans=reply('userload',$tryserver);	my $userloadans=reply('userload',$tryserver);
if ($userloadans !~ /\d/) { $userloadans=0; }	if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
my $answer=$loadans > $userloadans?	next; #didn't get a number from the server
$loadans : $userloadans;	}
if (($answer =~ /\d/) && ($answer<$lowestserver)) {	my $answer;
$spareserver="http://$hostname{$tryserver}";	if ($loadans =~ /\d/) {
$lowestserver=$answer;	if ($userloadans =~ /\d/) {
}	#both are numbers, pick the bigger one
	$answer=$loadans > $userloadans?
	$loadans : $userloadans;
	} else {
	$answer = $loadans;
	}
	} else {
	$answer = $userloadans;
	}
	if (($answer =~ /\d/) && ($answer<$lowestserver)) {
	$spareserver="http://$hostname{$tryserver}";
	$lowestserver=$answer;
	}
}	}
return $spareserver;	return $spareserver;
}	}
Line 556 sub authenticate {	Line 586 sub authenticate {
sub homeserver {	sub homeserver {
my ($uname,$udom,$ignoreBadCache)=@_;	my ($uname,$udom,$ignoreBadCache)=@_;
my $index="$uname:$udom";	my $index="$uname:$udom";
if ($homecache{$index}) {
return "$homecache{$index}";	my ($result,$cached)=&is_cached(\%homecache,$index,'home',86400);
}	if (defined($cached)) { return $result; }
my $tryserver;	my $tryserver;
foreach $tryserver (keys %libserv) {	foreach $tryserver (keys %libserv) {
next if ($ignoreBadCache ne 'true' &&	next if ($ignoreBadCache ne 'true' &&
Line 566 sub homeserver {	Line 596 sub homeserver {
if ($hostdom{$tryserver} eq $udom) {	if ($hostdom{$tryserver} eq $udom) {
my $answer=reply("home:$udom:$uname",$tryserver);	my $answer=reply("home:$udom:$uname",$tryserver);
if ($answer eq 'found') {	if ($answer eq 'found') {
$homecache{$index}=$tryserver;	return &do_cache(\%homecache,$index,$tryserver,'home');
return $tryserver;
} elsif ($answer eq 'no_host') {	} elsif ($answer eq 'no_host') {
$badServerCache{$tryserver}=1;	$badServerCache{$tryserver}=1;
}	}
Line 819 sub getsection {	Line 848 sub getsection {
return '-1';	return '-1';
}	}


	my $disk_caching_disabled=1;

	sub devalidate_cache {
	my ($cache,$id,$name) = @_;
	delete $$cache{$id.'.time'};
	delete $$cache{$id};
	if ($disk_caching_disabled) { return; }
	my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
	open(DB,"$filename.lock");
	flock(DB,LOCK_EX);
	my %hash;
	if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
	eval <<'EVALBLOCK';
	delete($hash{$id});
	delete($hash{$id.'.time'});
	EVALBLOCK
	if ($@) {
	&logthis("<font color='red'>devalidate_cache blew up :$@:$name</font>");
	unlink($filename);
	}
	} else {
	if (-e $filename) {
	&logthis("Unable to tie hash (devalidate cache): $name");
	unlink($filename);
	}
	}
	untie(%hash);
	flock(DB,LOCK_UN);
	close(DB);
	}

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

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

	sub save_cache_item {
	my ($cache,$name,$id)=@_;
	if ($disk_caching_disabled) { return; }
	my $starttime=&Time::HiRes::time();
	# &logthis("Saving :$name:$id");
	my %hash;
	my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
	open(DB,"$filename.lock");
	flock(DB,LOCK_EX);
	if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
	eval <<'EVALBLOCK';
	$hash{$id.'.time'}=$$cache{$id.'.time'};
	$hash{$id}=freeze({'item'=>$$cache{$id}});
	EVALBLOCK
	if ($@) {
	&logthis("<font color='red'>save_cache blew up :$@:$name</font>");
	unlink($filename);
	}
	} else {
	if (-e $filename) {
	&logthis("Unable to tie hash (save cache item): $name ($!)");
	unlink($filename);
	}
	}
	untie(%hash);
	flock(DB,LOCK_UN);
	close(DB);
	# &logthis("save_cache_item $name took ".(&Time::HiRes::time()-$starttime));
	}

	sub load_cache_item {
	my ($cache,$name,$id)=@_;
	if ($disk_caching_disabled) { return; }
	my $starttime=&Time::HiRes::time();
	# &logthis("Before Loading $name for $id size is ".scalar(%$cache));
	my %hash;
	my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
	open(DB,"$filename.lock");
	flock(DB,LOCK_SH);
	if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) {
	eval <<'EVALBLOCK';
	if (!%$cache) {
	my $count;
	while (my ($key,$value)=each(%hash)) {
	$count++;
	if ($key =~ /\.time$/) {
	$$cache{$key}=$value;
	} else {
	my $hashref=thaw($value);
	$$cache{$key}=$hashref->{'item'};
	}
	}
	# &logthis("Initial load: $count");
	} else {
	my $hashref=thaw($hash{$id});
	$$cache{$id}=$hashref->{'item'};
	$$cache{$id.'.time'}=$hash{$id.'.time'};
	}
	EVALBLOCK
	if ($@) {
	&logthis("<font color='red'>load_cache blew up :$@:$name</font>");
	unlink($filename);
	}
	} else {
	if (-e $filename) {
	&logthis("Unable to tie hash (load cache item): $name ($!)");
	unlink($filename);
	}
	}
	untie(%hash);
	flock(DB,LOCK_UN);
	close(DB);
	# &logthis("After Loading $name size is ".scalar(%$cache));
	# &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime));
	}

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

	my ($result,$cached)=&is_cached(\%usectioncache,$hashid,'usection');
	if (defined($cached)) { return $result; }
$courseid=~s/\_/\//g;	$courseid=~s/\_/\//g;
$courseid=~s/^(\w)/\/$1/;	$courseid=~s/^(\w)/\/$1/;
foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',	foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
Line 839 sub usection {	Line 1009 sub usection {
if ($end) {	if ($end) {
if ($now>$end) { $notactive=1; }	if ($now>$end) { $notactive=1; }
}	}
unless ($notactive) { return $section; }	unless ($notactive) {
	return &do_cache(\%usectioncache,$hashid,$section,'usection');
	}
}	}
}	}
return '-1';	return &do_cache(\%usectioncache,$hashid,'-1','usection');
}	}

# ------------------------------------- Read an entry from a user's environment	# ------------------------------------- Read an entry from a user's environment
Line 882 sub getversion {	Line 1054 sub getversion {

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

# ----------------------------- Subscribe to a resource, return URL if possible	# ----------------------------- Subscribe to a resource, return URL if possible
Line 928 sub repcopy {	Line 1102 sub repcopy {
&logthis("Subscribe returned $remoteurl: $filename");	&logthis("Subscribe returned $remoteurl: $filename");
return HTTP_SERVICE_UNAVAILABLE;	return HTTP_SERVICE_UNAVAILABLE;
} elsif ($remoteurl eq 'not_found') {	} elsif ($remoteurl eq 'not_found') {
&logthis("Subscribe returned not_found: $filename");	#&logthis("Subscribe returned not_found: $filename");
return HTTP_NOT_FOUND;	return HTTP_NOT_FOUND;
} elsif ($remoteurl =~ /^rejected by/) {	} elsif ($remoteurl =~ /^rejected by/) {
&logthis("Subscribe returned $remoteurl: $filename");	&logthis("Subscribe returned $remoteurl: $filename");
Line 985 sub ssi_body {	Line 1159 sub ssi_body {
my ($filelink,%form)=@_;	my ($filelink,%form)=@_;
my $output=($filelink=~/^http\:/?&externalssi($filelink):	my $output=($filelink=~/^http\:/?&externalssi($filelink):
&ssi($filelink,%form));	&ssi($filelink,%form));
$output=~s/^.\<body[^\>]\>//si;	$output=~s/^.?\<body[^\>]\>//si;
$output=~s/\<\/body\s\>.$//si;	$output=~s/(.)\<\/body\s\>.*?$/$1/si;
$output=~	$output=~
s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs;	s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs;
return $output;	return $output;
Line 1090 sub finishuserfileupload {	Line 1264 sub finishuserfileupload {
}	}
# Save the file	# Save the file
{	{
my $fh=Apache::File->new('>'.$filepath.'/'.$fname);	open(my $fh,'>'.$filepath.'/'.$fname);
print $fh $ENV{'form.'.$formname};	print $fh $ENV{'form.'.$formname};
	close($fh);
}	}
# Notify homeserver to grep it	# Notify homeserver to grep it
#	#
Line 1165 sub flushcourselogs {	Line 1340 sub flushcourselogs {
# File accesses	# File accesses
# Writes to the dynamic metadata of resources to get hit counts, etc.	# Writes to the dynamic metadata of resources to get hit counts, etc.
#	#
foreach (keys %accesshash) {	foreach my $entry (keys(%accesshash)) {
my $entry=$_;	my ($dom,$name,undef,$type)=($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:);
$entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/;	if ($type eq 'count'){
my %temphash=($entry => $accesshash{$entry});	my $value = $accesshash{$entry};
if (&Apache::lonnet::put('nohist_resevaldata',\%temphash,$1,$2) eq 'ok') {	my (undef,$url,undef) = ($entry =~ /^(.)___(.)___count$/);
delete $accesshash{$entry};	my %temphash=($url => $value);
	my $result = &inc('nohist_accesscount',\%temphash,$dom,$name);
	if ($result eq 'ok') {
	delete $accesshash{$entry};
	} elsif ($result eq 'unknown_cmd') {
	# Target server has old code running on it.
	my %temphash=($entry => $value);
	if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
	delete $accesshash{$entry};
	}
	}
	} else {
	my %temphash=($entry => $accesshash{$entry});
	if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
	delete $accesshash{$entry};
	}
}	}
}	}
#	#
Line 1207 sub courselog {	Line 1397 sub courselog {
} else {	} else {
$courselogs{$ENV{'request.course.id'}}.=$what;	$courselogs{$ENV{'request.course.id'}}.=$what;
}	}
if (length($courselogs{$ENV{'request.course.id'}})>4048) {	# if (length($courselogs{$ENV{'request.course.id'}})>4048) {
	if (length($courselogs{$ENV{'request.course.id'}})>48) {
&flushcourselogs();	&flushcourselogs();
}	}
}	}
Line 1216 sub courseacclog {	Line 1407 sub courseacclog {
my $fnsymb=shift;	my $fnsymb=shift;
unless ($ENV{'request.course.id'}) { return ''; }	unless ($ENV{'request.course.id'}) { return ''; }
my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'};	my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'};
if ($fnsymb=~/(problem\|exam\|quiz\|assess\|survey\|form)$/) {	if ($fnsymb=~/(problem\|exam\|quiz\|assess\|survey\|form\|page)$/) {
$what.=':POST';	$what.=':POST';
foreach (keys %ENV) {	foreach (keys %ENV) {
if ($_=~/^form\.(.*)/) {	if ($_=~/^form\.(.*)/) {
Line 1232 sub countacc {	Line 1423 sub countacc {
unless ($ENV{'request.course.id'}) { return ''; }	unless ($ENV{'request.course.id'}) { return ''; }
$accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1;	$accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1;
my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';	my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';
if (defined($accesshash{$key})) {	$accesshash{$key}++;
$accesshash{$key}++;
} else {
$accesshash{$key}=1;
}
}	}

sub linklog {	sub linklog {
Line 1284 sub get_course_adv_roles {	Line 1471 sub get_course_adv_roles {
return %returnhash;	return %returnhash;
}	}

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

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

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

	sub getannounce {

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

# ---------------------------------------------------------- Course ID routines	# ---------------------------------------------------------- Course ID routines
# Deal with domain's nohist_courseid.db files	# Deal with domain's nohist_courseid.db files
#	#
Line 1425 sub devalidate {	Line 1660 sub devalidate {
my ($symb,$uname,$udom)=@_;	my ($symb,$uname,$udom)=@_;
my $cid=$ENV{'request.course.id'};	my $cid=$ENV{'request.course.id'};
if ($cid) {	if ($cid) {
# delete the stored spreadsheets for	# delete the stored spreadsheets for
# - the student level sheet of this user in course's homespace	# - the student level sheet of this user in course's homespace
# - the assessment level sheet for this resource	# - the assessment level sheet for this resource
# for this user in user's homespace	# for this user in user's homespace
my $key=$uname.':'.$udom.':';	my $key=$uname.':'.$udom.':';
my $status=	my $status=
&del('nohist_calculatedsheets',	&del('nohist_calculatedsheets',
[$key.'studentcalc'],	[$key.'studentcalc:'],
$ENV{'course.'.$cid.'.domain'},	$ENV{'course.'.$cid.'.domain'},
$ENV{'course.'.$cid.'.num'})	$ENV{'course.'.$cid.'.num'})
.' '.	.' '.
&del('nohist_calculatedsheets_'.$cid,	&del('nohist_calculatedsheets_'.$cid,
[$key.'assesscalc:'.$symb]);	[$key.'assesscalc:'.$symb],$udom,$uname);
unless ($status eq 'ok ok') {	unless ($status eq 'ok ok') {
&logthis('Could not devalidate spreadsheet '.	&logthis('Could not devalidate spreadsheet '.
$uname.' at '.$udom.' for '.	$uname.' at '.$udom.' for '.
Line 1784 sub store {	Line 2019 sub store {
}	}
}	}
if (!$home) { $home=$ENV{'user.home'}; }	if (!$home) { $home=$ENV{'user.home'}; }

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

my $namevalue='';	my $namevalue='';
foreach (keys %$storehash) {	foreach (keys %$storehash) {
$namevalue.=escape($_).'='.escape($$storehash{$_}).'&';	$namevalue.=escape($_).'='.escape($$storehash{$_}).'&';
Line 1817 sub cstore {	Line 2056 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 1936 sub rolesinit {	Line 2178 sub rolesinit {
my ($tdummy,$tdomain,$trest)=split(/\//,$area);	my ($tdummy,$tdomain,$trest)=split(/\//,$area);
if ($trole =~ /^cr\//) {	if ($trole =~ /^cr\//) {
my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);	my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
my $homsvr=homeserver($rauthor,$rdomain);	my $homsvr=homeserver($rauthor,$rdomain);
if ($hostname{$homsvr} ne '') {	if ($hostname{$homsvr} ne '') {
my $roledef=	my ($rdummy,$roledef)=
reply("get:$rdomain:$rauthor:roles:rolesdef_$rrole",	&get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);
$homsvr);
if (($roledef ne 'con_lost') && ($roledef ne '')) {	if (($rdummy ne 'con_lost') && ($roledef ne '')) {
my ($syspriv,$dompriv,$coursepriv)=	my ($syspriv,$dompriv,$coursepriv)=
split(/\_/,unescape($roledef));	split(/\_/,$roledef);
if (defined($syspriv)) {	if (defined($syspriv)) {
$allroles{'cm./'}.=':'.$syspriv;	$allroles{'cm./'}.=':'.$syspriv;
$allroles{$spec.'./'}.=':'.$syspriv;	$allroles{$spec.'./'}.=':'.$syspriv;
Line 2077 sub dump {	Line 2319 sub dump {
return %returnhash;	return %returnhash;
}	}

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

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

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

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

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

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

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

sub put {	sub put {
Line 2209 sub customaccess {	Line 2497 sub customaccess {
$access=($effect eq 'allow');	$access=($effect eq 'allow');
last;	last;
}	}
	if ($realm eq '' && $role eq '') {
	$access=($effect eq 'allow');
	}
}	}
return $access;	return $access;
}	}
Line 2217 sub customaccess {	Line 2508 sub customaccess {

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

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

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

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

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

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

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

sub definerole {	sub definerole {
if (allowed('mcr','/')) {	if (allowed('mcr','/')) {
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'}!~/$crole/) { return "refused:s:$crole"; }
if ($pr{'cr:s'}=~/$crole\&/) {	if ($pr{'cr:s'}=~/$crole\&/) {
Line 2530 sub definerole {	Line 2846 sub definerole {
}	}
}	}
}	}
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'}!~/$crole/) { return "refused:d:$crole"; }
if ($pr{'cr:d'}=~/$crole\&/) {	if ($pr{'cr:d'}=~/$crole\&/) {
Line 2539 sub definerole {	Line 2855 sub definerole {
}	}
}	}
}	}
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'}!~/$crole/) { return "refused:c:$crole"; }
if ($pr{'cr:c'}=~/$crole\&/) {	if ($pr{'cr:c'}=~/$crole\&/) {
Line 2601 sub get_query_reply {	Line 2917 sub get_query_reply {
for (1..100) {	for (1..100) {
sleep 2;	sleep 2;
if (-e $replyfile.'.end') {	if (-e $replyfile.'.end') {
if (my $fh=Apache::File->new($replyfile)) {	if (open(my $fh,$replyfile)) {
$reply.=<$fh>;	$reply.=<$fh>;
$fh->close;	close($fh);
} else { return 'error: reply_file_error'; }	} else { return 'error: reply_file_error'; }
return &unescape($reply);	return &unescape($reply);
}	}
Line 2642 sub userlog_query {	Line 2958 sub userlog_query {

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

# ----------------------------------------------------------------- Assign Role	# ----------------------------------------------------------------- Assign Role
Line 2651 sub assignrole {	Line 2967 sub assignrole {
my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_;	my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_;
my $mrole;	my $mrole;
if ($role =~ /^cr\//) {	if ($role =~ /^cr\//) {
unless (&allowed('ccr',$url)) {	my $cwosec=$url;
	$cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
	unless (&allowed('ccr',$cwosec)) {
&logthis('Refused custom assignrole: '.	&logthis('Refused custom assignrole: '.
$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.	$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
$ENV{'user.name'}.' at '.$ENV{'user.domain'});	$ENV{'user.name'}.' at '.$ENV{'user.domain'});
Line 2744 sub modifyuser {	Line 3062 sub modifyuser {
' in domain '.$ENV{'request.role.domain'});	' in domain '.$ENV{'request.role.domain'});
my $uhome=&homeserver($uname,$udom,'true');	my $uhome=&homeserver($uname,$udom,'true');
# ----------------------------------------------------------------- Create User	# ----------------------------------------------------------------- Create User
if (($uhome eq 'no_host') && ($umode) && ($upass)) {	if (($uhome eq 'no_host') &&
	(($umode && $upass) \|\| ($umode eq 'localauth'))) {
my $unhome='';	my $unhome='';
if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) {	if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) {
$unhome = $desiredhome;	$unhome = $desiredhome;
Line 2801 sub modifyuser {	Line 3120 sub modifyuser {
} else {	} else {
%names = @tmp;	%names = @tmp;
}	}
	#
if (defined($first)) { $names{'firstname'} = $first; }	# Make sure to not trash student environment if instructor does not bother
	# to supply name and email information
	#
	if ($first) { $names{'firstname'} = $first; }
if (defined($middle)) { $names{'middlename'} = $middle; }	if (defined($middle)) { $names{'middlename'} = $middle; }
if (defined($last)) { $names{'lastname'} = $last; }	if ($last) { $names{'lastname'} = $last; }
if (defined($gene)) { $names{'generation'} = $gene; }	if (defined($gene)) { $names{'generation'} = $gene; }
if (defined($email)) { $names{'notification'} = $email;	if ($email) { $names{'notification'} = $email;
$names{'critnotification'} = $email; }	$names{'critnotification'} = $email; }

my $reply = &put('environment', \%names, $udom,$uname);	my $reply = &put('environment', \%names, $udom,$uname);
if ($reply ne 'ok') { return 'error: '.$reply; }	if ($reply ne 'ok') { return 'error: '.$reply; }
Line 3065 sub dirlist {	Line 3387 sub dirlist {
}	}
my $alldomstr='';	my $alldomstr='';
foreach (sort keys %alldom) {	foreach (sort keys %alldom) {
$alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:';	$alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'/&domain:';
}	}
$alldomstr=~s/:$//;	$alldomstr=~s/:$//;
return split(/:/,$alldomstr);	return split(/:/,$alldomstr);
Line 3081 sub dirlist {	Line 3403 sub dirlist {
# when it was last modified. It will also return an error of -1	# when it was last modified. It will also return an error of -1
# if an error occurs	# if an error occurs

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

# --------------------------------------------------- Course Resourcedata Query	# --------------------------------------------------- Course Resourcedata Query
Line 3166 sub courseresdata {	Line 3495 sub courseresdata {
my ($coursenum,$coursedomain,@which)=@_;	my ($coursenum,$coursedomain,@which)=@_;
my $coursehom=&homeserver($coursenum,$coursedomain);	my $coursehom=&homeserver($coursenum,$coursedomain);
my $hashid=$coursenum.':'.$coursedomain;	my $hashid=$coursenum.':'.$coursedomain;
my $dodump=0;	my ($result,$cached)=&is_cached(\%courseresdatacache,$hashid,'courseres');
if (!defined($courseresdatacache{$hashid.'.time'})) {	unless (defined($cached)) {
$dodump=1;
} else {
if (time-$courseresdatacache{$hashid.'.time'}>300) { $dodump=1; }
}
if ($dodump) {
my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum);	my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum);
	$result=\%dumpreply;
my ($tmp) = keys(%dumpreply);	my ($tmp) = keys(%dumpreply);
if ($tmp !~ /^(con_lost\|error\|no_such_host)/i) {	if ($tmp !~ /^(con_lost\|error\|no_such_host)/i) {
$courseresdatacache{$hashid.'.time'}=time;	&do_cache(\%courseresdatacache,$hashid,$result,'courseres');
$courseresdatacache{$hashid}=\%dumpreply;
} elsif ($tmp =~ /^(con_lost\|no_such_host)/) {	} elsif ($tmp =~ /^(con_lost\|no_such_host)/) {
return $tmp;	return $tmp;
	} elsif ($tmp =~ /^(error)/) {
	$result=undef;
	&do_cache(\%courseresdatacache,$hashid,$result,'courseres');
}	}
}	}
foreach my $item (@which) {	foreach my $item (@which) {
if (defined($courseresdatacache{$hashid}->{$item})) {	if (defined($result->{$item})) {
return $courseresdatacache{$hashid}->{$item};	return $result->{$item};
}	}
}	}
return undef;	return undef;
Line 3201 sub clear_EXT_cache_status {	Line 3528 sub clear_EXT_cache_status {
sub EXT_cache_status {	sub EXT_cache_status {
my ($target_domain,$target_user) = @_;	my ($target_domain,$target_user) = @_;
my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;	my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
if (exists($ENV{$cachename}) && ($ENV{$cachename}+1800) > time) {	if (exists($ENV{$cachename}) && ($ENV{$cachename}+600) > time) {
# We know already the user has no data	# We know already the user has no data
return 1;	return 1;
} else {	} else {
Line 3217 sub EXT_cache_set {	Line 3544 sub EXT_cache_set {

# --------------------------------------------------------- Value of a Variable	# --------------------------------------------------------- Value of a Variable
sub EXT {	sub EXT {
my ($varname,$symbparm,$udom,$uname,$usection)=@_;	my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_;

unless ($varname) { return ''; }	unless ($varname) { return ''; }
#get real user name/domain, courseid and symb	#get real user name/domain, courseid and symb
my $courseid;	my $courseid;
my $publicuser;	my $publicuser;
	if ($symbparm) {
	$symbparm=&get_symb_from_alias($symbparm);
	}
if (!($uname && $udom)) {	if (!($uname && $udom)) {
(my $cursymb,$courseid,$udom,$uname,$publicuser)=	(my $cursymb,$courseid,$udom,$uname,$publicuser)=
&Apache::lonxml::whichuser($symbparm);	&Apache::lonxml::whichuser($symbparm);
Line 3308 sub EXT {	Line 3638 sub EXT {
} elsif ($realm eq 'request') {	} elsif ($realm eq 'request') {
# ------------------------------------------------------------- request.browser	# ------------------------------------------------------------- request.browser
if ($space eq 'browser') {	if ($space eq 'browser') {
return $ENV{'browser.'.$qualifier};	if ($qualifier eq 'textremote') {
	if (&mt('textual_remote_display') eq 'on') {
	return 1;
	} else {
	return 0;
	}
	} else {
	return $ENV{'browser.'.$qualifier};
	}
# ------------------------------------------------------------ request.filename	# ------------------------------------------------------------ request.filename
} else {	} else {
return $ENV{'request.'.$spacequalifierrest};	return $ENV{'request.'.$spacequalifierrest};
Line 3318 sub EXT {	Line 3656 sub EXT {
return $ENV{'course.'.$courseid.'.'.$spacequalifierrest};	return $ENV{'course.'.$courseid.'.'.$spacequalifierrest};
} elsif ($realm eq 'resource') {	} elsif ($realm eq 'resource') {

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

#print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;	#print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
Line 3325 sub EXT {	Line 3664 sub EXT {
# ----------------------------------------------------- Cascading lookup scheme	# ----------------------------------------------------- Cascading lookup scheme
if (!$symbparm) { $symbparm=&symbread(); }	if (!$symbparm) { $symbparm=&symbread(); }
my $symbp=$symbparm;	my $symbp=$symbparm;
my $mapp=(split(/\_\_\_/,$symbp))[0];	my $mapp=(&decode_symb($symbp))[0];

my $symbparm=$symbp.'.'.$spacequalifierrest;	my $symbparm=$symbp.'.'.$spacequalifierrest;
my $mapparm=$mapp.'___(all).'.$spacequalifierrest;	my $mapparm=$mapp.'___(all).'.$spacequalifierrest;

my $section;
if (($ENV{'user.name'} eq $uname) &&	if (($ENV{'user.name'} eq $uname) &&
($ENV{'user.domain'} eq $udom)) {	($ENV{'user.domain'} eq $udom)) {
$section=$ENV{'request.course.sec'};	$section=$ENV{'request.course.sec'};
Line 3352 sub EXT {	Line 3690 sub EXT {

# ----------------------------------------------------------- first, check user	# ----------------------------------------------------------- first, check user
#most student don\'t have any data set, check if there is some data	#most student don\'t have any data set, check if there is some data
#every thirty minutes
if (! &EXT_cache_status($udom,$uname)) {	if (! &EXT_cache_status($udom,$uname)) {
my %resourcedata=&get('resourcedata',	my $hashid="$udom:$uname";
[$courselevelr,$courselevelm,$courselevel],	my ($result,$cached)=&is_cached(\%userresdatacache,$hashid,
$udom,$uname);	'userres');
my ($tmp)=keys(%resourcedata);	if (!defined($cached)) {
	my %resourcedata=&dump('resourcedata',$udom,$uname);
	$result=\%resourcedata;
	&do_cache(\%userresdatacache,$hashid,$result,'userres');
	}
	my ($tmp)=keys(%$result);
if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {	if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {
if ($resourcedata{$courselevelr}) {	if ($$result{$courselevelr}) {
return $resourcedata{$courselevelr}; }	return $$result{$courselevelr}; }
if ($resourcedata{$courselevelm}) {	if ($$result{$courselevelm}) {
return $resourcedata{$courselevelm}; }	return $$result{$courselevelm}; }
if ($resourcedata{$courselevel}) {	if ($$result{$courselevel}) {
return $resourcedata{$courselevel}; }	return $$result{$courselevel}; }
} else {	} else {
if ($tmp!~/No such file/) {	if ($tmp!~/No such file/) {
&logthis("<font color=blue>WARNING:".	&logthis("<font color=blue>WARNING:".
Line 3405 sub EXT {	Line 3747 sub EXT {
my $filename;	my $filename;
if (!$symbparm) { $symbparm=&symbread(); }	if (!$symbparm) { $symbparm=&symbread(); }
if ($symbparm) {	if ($symbparm) {
$filename=(split(/\_\_\_/,$symbparm))[2];	$filename=(&decode_symb($symbparm))[2];
} else {	} else {
$filename=$ENV{'request.filename'};	$filename=$ENV{'request.filename'};
}	}
Line 3421 sub EXT {	Line 3763 sub EXT {
my $part=join('_',@parts);	my $part=join('_',@parts);
if ($part eq '') { $part='0'; }	if ($part eq '') { $part='0'; }
my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,	my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
$symbparm,$udom,$uname);	$symbparm,$udom,$uname,$section,1);
if (defined($partgeneral)) { return $partgeneral; }	if (defined($partgeneral)) { return $partgeneral; }
}	}
	if ($recurse) { return undef; }
	my $pack_def=&packages_tab_default($filename,$varname);
	if (defined($pack_def)) { return $pack_def; }

# ---------------------------------------------------- Any other user namespace	# ---------------------------------------------------- Any other user namespace
} elsif ($realm eq 'environment') {	} elsif ($realm eq 'environment') {
Line 3444 sub EXT {	Line 3789 sub EXT {
return '';	return '';
}	}

	sub packages_tab_default {
	my ($uri,$varname)=@_;
	my (undef,$part,$name)=split(/\./,$varname);
	my $packages=&metadata($uri,'packages');
	foreach my $package (split(/,/,$packages)) {
	my ($pack_type,$pack_part)=split(/_/,$package,2);
	if ($pack_part eq $part) {
	return $packagetab{"$pack_type&$name&default"};
	}
	}
	return undef;
	}

sub add_prefix_and_part {	sub add_prefix_and_part {
my ($prefix,$part)=@_;	my ($prefix,$part)=@_;
my $keyroot;	my $keyroot;
Line 3464 sub add_prefix_and_part {	Line 3822 sub add_prefix_and_part {

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

$uri=&declutter($uri);	$uri=&declutter($uri);
# if it is a non metadata possible uri return quickly	# if it is a non metadata possible uri return quickly
if (($uri eq '') \|\| (($uri =~ m\|^/*adm/\|) && ($uri !~ m\|^adm/includes\|)) \|\|	if (($uri eq '') \|\| (($uri =~ m\|^/*adm/\|) && ($uri !~ m\|^adm/includes\|)) \|\|
($uri =~ m\|/$\|) \|\| ($uri =~ m\|/.meta$\|)) {	($uri =~ m\|/$\|) \|\| ($uri =~ m\|/.meta$\|) \|\| ($uri =~ /^~/) \|\|
	($uri =~ m\|home/[^/]+/public_html/\|)) {
return '';	return '';
}	}
my $filename=$uri;	my $filename=$uri;
Line 3478 sub metadata {	Line 3836 sub metadata {
# Look at timestamp of caching	# Look at timestamp of caching
# Everything is cached by the main uri, libraries are never directly cached	# Everything is cached by the main uri, libraries are never directly cached
#	#
unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600 && !defined($liburi)) {	if (!defined($liburi)) {
	my ($result,$cached)=&is_cached(\%metacache,$uri,'meta');
	if (defined($cached)) { return $result->{':'.$what}; }
	}
	{
#	#
# Is this a recursive call for a library?	# Is this a recursive call for a library?
#	#
	if (! exists($metacache{$uri})) {
	$metacache{$uri}={};
	}
if ($liburi) {	if ($liburi) {
$liburi=&declutter($liburi);	$liburi=&declutter($liburi);
$filename=$liburi;	$filename=$liburi;
}	} else {
	&devalidate_cache(\%metacache,$uri,'meta');
	}
my %metathesekeys=();	my %metathesekeys=();
unless ($filename=~/\.meta$/) { $filename.='.meta'; }	unless ($filename=~/\.meta$/) { $filename.='.meta'; }
my $metastring=&getfile(&filelocation('',&clutter($filename)));	my $metastring=&getfile(&filelocation('',&clutter($filename)));
my $parser=HTML::LCParser->new(\$metastring);	my $parser=HTML::LCParser->new(\$metastring);
my $token;	my $token;
undef %metathesekeys;	undef %metathesekeys;
delete($metacache{$uri.':packages'});
while ($token=$parser->get_token) {	while ($token=$parser->get_token) {
if ($token->[0] eq 'S') {	if ($token->[0] eq 'S') {
if (defined($token->[2]->{'package'})) {	if (defined($token->[2]->{'package'})) {
Line 3504 sub metadata {	Line 3870 sub metadata {
if (defined($token->[2]->{'id'})) {	if (defined($token->[2]->{'id'})) {
$keyroot.='_'.$token->[2]->{'id'};	$keyroot.='_'.$token->[2]->{'id'};
}	}
if ($metacache{$uri.':packages'}) {	if ($metacache{$uri}->{':packages'}) {
$metacache{$uri.':packages'}.=','.$package.$keyroot;	$metacache{$uri}->{':packages'}.=','.$package.$keyroot;
} else {	} else {
$metacache{$uri.':packages'}=$package.$keyroot;	$metacache{$uri}->{':packages'}=$package.$keyroot;
}	}
foreach (keys %packagetab) {	foreach (keys %packagetab) {
if ($_=~/^$package\&/) {	my $part=$keyroot;
	$part=~s/^\_//;
	if ($_=~/^\Q$package\E\&/ \|\|
	$_=~/^\Q$package\E_0\&/) {
my ($pack,$name,$subp)=split(/\&/,$_);	my ($pack,$name,$subp)=split(/\&/,$_);
	# ignore package.tab specified default values
	# here &package_tab_default() will fetch those
	if ($subp eq 'default') { next; }
my $value=$packagetab{$_};	my $value=$packagetab{$_};
my $part=$keyroot;	my $unikey;
$part=~s/^\_//;	if ($pack =~ /_0$/) {
if ($subp eq 'display') {
$value.=' [Part: '.$part.']';
}
my $unikey='parameter'.$keyroot.'_'.$name;
if ($subp eq 'default') {
$unikey='parameter_0_'.$name;	$unikey='parameter_0_'.$name;
$metacache{$uri.':'.$unikey.'.part'}='0';	$part=0;
} else {	} else {
$metacache{$uri.':'.$unikey.'.part'}=$part;	$unikey='parameter'.$keyroot.'_'.$name;
$metathesekeys{$unikey}=1;
}	}
unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {	if ($subp eq 'display') {
$metacache{$uri.':'.$unikey.'.'.$subp}=$value;	$value.=' [Part: '.$part.']';
}	}
if (defined($metacache{$uri.':'.$unikey.'.default'})) {	$metacache{$uri}->{':'.$unikey.'.part'}=$part;
$metacache{$uri.':'.$unikey}=	$metathesekeys{$unikey}=1;
$metacache{$uri.':'.$unikey.'.default'};	unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) {
	$metacache{$uri}->{':'.$unikey.'.'.$subp}=$value;
	}
	if (defined($metacache{$uri}->{':'.$unikey.'.default'})) {
	$metacache{$uri}->{':'.$unikey}=
	$metacache{$uri}->{':'.$unikey.'.default'};
}	}
}	}
}	}
Line 3564 sub metadata {	Line 3935 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 3574 sub metadata {	Line 3946 sub metadata {
}	}
$metathesekeys{$unikey}=1;	$metathesekeys{$unikey}=1;
foreach (@{$token->[3]}) {	foreach (@{$token->[3]}) {
$metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};	$metacache{$uri}->{':'.$unikey.'.'.$_}=$token->[2]->{$_};
}	}
my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));	my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
my $default=$metacache{$uri.':'.$unikey.'.default'};	my $default=$metacache{$uri}->{':'.$unikey.'.default'};
if ( $internaltext =~ /^\s$/ && $default !~ /^\s$/) {	if ( $internaltext =~ /^\s$/ && $default !~ /^\s$/) {
# only ws inside the tag, and not in default, so use default	# only ws inside the tag, and not in default, so use default
# as value	# as value
$metacache{$uri.':'.$unikey}=$default;	$metacache{$uri}->{':'.$unikey}=$default;
} else {	} else {
# either something interesting inside the tag or default	# either something interesting inside the tag or default
# uninteresting	# uninteresting
$metacache{$uri.':'.$unikey}=$internaltext;	$metacache{$uri}->{':'.$unikey}=$internaltext;
}	}
# end of not-a-package not-a-library import	# end of not-a-package not-a-library import
}	}
Line 3595 sub metadata {	Line 3967 sub metadata {
}	}
}	}
# are there custom rights to evaluate	# are there custom rights to evaluate
if ($metacache{$uri.':copyright'} eq 'custom') {	if ($metacache{$uri}->{':copyright'} eq 'custom') {

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

sub metadata_generate_part0 {	sub metadata_generate_part0 {
Line 3626 sub metadata_generate_part0 {	Line 3999 sub metadata_generate_part0 {
my %allnames;	my %allnames;
foreach my $metakey (sort keys %$metadata) {	foreach my $metakey (sort keys %$metadata) {
if ($metakey=~/^parameter\_(.*)/) {	if ($metakey=~/^parameter\_(.*)/) {
my $part=$$metacache{$uri.':'.$metakey.'.part'};	my $part=$$metacache{':'.$metakey.'.part'};
my $name=$$metacache{$uri.':'.$metakey.'.name'};	my $name=$$metacache{':'.$metakey.'.name'};
if (! exists($$metadata{'parameter_0_'.$name.'.name'})) {	if (! exists($$metadata{'parameter_0_'.$name.'.name'})) {
$allnames{$name}=$part;	$allnames{$name}=$part;
}	}
Line 3635 sub metadata_generate_part0 {	Line 4008 sub metadata_generate_part0 {
}	}
foreach my $name (keys(%allnames)) {	foreach my $name (keys(%allnames)) {
$$metadata{"parameter_0_$name"}=1;	$$metadata{"parameter_0_$name"}=1;
my $key="$uri:parameter_0_$name";	my $key=":parameter_0_$name";
$$metacache{"$key.part"}='0';	$$metacache{"$key.part"}='0';
$$metacache{"$key.name"}=$name;	$$metacache{"$key.name"}=$name;
$$metacache{"$key.type"}=$$metacache{$uri.':parameter_'.	$$metacache{"$key.type"}=$$metacache{':parameter_'.
$allnames{$name}.'_'.$name.	$allnames{$name}.'_'.$name.
'.type'};	'.type'};
my $olddis=$$metacache{$uri.':parameter_'.$allnames{$name}.'_'.$name.	my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name.
'.display'};	'.display'};
my $expr='\\[Part: '.$allnames{$name}.'\\]';	my $expr='\\[Part: '.$allnames{$name}.'\\]';
$olddis=~s/$expr/\[Part: 0\]/;	$olddis=~s/$expr/\[Part: 0\]/;
Line 3658 sub gettitle {	Line 4031 sub gettitle {
unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; }	unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; }
return &metadata($urlsymb,'title');	return &metadata($urlsymb,'title');
}	}
if ($titlecache{$symb}) {	my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);
if (time < ($titlecache{$symb}[1] + 600)) {	if (defined($cached)) { return $result; }
return $titlecache{$symb}[0];	my ($map,$resid,$url)=&decode_symb($symb);
} else {
delete($titlecache{$symb});
}
}
my ($map,$resid,$url)=split(/\_\_\_/,$symb);
my $title='';	my $title='';
my %bighash;	my %bighash;
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',	if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
Line 3676 sub gettitle {	Line 4044 sub gettitle {
}	}
$title=~s/\&colon\;/\:/gs;	$title=~s/\&colon\;/\:/gs;
if ($title) {	if ($title) {
$titlecache{$symb}=[$title,time];	return &do_cache(\%titlecache,$symb,$title,'title');
return $title;
} else {	} else {
return &metadata($urlsymb,'title');	return &metadata($urlsymb,'title');
}	}
Line 3687 sub gettitle {	Line 4054 sub gettitle {

sub symblist {	sub symblist {
my ($mapname,%newhash)=@_;	my ($mapname,%newhash)=@_;
$mapname=declutter($mapname);	$mapname=&deversion(&declutter($mapname));
my %hash;	my %hash;
if (($ENV{'request.course.fn'}) && (%newhash)) {	if (($ENV{'request.course.fn'}) && (%newhash)) {
if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',	if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
&GDBM_WRCREAT(),0640)) {	&GDBM_WRCREAT(),0640)) {
foreach (keys %newhash) {	foreach (keys %newhash) {
$hash{declutter($_)}=$mapname.'___'.$newhash{$_};	$hash{declutter($_)}=$mapname.'___'.&deversion($newhash{$_});
}	}
if (untie(%hash)) {	if (untie(%hash)) {
return 'ok';	return 'ok';
Line 3711 sub symbverify {	Line 4078 sub symbverify {
# direct jump to resource in page or to a sequence - will construct own symbs	# direct jump to resource in page or to a sequence - will construct own symbs
if ($thisfn=~/\.(page\|sequence)$/) { return 1; }	if ($thisfn=~/\.(page\|sequence)$/) { return 1; }
# check URL part	# check URL part
my ($map,$resid,$url)=split(/\_\_\_/,$symb);	my ($map,$resid,$url)=&decode_symb($symb);
unless (&symbclean($url) eq &symbclean($thisfn)) { return 0; }
	unless ($url eq $thisfn) { return 0; }

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

my %bighash;	my %bighash;
my $okay=0;	my $okay=0;

if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',	if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
&GDBM_READER(),0640)) {	&GDBM_READER(),0640)) {
my $ids=$bighash{'ids_'.&clutter($thisfn)};	my $ids=$bighash{'ids_'.&clutter($thisfn)};
Line 3754 sub symbclean {	Line 4124 sub symbclean {
return $symb;	return $symb;
}	}

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

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

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

	sub fixversion {
	my $fn=shift;
	if ($fn=~/^(adm\|uploaded\|public)/) { return $fn; }
	my %bighash;
	my $uri=&clutter($fn);
	my $key=$ENV{'request.course.id'}.'_'.$uri;
	# is this cached?
	my ($result,$cached)=&is_cached(\%courseresversioncache,$key,
	'courseresversion',600);
	if (defined($cached)) { return $result; }
	# unfortunately not cached, or expired
	if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
	&GDBM_READER(),0640)) {
	if ($bighash{'version_'.$uri}) {
	my $version=$bighash{'version_'.$uri};
	unless (($version eq 'mostrecent') \|\|
	($version==&getversion($uri))) {
	$uri=~s/\.(\w+)$/\.$version\.$1/;
	}
	}
	untie %bighash;
	}
	return &do_cache
	(\%courseresversioncache,$key,&declutter($uri),'courseresversion');
	}

	sub deversion {
	my $url=shift;
	$url=~s/\.\d+\.(\w+)$/\.$1/;
	return $url;
	}

# ------------------------------------------------------ Return symb list entry	# ------------------------------------------------------ Return symb list entry

sub symbread {	sub symbread {
Line 3851 sub numval {	Line 4265 sub numval {
}	}

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

sub rndseed {	sub rndseed {
Line 3868 sub rndseed {	Line 4282 sub rndseed {
my $CODE=$ENV{'scantron.CODE'};	my $CODE=$ENV{'scantron.CODE'};
if (defined($CODE)) {	if (defined($CODE)) {
&rndseed_CODE_64bit($symb,$courseid,$domain,$username);	&rndseed_CODE_64bit($symb,$courseid,$domain,$username);
	} elsif ($which eq '64bit2') {
	return &rndseed_64bit2($symb,$courseid,$domain,$username);
} elsif ($which eq '64bit') {	} elsif ($which eq '64bit') {
return &rndseed_64bit($symb,$courseid,$domain,$username);	return &rndseed_64bit($symb,$courseid,$domain,$username);
}	}
Line 3911 sub rndseed_64bit {	Line 4327 sub rndseed_64bit {
}	}
}	}

	sub rndseed_64bit2 {
	my ($symb,$courseid,$domain,$username)=@_;
	{
	use integer;
	# strings need to be an even # of cahracters long, it it is odd the
	# last characters gets thrown away
	my $symbchck=unpack("%32S*",$symb.' ') << 21;
	my $symbseed=numval($symb) << 10;
	my $namechck=unpack("%32S*",$username.' ');

	my $nameseed=numval($username) << 21;
	my $domainseed=unpack("%32S*",$domain.' ') << 10;
	my $courseseed=unpack("%32S*",$courseid.' ');

	my $num1=$symbchck+$symbseed+$namechck;
	my $num2=$nameseed+$domainseed+$courseseed;
	#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed\|$courseseed;$namechck:$symbchck");
	#&Apache::lonxml::debug("rndseed :$num:$symb");
	return "$num1,$num2";
	}
	}

sub rndseed_CODE_64bit {	sub rndseed_CODE_64bit {
my ($symb,$courseid,$domain,$username)=@_;	my ($symb,$courseid,$domain,$username)=@_;
{	{
use integer;	use integer;
my $symbchck=unpack("%32S*",$symb) << 16;	my $symbchck=unpack("%32S*",$symb.' ') << 16;
my $symbseed=numval($symb);	my $symbseed=numval($symb);
my $CODEseed=numval($ENV{'scantron.CODE'}) << 16;	my $CODEseed=numval($ENV{'scantron.CODE'}) << 16;
my $courseseed=unpack("%32S*",$courseid);	my $courseseed=unpack("%32S*",$courseid.' ');
my $num1=$symbseed+$CODEseed;	my $num1=$symbseed+$CODEseed;
my $num2=$courseseed+$symbchck;	my $num2=$courseseed+$symbchck;
#&Apache::lonxml::debug("$symbseed:$CODEseed\|$courseseed:$symbchck");	#&Apache::lonxml::debug("$symbseed:$CODEseed\|$courseseed:$symbchck");
Line 3974 sub getfile {	Line 4412 sub getfile {
} else { # normal file from res space	} else { # normal file from res space
&repcopy($file);	&repcopy($file);
if (! -e $file ) { return -1; };	if (! -e $file ) { return -1; };
my $fh=Apache::File->new($file);	my $fh;
	open($fh,"<$file");
my $a='';	my $a='';
while (<$fh>) { $a .=$_; }	while (<$fh>) { $a .=$_; }
return $a;	return $a;
Line 4053 sub unescape {	Line 4492 sub unescape {
return $str;	return $str;
}	}

	sub mod_perl_version {
	if (defined($perlvar{'MODPERL2'})) {
	return 2;
	}
	return 1;
	}

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

sub goodbye {	sub goodbye {
&logthis("Starting Shut down");	&logthis("Starting Shut down");
	#not converted to using infrastruture and probably shouldn't be
	&logthis(sprintf("%-20s is %s",'%badServerCache',scalar(%badServerCache)));
	#converted
	&logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
	&logthis(sprintf("%-20s is %s",'%homecache',scalar(%homecache)));
	&logthis(sprintf("%-20s is %s",'%titlecache',scalar(%titlecache)));
	&logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache)));
	#1.1 only
	&logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache)));
	&logthis(sprintf("%-20s is %s",'%usectioncache',scalar(%usectioncache)));
	&logthis(sprintf("%-20s is %s",'%courseresversioncache',scalar(%courseresversioncache)));
	&logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache)));
&flushcourselogs();	&flushcourselogs();
&logthis("Shutting down");	&logthis("Shutting down");
return DONE;	return DONE;
Line 4066 BEGIN {	Line 4529 BEGIN {
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf	# ----------------------------------- Read loncapa.conf and loncapa_apache.conf
unless ($readit) {	unless ($readit) {
{	{
my $config=Apache::File->new("/etc/httpd/conf/loncapa.conf");	open(my $config,"</etc/httpd/conf/loncapa.conf");

while (my $configline=<$config>) {	while (my $configline=<$config>) {
if ($configline =~ /^[^\#]*PerlSetVar/) {	if ($configline =~ /^[^\#]*PerlSetVar/) {
Line 4075 BEGIN {	Line 4538 BEGIN {
$perlvar{$varname}=$varvalue;	$perlvar{$varname}=$varvalue;
}	}
}	}
	close($config);
}	}
{	{
my $config=Apache::File->new("/etc/httpd/conf/loncapa_apache.conf");	open(my $config,"</etc/httpd/conf/loncapa_apache.conf");

while (my $configline=<$config>) {	while (my $configline=<$config>) {
if ($configline =~ /^[^\#]*PerlSetVar/) {	if ($configline =~ /^[^\#]*PerlSetVar/) {
Line 4086 BEGIN {	Line 4550 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 /^\#/;	next if (/^(\#\|\s*$)/);
	# next if /^\#/;
chomp;	chomp;
my ($domain, $domain_description, $def_auth, $def_auth_arg)	my ($domain, $domain_description, $def_auth, $def_auth_arg,
= split(/:/,$_,4);	$def_lang, $city, $longi, $lati) = split(/:/,$_);
$domain_auth_def{$domain}=$def_auth;	$domain_auth_def{$domain}=$def_auth;
$domain_auth_arg_def{$domain}=$def_auth_arg;	$domain_auth_arg_def{$domain}=$def_auth_arg;
$domaindescription{$domain}=$domain_description;	$domaindescription{$domain}=$domain_description;
# &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");	$domain_lang_def{$domain}=$def_lang;
	$domain_city{$domain}=$city;
	$domain_longi{$domain}=$longi;
	$domain_lati{$domain}=$lati;

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


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

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

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

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

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

# -------------------------------------------- Read plain texts for permissions	# -------------------------------------------- Read plain texts for permissions
{	{
my $config=Apache::File->new("$perlvar{'lonTabDir'}/rolesplain.tab");	open(my $config,"<$perlvar{'lonTabDir'}/rolesplain.tab");

while (my $configline=<$config>) {	while (my $configline=<$config>) {
chomp($configline);	chomp($configline);
if ($configline) {	if ($configline) {
my ($short,$plain)=split(/:/,$configline);	my ($short,$plain)=split(/:/,$configline);
if ($plain ne '') { $prp{$short}=$plain; }	if ($plain ne '') { $prp{$short}=$plain; }
}	}
}	}
	close($config);
}	}

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

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

# ------------- set up temporary directory	# ------------- set up temporary directory
Line 4240 being set.	Line 4716 being set.

=back	=back

=head1 INTRODUCTION	=head1 OVERVIEW

This module provides subroutines which interact with the	lonnet provides subroutines which interact with the
lonc/lond (TCP) network layer of LON-CAPA. And Can be used to ask about	lonc/lond (TCP) network layer of LON-CAPA. They can be used to ask
- classes	about classes, users, and resources.
- users
- resources

For many of these objects you can also use this to store data about	For many of these objects you can also use this to store data about
them or modify them in various ways.	them or modify them in various ways.

This is part of the LearningOnline Network with CAPA project	=head2 Symbs
described at http://www.lon-capa.org.

=head1 RETURN MESSAGES	To identify a specific instance of a resource, LON-CAPA uses symbols
	or "symbs"X<symb>. These identifiers are built from the URL of the
	map, the resource number of the resource in the map, and the URL of
	the resource itself. The latter is somewhat redundant, but might help
	if maps change.

=over 4	An example is

=item *	msu/korte/parts/part1.sequence___19___msu/korte/tests/part12.problem

con_lost : unable to contact remote host	The respective map entry is

=item *	<resource id="19" src="/res/msu/korte/tests/part12.problem"
	title="Problem 2">
	</resource>

con_delayed : unable to contact remote host, message will be delivered	Symbs are used by the random number generator, as well as to store and
when the connection is brought back up	restore data specific to a certain instance of for example a problem.

=item *	=head2 Storing And Retrieving Data

con_failed : unable to contact remote host and unable to save message	X<store()>X<cstore()>X<restore()>Three of the most important functions
for later delivery	in C<lonnet.pm> are C<&Apache::lonnet::cstore()>,
	C<&Apache::lonnet:restore()>, and C<&Apache::lonnet::store()>, which
	is is the non-critical message twin of cstore. These functions are for
	handlers to store a perl hash to a user's permanent data space in an
	easy manner, and to retrieve it again on another call. It is expected
	that a handler would use this once at the beginning to retrieve data,
	and then again once at the end to send only the new data back.

=item *	The data is stored in the user's data directory on the user's
	homeserver under the ID of the course.

error: : an error a occured, a description of the error follows the :	The hash that is returned by restore will have all of the previous
	value for all of the elements of the hash.

=item *	Example:

	#creating a hash
	my %hash;
	$hash{'foo'}='bar';

	#storing it
	&Apache::lonnet::cstore(\%hash);

no_such_host : unable to fund a host associated with the user/domain	#changing a value
	$hash{'foo'}='notbar';

	#adding a new value
	$hash{'bar'}='foo';
	&Apache::lonnet::cstore(\%hash);

	#retrieving the hash
	my %history=&Apache::lonnet::restore();

	#print the hash
	foreach my $key (sort(keys(%history))) {
	print("\%history{$key} = $history{$key}");
	}

	Will print out:

	%history{1:foo} = bar
	%history{1:keys} = foo:timestamp
	%history{1:timestamp} = 990455579
	%history{2:bar} = foo
	%history{2:foo} = notbar
	%history{2:keys} = foo:bar:timestamp
	%history{2:timestamp} = 990455580
	%history{bar} = foo
	%history{foo} = notbar
	%history{timestamp} = 990455580
	%history{version} = 2

	Note that the special hash entries C<keys>, C<version> and
	C<timestamp> were added to the hash. C<version> will be equal to the
	total number of versions of the data that have been stored. The
	C<timestamp> attribute will be the UNIX time the hash was
	stored. C<keys> is available in every historical section to list which
	keys were added or changed at a specific historical revision of a
	hash.

	B<Warning>: do not store the hash that restore returns directly. This
	will cause a mess since it will restore the historical keys as if the
	were new keys. I.E. 1:foo will become 1:1:foo etc.

	Calling convention:

	my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname,$home);
	&Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$home);

	For more detailed information, see lonnet specific documentation.

	=head1 RETURN MESSAGES

	=over 4

	=item * B<con_lost>: unable to contact remote host

	=item * B<con_delayed>: unable to contact remote host, message will be delivered
	when the connection is brought back up

	=item * B<con_failed>: unable to contact remote host and unable to save message
	for later delivery

	=item * B<error:>: an error a occured, a description of the error follows the :

	=item * B<no_such_host>: unable to fund a host associated with the user/domain
that was requested	that was requested

=back	=back
Line 4289 that was requested	Line 4845 that was requested

=over 4	=over 4

=item *	=item *
	X<appenv()>
appenv(%hash) : the value of %hash is written to the user envirnoment	B<appenv(%hash)>: the value of %hash is written to
file, and will be restored for each access this user makes during this	the user envirnoment file, and will be restored for each access this
session, also modifies the %ENV for the current process	user makes during this session, also modifies the %ENV for the current
	process

=item *	=item *
	X<delenv()>
delenv($regexp) : removes all items from the session environment file that matches the regular expression in $regexp. The values are also delted from the current processes %ENV.	B<delenv($regexp)>: removes all items from the session
	environment file that matches the regular expression in $regexp. The
	values are also delted from the current processes %ENV.

=back	=back

Line 4306 delenv($regexp) : removes all items from	Line 4865 delenv($regexp) : removes all items from
=over 4	=over 4

=item *	=item *
	X<queryauthenticate()>
queryauthenticate($uname,$udom) : try to determine user's current	B<queryauthenticate($uname,$udom)>: try to determine user's current
authentication scheme	authentication scheme

=item *	=item *
	X<authenticate()>
authenticate($uname,$upass,$udom) : try to authenticate user from domain's lib	B<authenticate($uname,$upass,$udom)>: try to
servers (first use the current one), $upass should be the users password	authenticate user from domain's lib servers (first use the current
	one). C<$upass> should be the users password.

=item *	=item *
	X<homeserver()>
homeserver($uname,$udom) : find the server which has the user's	B<homeserver($uname,$udom)>: find the server which has
directory and files (there must be only one), this caches the answer,	the user's directory and files (there must be only one), this caches
and also caches if there is a borken connection.	the answer, and also caches if there is a borken connection.

=item *	=item *
	X<idget()>
idget($udom,@ids) : find the usernames behind a list of IDs (IDs are a	B<idget($udom,@ids)>: find the usernames behind a list of IDs
unique resource in a domain, there must be only 1 ID per username, and	(IDs are a unique resource in a domain, there must be only 1 ID per
only 1 username per ID in a specific domain) (returns hash:	username, and only 1 username per ID in a specific domain) (returns
id=>name,id=>name)	hash: id=>name,id=>name)

=item *	=item *
	X<idrget()>
idrget($udom,@unames) : find the IDs behind a list of usernames (returns hash:	B<idrget($udom,@unames)>: find the IDs behind a list of
name=>id,name=>id)	usernames (returns hash: name=>id,name=>id)

=item *	=item *
	X<idput()>
idput($udom,%ids) : store away a list of names and associated IDs	B<idput($udom,%ids)>: store away a list of names and associated IDs

=item *	=item *
	X<rolesinit()>
rolesinit($udom,$username,$authhost) : get user privileges	B<rolesinit($udom,$username,$authhost)>: get user privileges

=item *	=item *
	X<usection()>
usection($udom,$uname,$cname) : finds the section of student in the	B<usection($udom,$uname,$cname)>: finds the section of student in the
course $cname, return section name/number or '' for "not in course"	course $cname, return section name/number or '' for "not in course"
and '-1' for "no section"	and '-1' for "no section"

=item *	=item *
	X<userenvironment()>
userenvironment($udom,$uname,@what) : gets the values of the keys	B<userenvironment($udom,$uname,@what)>: gets the values of the keys
passed in @what from the requested user's environment, returns a hash	passed in @what from the requested user's environment, returns a hash

=back	=back
Line 4717 dumps the complete (or key matching rege	Line 5277 dumps the complete (or key matching rege

=item *	=item *

	inc($namespace,$store,$udom,$uname) : increments $store in $namespace.
	$store can be a scalar, an array reference, or if the amount to be
	incremented is > 1, a hash reference.

	($udom and $uname are optional)

	=item *

put($namespace,$storehash,$udom,$uname) : stores hash in namesp	put($namespace,$storehash,$udom,$uname) : stores hash in namesp
($udom and $uname are optional)	($udom and $uname are optional)

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

Removed from v.1.387
changed lines
	Added in v.1.454