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.382 and 1.444

version 1.382, 2003/06/19 19:37:45	version 1.444, 2003/11/10 21:50:21
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;
Line 73 use LWP::UserAgent();	Line 35 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;

# --------------------------------------------------------------------- Logging	# --------------------------------------------------------------------- Logging
Line 243 sub critical {	Line 209 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 256 sub transfer_profile_to_env {	Line 236 sub transfer_profile_to_env {
$idf->close();	$idf->close();
}	}
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}++;
	}
	}
	}
	foreach my $expired_key (keys(%Remove)) {
	&delenv($expired_key);
}	}
$ENV{'user.environment'} = "$lonidsdir/$handle.id";	$ENV{'user.environment'} = "$lonidsdir/$handle.id";
}	}
Line 377 sub userload {	Line 366 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 424 sub spareserver {	Line 413 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 557 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 567 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 819 sub getsection {
return '-1';	return '-1';
}	}

	sub devalidate_cache {
	my ($cache,$id,$name) = @_;
	delete $$cache{$id.'.time'};
	delete $$cache{$id};
	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)=@_;
	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)=@_;
	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 974 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 1019 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 1032 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 1067 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 1216 sub courseacclog {	Line 1355 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 1284 sub get_course_adv_roles {	Line 1423 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 (my $fh=Apache::File->new($perlvar{'lonDocRoot'}.'/announcement.txt')) {
	my $announcement='';
	while (<$fh>) { $announcement .=$_; }
	$fh->close();
	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 1611 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 1936 sub rolesinit {	Line 2122 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 2263 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 2297 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 2310 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;
	}

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

sub put {	sub put {
Line 2209 sub customaccess {	Line 2417 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 2428 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 2713 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 2729 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 2766 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 2775 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 2642 sub userlog_query {	Line 2878 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 2887 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 2732 sub modifyuser {	Line 2970 sub modifyuser {
my ($udom, $uname, $uid,	my ($udom, $uname, $uid,
$umode, $upass, $first,	$umode, $upass, $first,
$middle, $last, $gene,	$middle, $last, $gene,
$forceid, $desiredhome)=@_;	$forceid, $desiredhome, $email)=@_;
$udom=~s/\W//g;	$udom=~s/\W//g;
$uname=~s/\W//g;	$uname=~s/\W//g;
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.	&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
Line 2744 sub modifyuser {	Line 2982 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 2774 sub modifyuser {	Line 3013 sub modifyuser {
}	}
$uhome=&homeserver($uname,$udom,'true');	$uhome=&homeserver($uname,$udom,'true');
if (($uhome eq '') \|\| ($uhome eq 'no_host') \|\| ($uhome ne $unhome)) {	if (($uhome eq '') \|\| ($uhome eq 'no_host') \|\| ($uhome ne $unhome)) {
return 'error: verify home';	return 'error: unable verify users home machine.';
}	}
} # End of creation of new user	} # End of creation of new user
# ---------------------------------------------------------------------- Add ID	# ---------------------------------------------------------------------- Add ID
Line 2784 sub modifyuser {	Line 3023 sub modifyuser {
if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/)	if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/)
&& (!$forceid)) {	&& (!$forceid)) {
unless ($uid eq $uidhash{$uname}) {	unless ($uid eq $uidhash{$uname}) {
return 'error: mismatch '.$uidhash{$uname}.' versus '.$uid;	return 'error: user id "'.$uid.'" does not match '.
	'current user id "'.$uidhash{$uname}.'".';
}	}
} else {	} else {
&idput($udom,($uname => $uid));	&idput($udom,($uname => $uid));
Line 2800 sub modifyuser {	Line 3040 sub modifyuser {
} else {	} else {
%names = @tmp;	%names = @tmp;
}	}
	#
	# Make sure to not trash student environment if instructor does not bother
	# to supply name and email information
	#
if ($first) { $names{'firstname'} = $first; }	if ($first) { $names{'firstname'} = $first; }
if ($middle) { $names{'middlename'} = $middle; }	if (defined($middle)) { $names{'middlename'} = $middle; }
if ($last) { $names{'lastname'} = $last; }	if ($last) { $names{'lastname'} = $last; }
if ($gene) { $names{'generation'} = $gene; }	if (defined($gene)) { $names{'generation'} = $gene; }
	if ($email) { $names{'notification'} = $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; }
&logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.	&logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
Line 2817 sub modifyuser {	Line 3064 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)=@_;	$end,$start,$forceid,$desiredhome,$email)=@_;
my $cid='';	my $cid='';
unless ($cid=$ENV{'request.course.id'}) {	unless ($cid=$ENV{'request.course.id'}) {
return 'not_in_class';	return 'not_in_class';
Line 2825 sub modifystudent {	Line 3072 sub modifystudent {
# --------------------------------------------------------------- Make the user	# --------------------------------------------------------------- Make the user
my $reply=&modifyuser	my $reply=&modifyuser
($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,	($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,
$desiredhome);	$desiredhome,$email);
unless ($reply eq 'ok') { return $reply; }	unless ($reply eq 'ok') { return $reply; }
# 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
Line 3060 sub dirlist {	Line 3307 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 3076 sub dirlist {	Line 3323 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 3152 sub condval {	Line 3406 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 3161 sub courseresdata {	Line 3415 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 3190 sub courseresdata {	Line 3442 sub courseresdata {
#	#

sub clear_EXT_cache_status {	sub clear_EXT_cache_status {
&delenv('cache.');	&delenv('cache.EXT.');
}	}

sub EXT_cache_status {	sub EXT_cache_status {
my ($target_domain,$target_user) = @_;	my ($target_domain,$target_user) = @_;
my $cachename = 'cache.'.$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 3206 sub EXT_cache_status {	Line 3458 sub EXT_cache_status {

sub EXT_cache_set {	sub EXT_cache_set {
my ($target_domain,$target_user) = @_;	my ($target_domain,$target_user) = @_;
my $cachename = 'cache.'.$target_user.'.'.$target_domain;	my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
&appenv($cachename => time);	&appenv($cachename => time);
}	}

# --------------------------------------------------------- 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 3297 sub EXT {	Line 3552 sub EXT {
}	}
} elsif ($realm eq 'query') {	} elsif ($realm eq 'query') {
# ---------------------------------------------- pull stuff out of query string	# ---------------------------------------------- pull stuff out of query string
&Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},[$space]);	&Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},
	[$spacequalifierrest]);
return $ENV{'form.'.$spacequalifierrest};	return $ENV{'form.'.$spacequalifierrest};
} 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 3312 sub EXT {	Line 3576 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 3319 sub EXT {	Line 3584 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 3346 sub EXT {	Line 3610 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=&get('resourcedata',
	[$courselevelr,$courselevelm,
	$courselevel],$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 3399 sub EXT {	Line 3669 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 3415 sub EXT {	Line 3685 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 3438 sub EXT {	Line 3711 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 3458 sub add_prefix_and_part {	Line 3744 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 3472 sub metadata {	Line 3758 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?
#	#
	my %lcmetacache;
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 3498 sub metadata {	Line 3790 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 ($lcmetacache{':packages'}) {
$metacache{$uri.':packages'}.=','.$package.$keyroot;	$lcmetacache{':packages'}.=','.$package.$keyroot;
} else {	} else {
$metacache{$uri.':packages'}=$package.$keyroot;	$lcmetacache{':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;	}
	if ($subp eq 'display') {
	$value.=' [Part: '.$part.']';
}	}
unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {	$lcmetacache{':'.$unikey.'.part'}=$part;
$metacache{$uri.':'.$unikey.'.'.$subp}=$value;	$metathesekeys{$unikey}=1;
	unless (defined($lcmetacache{':'.$unikey.'.'.$subp})) {
	$lcmetacache{':'.$unikey.'.'.$subp}=$value;
}	}
if (defined($metacache{$uri.':'.$unikey.'.default'})) {	if (defined($lcmetacache{':'.$unikey.'.default'})) {
$metacache{$uri.':'.$unikey}=	$lcmetacache{':'.$unikey}=
$metacache{$uri.':'.$unikey.'.default'};	$lcmetacache{':'.$unikey.'.default'};
}	}
}	}
}	}
Line 3568 sub metadata {	Line 3865 sub metadata {
}	}
$metathesekeys{$unikey}=1;	$metathesekeys{$unikey}=1;
foreach (@{$token->[3]}) {	foreach (@{$token->[3]}) {
$metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};	$lcmetacache{':'.$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=$lcmetacache{':'.$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;	$lcmetacache{':'.$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;	$lcmetacache{':'.$unikey}=$internaltext;
}	}
# end of not-a-package not-a-library import	# end of not-a-package not-a-library import
}	}
Line 3589 sub metadata {	Line 3886 sub metadata {
}	}
}	}
# are there custom rights to evaluate	# are there custom rights to evaluate
if ($metacache{$uri.':copyright'} eq 'custom') {	if ($lcmetacache{':copyright'} eq 'custom') {

#	#
# Importing a rights file here	# Importing a rights file here
#	#
unless ($depthcount) {	unless ($depthcount) {
my $location=$metacache{$uri.':customdistributionfile'};	my $location=$lcmetacache{':customdistributionfile'};
my $dir=$filename;	my $dir=$filename;
$dir=~s\|[^/]*$\|\|;	$dir=~s\|[^/]*$\|\|;
$location=&filelocation($dir,$location);	$location=&filelocation($dir,$location);
Line 3606 sub metadata {	Line 3903 sub metadata {
}	}
}	}
}	}
$metacache{$uri.':keys'}=join(',',keys %metathesekeys);	$lcmetacache{':keys'}=join(',',keys %metathesekeys);
&metadata_generate_part0(\%metathesekeys,\%metacache,$uri);	&metadata_generate_part0(\%metathesekeys,\%lcmetacache,$uri);
$metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys);	$lcmetacache{':allpossiblekeys'}=join(',',keys %metathesekeys);
$metacache{$uri.':cachedtimestamp'}=time;	&do_cache(\%metacache,$uri,\%lcmetacache,'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 3620 sub metadata_generate_part0 {	Line 3917 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 3629 sub metadata_generate_part0 {	Line 3926 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 3652 sub gettitle {	Line 3949 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 3670 sub gettitle {	Line 3962 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 3681 sub gettitle {	Line 3972 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 3705 sub symbverify {	Line 3996 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 3748 sub symbclean {	Line 4042 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 3845 sub numval {	Line 4183 sub numval {
}	}

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

sub rndseed {	sub rndseed {
Line 3862 sub rndseed {	Line 4200 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 3905 sub rndseed_64bit {	Line 4245 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 4047 sub unescape {	Line 4409 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 4091 BEGIN {	Line 4477 BEGIN {
%domain_auth_arg_def = ();	%domain_auth_arg_def = ();
if ($fh) {	if ($fh) {
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;
	$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, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");
# &logthis("Domain.tab: $domain ".$domaindescription{$domain} );	# &logthis("Domain.tab: $domain ".$domaindescription{$domain} );
}	}
Line 4234 being set.	Line 4626 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);

	#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}");
	}

no_such_host : unable to fund a host associated with the user/domain	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 4283 that was requested	Line 4755 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 4300 delenv($regexp) : removes all items from	Line 4775 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

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

Removed from v.1.382
changed lines
	Added in v.1.444