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.367 and 1.417

version 1.367, 2003/05/02 15:26:36	version 1.417, 2003/09/19 16:53:35
Line 76 qw(%perlvar %hostname %homecache %badSer	Line 76 qw(%perlvar %hostname %homecache %badSer
%libserv %pr %prp %metacache %packagetab %titlecache	%libserv %pr %prp %metacache %packagetab %titlecache
%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);	%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;

my $readit;	my $readit;

Line 244 sub critical {	Line 247 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

	sub transfer_profile_to_env {
	my ($lonidsdir,$handle)=@_;
	my @profile;
	{
	my $idf=Apache::File->new("$lonidsdir/$handle.id");
	flock($idf,LOCK_SH);
	@profile=<$idf>;
	$idf->close();
	}
	my $envi;
	for ($envi=0;$envi<=$#profile;$envi++) {
	chomp($profile[$envi]);
	my ($envname,$envvalue)=split(/=/,$profile[$envi]);
	$ENV{$envname} = $envvalue;
	}
	$ENV{'user.environment'} = "$lonidsdir/$handle.id";
	}

# ---------------------------------------------------------- Append Environment	# ---------------------------------------------------------- Append Environment

sub appenv {	sub appenv {
Line 347 sub delenv {	Line 384 sub delenv {
return 'ok';	return 'ok';
}	}

	# ------------------------------------------ Find out current server userload
	# there is a copy in lond
	sub userload {
	my $numusers=0;
	{
	opendir(LONIDS,$perlvar{'lonIDsDir'});
	my $filename;
	my $curtime=time;
	while ($filename=readdir(LONIDS)) {
	if ($filename eq '.' \|\| $filename eq '..') {next;}
	my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
	if ($curtime-$mtime < 3600) { $numusers++; }
	}
	closedir(LONIDS);
	}
	my $userloadpercent=0;
	my $maxuserload=$perlvar{'lonUserLoadLim'};
	if ($maxuserload) {
	$userloadpercent=100*$numusers/$maxuserload;
	}
	$userloadpercent=sprintf("%.2f",$userloadpercent);
	return $userloadpercent;
	}

# ------------------------------------------ Fight off request when overloaded	# ------------------------------------------ Fight off request when overloaded

sub overloaderror {	sub overloaderror {
Line 373 sub overloaderror {	Line 434 sub overloaderror {
# ------------------------------ Find server with least workload from spare.tab	# ------------------------------ Find server with least workload from spare.tab

sub spareserver {	sub spareserver {
my $loadpercent = shift;	my ($loadpercent,$userloadpercent) = @_;
my $tryserver;	my $tryserver;
my $spareserver='';	my $spareserver='';
my $lowestserver=$loadpercent;	if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
	my $lowestserver=$loadpercent > $userloadpercent?
	$loadpercent : $userloadpercent;
foreach $tryserver (keys %spareid) {	foreach $tryserver (keys %spareid) {
my $answer=reply('load',$tryserver);	my $loadans=reply('load',$tryserver);
if (($answer =~ /\d/) && ($answer<$lowestserver)) {	my $userloadans=reply('userload',$tryserver);
$spareserver="http://$hostname{$tryserver}";	if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
$lowestserver=$answer;	next; #didn't get a number from the server
}	}
}	my $answer;
	if ($loadans =~ /\d/) {
	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 769 sub getsection {	Line 848 sub getsection {
return '-1';	return '-1';
}	}

	sub devalidate_cache {
	my ($cache,$id) = @_;
	delete $$cache{$id.'.time'};
	delete $$cache{$id};
	}

	sub is_cached {
	my ($cache,$id,$time) = @_;
	if (!exists($$cache{$id.'.time'})) {
	return (undef,undef);
	} else {
	if (time-$$cache{$id.'.time'}>$time) {
	&devalidate_cache($cache,$id);
	return (undef,undef);
	}
	}
	return ($$cache{$id},1);
	}

	sub do_cache {
	my ($cache,$id,$value) = @_;
	$$cache{$id.'.time'}=time;
	# do_cache implictly return the set value
	$$cache{$id}=$value;
	}

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

	my ($result,$cached)=&is_cached(\%usectioncache,$hashid,300);
	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 789 sub usection {	Line 898 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);
	}
}	}
}	}
return '-1';	return &do_cache(\%usectioncache,$hashid,'-1');
}	}

# ------------------------------------- Read an entry from a user's environment	# ------------------------------------- Read an entry from a user's environment
Line 932 sub repcopy {	Line 1043 sub repcopy {

# ------------------------------------------------ Get server side include body	# ------------------------------------------------ Get server side include body
sub ssi_body {	sub ssi_body {
my $filelink=shift;	my ($filelink,%form)=@_;
my $output=($filelink=~/^http\:/?&externalssi($filelink):	my $output=($filelink=~/^http\:/?&externalssi($filelink):
&ssi($filelink));	&ssi($filelink,%form));
$output=~s/^.\<body[^\>]\>//si;	$output=~s/^.\<body[^\>]\>//si;
$output=~s/\<\/body\s\>.$//si;	$output=~s/\<\/body\s\>.$//si;
$output=~	$output=~
Line 1166 sub courseacclog {	Line 1277 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 1230 sub get_course_adv_roles {	Line 1341 sub get_course_adv_roles {
} else {	} else {
$returnhash{$key}=$username.':'.$domain;	$returnhash{$key}=$username.':'.$domain;
}	}
	}
	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 '';
}	}
return sort %returnhash;
}	}

# ---------------------------------------------------------- Course ID routines	# ---------------------------------------------------------- Course ID routines
Line 1375 sub devalidate {	Line 1533 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 1593 sub tmpreset {	Line 1751 sub tmpreset {
my ($symb,$namespace,$domain,$stuname) = @_;	my ($symb,$namespace,$domain,$stuname) = @_;
if (!$symb) {	if (!$symb) {
$symb=&symbread();	$symb=&symbread();
if (!$symb) { $symb= $ENV{'REQUEST_URI'}; }	if (!$symb) { $symb= $ENV{'request.url'}; }
}	}
$symb=escape($symb);	$symb=escape($symb);

Line 1886 sub rolesinit {	Line 2044 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 2027 sub dump {	Line 2185 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 2159 sub customaccess {	Line 2332 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 2171 sub allowed {	Line 2347 sub allowed {
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 2462 sub is_on_map {	Line 2639 sub is_on_map {
if ($match) {	if ($match) {
return (1,$1);	return (1,$1);
} else {	} else {
return (0,0);	my ($name,$ext)=($filename=~/^(.+)\.(\w+)$/);
	$ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
	/\&(\Q$name\E\.\d+\.$ext)\:([\d\\|]+)\&/;
	return (0,$2,$pathname.'/'.$1);
}	}
}	}

Line 2471 sub is_on_map {	Line 2651 sub is_on_map {
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 2480 sub definerole {	Line 2660 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 2489 sub definerole {	Line 2669 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 2592 sub userlog_query {	Line 2772 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 2601 sub assignrole {	Line 2781 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 2611 sub assignrole {	Line 2793 sub assignrole {
} else {	} else {
my $cwosec=$url;	my $cwosec=$url;
$cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;	$cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
unless (&allowed('c'.$role,$cwosec)) {	unless ((&allowed('c'.$role,$cwosec)) \|\| &allowed('c'.$role,$udom)) {
&logthis('Refused assignrole: '.	&logthis('Refused 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 2631 sub assignrole {	Line 2813 sub assignrole {
}	}
# actually delete	# actually delete
if ($deleteflag) {	if ($deleteflag) {
if (&allowed('dro',$udom)) {	if ((&allowed('dro',$udom)) \|\| (&allowed('dro',$url))) {
# modify command to delete the role	# modify command to delete the role
$command="encrypt:rolesdel:$ENV{'user.domain'}:$ENV{'user.name'}:".	$command="encrypt:rolesdel:$ENV{'user.domain'}:$ENV{'user.name'}:".
"$udom:$uname:$url".'_'."$mrole";	"$udom:$uname:$url".'_'."$mrole";
	&logthis("$ENV{'user.name'} at $ENV{'user.domain'} deletes $mrole in $url for $uname at $udom");
# set start and finish to negative values for userrolelog	# set start and finish to negative values for userrolelog
$start=-1;	$start=-1;
$end=-1;	$end=-1;
Line 2681 sub modifyuser {	Line 2864 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 2693 sub modifyuser {	Line 2876 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 2723 sub modifyuser {	Line 2907 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 2733 sub modifyuser {	Line 2917 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 2749 sub modifyuser {	Line 2934 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 2766 sub modifyuser {	Line 2958 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 2774 sub modifystudent {	Line 2966 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 3009 sub dirlist {	Line 3201 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 3025 sub dirlist {	Line 3217 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 3033 sub GetFileTimestamp {	Line 3232 sub GetFileTimestamp {
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;	$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
my $proname="$studentDomain/$subdir/$studentName";	my $proname="$studentDomain/$subdir/$studentName";
$proname .= '/'.$filename;	$proname .= '/'.$filename;
my @dir = &Apache::lonnet::dirlist($proname, $studentDomain, $studentName,	my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain,
$root);	$studentName, $root);
my $fileStat = $dir[0];
my @stats = split('&', $fileStat);	my @stats = split('&', $fileStat);
if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {	if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
return $stats[9];	# @stats contains first the filename, then the stat output
	return $stats[10]; # so this is 10 instead of 9.
} else {	} else {
return -1;	return -1;
}	}
Line 3110 sub courseresdata {	Line 3309 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,300);
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);
$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);
}	}
}	}
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;
}	}

# --------------------------------------------------------- Value of a Variable	#
	# EXT resource caching routines
	#

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

	sub EXT_cache_status {
	my ($target_domain,$target_user) = @_;
	my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
	if (exists($ENV{$cachename}) && ($ENV{$cachename}+600) > time) {
	# We know already the user has no data
	return 1;
	} else {
	return 0;
	}
	}

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

	# --------------------------------------------------------- Value of a Variable
sub EXT {	sub EXT {
my ($varname,$symbparm,$udom,$uname,)=@_;	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
Line 3145 sub EXT {	Line 3366 sub EXT {
my $publicuser;	my $publicuser;
if (!($uname && $udom)) {	if (!($uname && $udom)) {
(my $cursymb,$courseid,$udom,$uname,$publicuser)=	(my $cursymb,$courseid,$udom,$uname,$publicuser)=
&Apache::lonxml::whichuser();	&Apache::lonxml::whichuser($symbparm);
if (!$symbparm) { $symbparm=$cursymb; }	if (!$symbparm) { $symbparm=$cursymb; }
} else {	} else {
$courseid=$ENV{'request.course.id'};	$courseid=$ENV{'request.course.id'};
Line 3222 sub EXT {	Line 3443 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'},
return $ENV{'form.'.$space};	[$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') {
Line 3237 sub EXT {	Line 3459 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 3244 sub EXT {	Line 3467 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'};
} else {	} else {
$section=&usection($udom,$uname,$courseid);	if (! defined($usection)) {
	$section=&usection($udom,$uname,$courseid);
	} else {
	$section = $usection;
	}
}	}

my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;	my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
Line 3266 sub EXT {	Line 3492 sub EXT {
my $courselevelm=$courseid.'.'.$mapparm;	my $courselevelm=$courseid.'.'.$mapparm;

# ----------------------------------------------------------- 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	#every thirty minutes
if (!	if (! &EXT_cache_status($udom,$uname)) {
(exists($ENV{'cache.studentresdata'})
&& (($ENV{'cache.studentresdata'}+1800) > time))) {
my %resourcedata=&get('resourcedata',	my %resourcedata=&get('resourcedata',
[$courselevelr,$courselevelm,$courselevel],	[$courselevelr,$courselevelm,$courselevel],
$udom,$uname);	$udom,$uname);
Line 3289 sub EXT {	Line 3513 sub EXT {
$uname." at ".$udom.": ".	$uname." at ".$udom.": ".
$tmp."</font>");	$tmp."</font>");
} elsif ($tmp=~/error:No such file/) {	} elsif ($tmp=~/error:No such file/) {
$ENV{'cache.studentresdata'}=time;	&EXT_cache_set($udom,$uname);
&appenv(('cache.studentresdata'=>
$ENV{'cache.studentresdata'}));
} elsif ($tmp =~ /^(con_lost\|no_such_host)/) {	} elsif ($tmp =~ /^(con_lost\|no_such_host)/) {
return $tmp;	return $tmp;
}	}
Line 3324 sub EXT {	Line 3546 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 3340 sub EXT {	Line 3562 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 3363 sub EXT {	Line 3588 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 3404 sub metadata {	Line 3642 sub metadata {
if ($liburi) {	if ($liburi) {
$liburi=&declutter($liburi);	$liburi=&declutter($liburi);
$filename=$liburi;	$filename=$liburi;
}	} else {
	delete($metacache{$uri.':packages'});
	}
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 3431 sub metadata {	Line 3670 sub metadata {
foreach (keys %packagetab) {	foreach (keys %packagetab) {
if ($_=~/^$package\&/) {	if ($_=~/^$package\&/) {
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 $part=$keyroot;
$part=~s/^\_//;	$part=~s/^\_//;
Line 3438 sub metadata {	Line 3680 sub metadata {
$value.=' [Part: '.$part.']';	$value.=' [Part: '.$part.']';
}	}
my $unikey='parameter'.$keyroot.'_'.$name;	my $unikey='parameter'.$keyroot.'_'.$name;
if ($subp eq 'default') {	$metacache{$uri.':'.$unikey.'.part'}=$part;
$unikey='parameter_0_'.$name;	$metathesekeys{$unikey}=1;
$metacache{$uri.':'.$unikey.'.part'}='0';
} else {
$metacache{$uri.':'.$unikey.'.part'}=$part;
$metathesekeys{$unikey}=1;
}
unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {	unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {
$metacache{$uri.':'.$unikey.'.'.$subp}=$value;	$metacache{$uri.':'.$unikey.'.'.$subp}=$value;
}	}
Line 3577 sub gettitle {	Line 3814 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}) { return $titlecache{$symb}; }	if ($titlecache{$symb}) {
my ($map,$resid,$url)=split(/\_\_\_/,$symb);	if (time < ($titlecache{$symb}[1] + 600)) {
	return $titlecache{$symb}[0];
	} else {
	delete($titlecache{$symb});
	}
	}
	my ($map,$resid,$url)=&decode_symb($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 3589 sub gettitle {	Line 3832 sub gettitle {
}	}
$title=~s/\&colon\;/\:/gs;	$title=~s/\&colon\;/\:/gs;
if ($title) {	if ($title) {
$titlecache{$symb}=$title;	$titlecache{$symb}=[$title,time];
return $title;	return $title;
} else {	} else {
return &metadata($urlsymb,'title');	return &metadata($urlsymb,'title');
Line 3624 sub symbverify {	Line 3867 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 (&symbclean($url) eq &symbclean($thisfn)) { return 0; }

$symb=&symbclean($symb);	$symb=&symbclean($symb);
Line 3667 sub symbclean {	Line 3910 sub symbclean {
return $symb;	return $symb;
}	}

	# ---------------------------------------------- Split symb to find map and 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 ($match,$cond,$versioned)=&is_on_map($fn);
	unless ($match) {
	$fn=$versioned;
	}
	return $fn;
	}

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

sub symbread {	sub symbread {
Line 3763 sub numval {	Line 4023 sub numval {
return int($txt);	return int($txt);
}	}

	sub latest_rnd_algorithm_id {
	return '64bit';
	}

sub rndseed {	sub rndseed {
my ($symb,$courseid,$domain,$username)=@_;	my ($symb,$courseid,$domain,$username)=@_;

Line 3962 sub unescape {	Line 4226 sub unescape {
return $str;	return $str;
}	}

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

sub goodbye {	sub goodbye {
Line 4006 BEGIN {	Line 4276 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 4149 being set.	Line 4425 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}");
	}

	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

no_such_host : unable to fund a host associated with the user/domain	=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 4198 that was requested	Line 4554 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 4215 delenv($regexp) : removes all items from	Line 4574 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.367
changed lines
	Added in v.1.417