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.522 and 1.597

version 1.522, 2004/07/16 17:56:01	version 1.597, 2005/02/09 22:39:49
Line 35 use HTTP::Headers;	Line 35 use HTTP::Headers;
use HTTP::Date;	use HTTP::Date;
# use Date::Parse;	# use Date::Parse;
use vars	use vars
qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom	qw(%perlvar %hostname %homecache %badServerCache %iphost %spareid %hostdom
%libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache	%libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache
%courselogs %accesshash %userrolehash $processmarker $dumpcount	%courselogs %accesshash %userrolehash $processmarker $dumpcount
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache	%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %courseresdatacache
%userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def	%userresdatacache %getsectioncache %domaindescription %domain_auth_def %domain_auth_arg_def
%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir);	%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit);

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::lonlocal;	use Apache::lonlocal;
use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw);	use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);
use Time::HiRes();	use Time::HiRes qw( gettimeofday tv_interval );
my $readit;	my $readit;
	my $max_connection_retries = 10; # Or some such value.

=pod	=pod

Line 116 sub logperm {	Line 116 sub logperm {
sub subreply {	sub subreply {
my ($cmd,$server)=@_;	my ($cmd,$server)=@_;
my $peerfile="$perlvar{'lonSockDir'}/$server";	my $peerfile="$perlvar{'lonSockDir'}/$server";
my $client=IO::Socket::UNIX->new(Peer =>"$peerfile",	#
Type => SOCK_STREAM,	# With loncnew process trimming, there's a timing hole between lonc server
Timeout => 10)	# process exit and the master server picking up the listen on the AF_UNIX
or return "con_lost";	# socket. In that time interval, a lock file will exist:
print $client "$cmd\n";
my $answer=<$client>;	my $lockfile=$peerfile.".lock";
if (!$answer) { $answer="con_lost"; }	while (-e $lockfile) { # Need to wait for the lockfile to disappear.
chomp($answer);	sleep(1);
	}
	# At this point, either a loncnew parent is listening or an old lonc
	# or loncnew child is listening so we can connect or everything's dead.
	#
	# We'll give the connection a few tries before abandoning it. If
	# connection is not possible, we'll con_lost back to the client.
	#
	my $client;
	for (my $retries = 0; $retries < $max_connection_retries; $retries++) {
	$client=IO::Socket::UNIX->new(Peer =>"$peerfile",
	Type => SOCK_STREAM,
	Timeout => 10);
	if($client) {
	last; # Connected!
	}
	sleep(1); # Try again later if failed connection.
	}
	my $answer;
	if ($client) {
	print $client "$cmd\n";
	$answer=<$client>;
	if (!$answer) { $answer="con_lost"; }
	chomp($answer);
	} else {
	$answer = 'con_lost'; # Failed connection.
	}
return $answer;	return $answer;
}	}

Line 131 sub reply {	Line 157 sub reply {
my ($cmd,$server)=@_;	my ($cmd,$server)=@_;
unless (defined($hostname{$server})) { return 'no_such_host'; }	unless (defined($hostname{$server})) { return 'no_such_host'; }
my $answer=subreply($cmd,$server);	my $answer=subreply($cmd,$server);
if ($answer eq 'con_lost') {
#sleep 5;
#$answer=subreply($cmd,$server);
#if ($answer eq 'con_lost') {
# &logthis("Second attempt con_lost on $server");
# my $peerfile="$perlvar{'lonSockDir'}/$server";
# my $client=IO::Socket::UNIX->new(Peer =>"$peerfile",
# Type => SOCK_STREAM,
# Timeout => 10)
# or return "con_lost";
# &logthis("Killing socket");
# print $client "close_connection_exit\n";
#sleep 5;
# $answer=subreply($cmd,$server);
#}
}
if (($answer=~/^refused/) \|\| ($answer=~/^rejected/)) {	if (($answer=~/^refused/) \|\| ($answer=~/^rejected/)) {
&logthis("<font color=blue>WARNING:".	&logthis("<font color=blue>WARNING:".
" $cmd to $server returned $answer</font>");	" $cmd to $server returned $answer</font>");
Line 194 sub critical {	Line 204 sub critical {
}	}
my $answer=reply($cmd,$server);	my $answer=reply($cmd,$server);
if ($answer eq 'con_lost') {	if ($answer eq 'con_lost') {
my $pingreply=reply('ping',$server);
&reconlonc("$perlvar{'lonSockDir'}/$server");	&reconlonc("$perlvar{'lonSockDir'}/$server");
my $pongreply=reply('pong',$server);	my $answer=reply($cmd,$server);
&logthis("Ping/Pong for $server: $pingreply/$pongreply");
$answer=reply($cmd,$server);
if ($answer eq 'con_lost') {	if ($answer eq 'con_lost') {
my $now=time;	my $now=time;
my $middlename=$cmd;	my $middlename=$cmd;
Line 434 sub overloaderror {	Line 441 sub overloaderror {
if ($overload>0) {	if ($overload>0) {
$r->err_headers_out->{'Retry-After'}=$overload;	$r->err_headers_out->{'Retry-After'}=$overload;
$r->log_error('Overload of '.$overload.' on '.$checkserver);	$r->log_error('Overload of '.$overload.' on '.$checkserver);
return 409;	return 413;
}	}
return '';	return '';
}	}
Line 771 sub getsection {	Line 778 sub getsection {
my ($udom,$unam,$courseid)=@_;	my ($udom,$unam,$courseid)=@_;
$courseid=~s/\_/\//g;	$courseid=~s/\_/\//g;
$courseid=~s/^(\w)/\/$1/;	$courseid=~s/^(\w)/\/$1/;

	my $hashid="$udom:$unam:$courseid";
	my ($result,$cached)=&is_cached(\%getsectioncache,$hashid,'getsection');
	if (defined($cached)) { return $result; }

my %Pending;	my %Pending;
my %Expired;	my %Expired;
#	#
Line 795 sub getsection {	Line 807 sub getsection {
if ($key eq $courseid.'_st') { $section=''; }	if ($key eq $courseid.'_st') { $section=''; }
my ($dummy,$end,$start)=split(/\_/,&unescape($value));	my ($dummy,$end,$start)=split(/\_/,&unescape($value));
my $now=time;	my $now=time;
if (defined($end) && ($now > $end)) {	if (defined($end) && $end && ($now > $end)) {
$Expired{$end}=$section;	$Expired{$end}=$section;
next;	next;
}	}
if (defined($start) && ($now < $start)) {	if (defined($start) && $start && ($now < $start)) {
$Pending{$start}=$section;	$Pending{$start}=$section;
next;	next;
}	}
return $section;	return &do_cache(\%getsectioncache,$hashid,$section,'getsection');
}	}
#	#
# Presumedly there will be few matching roles from the above	# Presumedly there will be few matching roles from the above
# loop and the sorting time will be negligible.	# loop and the sorting time will be negligible.
if (scalar(keys(%Pending))) {	if (scalar(keys(%Pending))) {
my ($time) = sort {$a <=> $b} keys(%Pending);	my ($time) = sort {$a <=> $b} keys(%Pending);
return $Pending{$time};	return &do_cache(\%getsectioncache,$hashid,$Pending{$time},'getsection');
}	}
if (scalar(keys(%Expired))) {	if (scalar(keys(%Expired))) {
my @sorted = sort {$a <=> $b} keys(%Expired);	my @sorted = sort {$a <=> $b} keys(%Expired);
my $time = pop(@sorted);	my $time = pop(@sorted);
return $Expired{$time};	return &do_cache(\%getsectioncache,$hashid,$Expired{$time},'getsection');
}	}
return '-1';	return &do_cache(\%getsectioncache,$hashid,'-1','getsection');
}	}


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

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

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

sub load_cache_item {	sub load_cache_item {
my ($cache,$name,$id)=@_;	my ($cache,$name,$id,$time)=@_;
if ($disk_caching_disabled) { return; }	if ($disk_caching_disabled) { return; }
my $starttime=&Time::HiRes::time();	my $starttime=&Time::HiRes::time();
# &logthis("Before Loading $name for $id size is ".scalar(%$cache));	# &logthis("Before Loading $name for $id size is ".scalar(%$cache));
my %hash;	my %hash;
my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";	my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
open(DB,"$filename.lock");	if (!-e $filename) { return; }
	open(DB,">$filename.lock");
flock(DB,LOCK_SH);	flock(DB,LOCK_SH);
if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) {	if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) {
eval <<'EVALBLOCK';	eval <<'EVALBLOCK';
Line 935 sub load_cache_item {	Line 990 sub load_cache_item {
}	}
# &logthis("Initial load: $count");	# &logthis("Initial load: $count");
} else {	} else {
my $hashref=thaw($hash{$id});	if (($$cache{$id.'.time'}+$time) < time) {
$$cache{$id}=$hashref->{'item'};	$$cache{$id.'.time'}=$hash{$id.'.time'};
$$cache{$id.'.time'}=$hash{$id.'.time'};	{
	my $hashref=thaw($hash{$id});
	$$cache{$id}=$hashref->{'item'};
	}
	if (exists($hash{$id.'.file'})) {
	my $hashref=thaw($hash{$id.'.file'});
	$$cache{$id.'.file'}=$hashref->{'item'};
	}
	}
}	}
EVALBLOCK	EVALBLOCK
if ($@) {	if ($@) {
Line 957 EVALBLOCK	Line 1020 EVALBLOCK
# &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime));	# &logthis("load_cache_item $name took ".(&Time::HiRes::time()-$starttime));
}	}

sub usection {
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/^(\w)/\/$1/;
foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
&homeserver($unam,$udom)))) {
my ($key,$value)=split(/\=/,$_);
$key=&unescape($key);
if ($key=~/^\Q$courseid\E(?:\/)(\w+)\_st$/) {
my $section=$1;
if ($key eq $courseid.'_st') { $section=''; }
my ($dummy,$end,$start)=split(/\_/,&unescape($value));
my $now=time;
my $notactive=0;
if ($start) {
if ($now<$start) { $notactive=1; }
}
if ($end) {
if ($now>$end) { $notactive=1; }
}
unless ($notactive) {
return &do_cache(\%usectioncache,$hashid,$section,'usection');
}
}
}
return &do_cache(\%usectioncache,$hashid,'-1','usection');
}

# ------------------------------------- Read an entry from a user's environment	# ------------------------------------- Read an entry from a user's environment

sub userenvironment {	sub userenvironment {
Line 1047 sub currentversion {	Line 1078 sub currentversion {
sub subscribe {	sub subscribe {
my $fname=shift;	my $fname=shift;
if ($fname=~/\/(aboutme\|syllabus\|bulletinboard\|smppg)$/) { return ''; }	if ($fname=~/\/(aboutme\|syllabus\|bulletinboard\|smppg)$/) { return ''; }
	$fname=~s/[\n\r]//g;
my $author=$fname;	my $author=$fname;
$author=~s/\/home\/httpd\/html\/res\/([^\/])\/([^\/]).*/$1\/$2/;	$author=~s/\/home\/httpd\/html\/res\/([^\/])\/([^\/]).*/$1\/$2/;
my ($udom,$uname)=split(/\//,$author);	my ($udom,$uname)=split(/\//,$author);
Line 1066 sub subscribe {	Line 1098 sub subscribe {
sub repcopy {	sub repcopy {
my $filename=shift;	my $filename=shift;
$filename=~s/\/+/\//g;	$filename=~s/\/+/\//g;
if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; }	if ($filename=~m\|^/home/httpd/html/adm/\|) { return OK; }
	if ($filename=~m\|^/home/httpd/html/lonUsers/\|) { return OK; }
	if ($filename=~m\|^/home/httpd/html/userfiles/\| or
	$filename=~m\|^/*uploaded/\|) {
	return &repcopy_userfile($filename);
	}
	$filename=~s/[\n\r]//g;
my $transname="$filename.in.transfer";	my $transname="$filename.in.transfer";
if ((-e $filename) \|\| (-e $transname)) { return OK; }	if ((-e $filename) \|\| (-e $transname)) { return OK; }
my $remoteurl=subscribe($filename);	my $remoteurl=subscribe($filename);
Line 1131 sub ssi_body {	Line 1169 sub ssi_body {
my ($filelink,%form)=@_;	my ($filelink,%form)=@_;
my $output=($filelink=~/^http\:/?&externalssi($filelink):	my $output=($filelink=~/^http\:/?&externalssi($filelink):
&ssi($filelink,%form));	&ssi($filelink,%form));
	$output=~s\|//(\s<!--)? BEGIN LON-CAPA Internal.+// END LON-CAPA Internal\s(-->)?\s\|\|gs;
$output=~s/^.?\<body[^\>]\>//si;	$output=~s/^.?\<body[^\>]\>//si;
$output=~s/(.)\<\/body\s\>.*?$/$1/si;	$output=~s/(.)\<\/body\s\>.*?$/$1/si;
$output=~
s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs;
return $output;	return $output;
}	}

Line 1267 sub process_coursefile {	Line 1304 sub process_coursefile {
# input: name of form element, coursedoc=1 means this is for the course	# input: name of form element, coursedoc=1 means this is for the course
# output: url of file in userspace	# output: url of file in userspace

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

	sub userfileupload {
	my ($formname,$coursedoc,$subdir)=@_;
	if (!defined($subdir)) { $subdir='unknown'; }
	my $fname=$ENV{'form.'.$formname.'.filename'};
	$fname=&clean_filename($fname);
# See if there is anything left	# See if there is anything left
unless ($fname) { return 'error: no uploaded file'; }	unless ($fname) { return 'error: no uploaded file'; }
chop($ENV{'form.'.$formname});	chop($ENV{'form.'.$formname});
	if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { #files uploaded to help request form are handled differently
	my $now = time;
	my $filepath = 'tmp/helprequests/'.$now;
	my @parts=split(/\//,$filepath);
	my $fullpath = $perlvar{'lonDaemons'};
	for (my $i=0;$i<@parts;$i++) {
	$fullpath .= '/'.$parts[$i];
	if ((-e $fullpath)!=1) {
	mkdir($fullpath,0777);
	}
	}
	open(my $fh,'>'.$fullpath.'/'.$fname);
	print $fh $ENV{'form.'.$formname};
	close($fh);
	return $fullpath.'/'.$fname;
	}
# Create the directory if not present	# Create the directory if not present
my $docuname='';	my $docuname='';
my $docudom='';	my $docudom='';
Line 1325 sub finishuserfileupload {	Line 1387 sub finishuserfileupload {
}	}
# Save the file	# Save the file
{	{
#&Apache::lonnet::logthis("Saving to $filepath $file");	open(FH,'>'.$filepath.'/'.$file);
open(my $fh,'>'.$filepath.'/'.$file);	print FH $ENV{'form.'.$formname};
print $fh $ENV{'form.'.$formname};	close(FH);
close($fh);
}	}
# Notify homeserver to grep it	# Notify homeserver to grep it
#	#
	&Apache::lonnet::logthis("fetching ".$path.$file);
my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);	my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
if ($fetchresult eq 'ok') {	if ($fetchresult eq 'ok') {
#	#
Line 1356 sub removeuserfile {	Line 1418 sub removeuserfile {
return &reply("removeuserfile:$docudom/$docuname/$fname",$home);	return &reply("removeuserfile:$docudom/$docuname/$fname",$home);
}	}

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

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

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

sub log {	sub log {
Line 1396 sub flushcourselogs {	Line 1471 sub flushcourselogs {
if ($courseidbuffer{$coursehombuf{$crsid}}) {	if ($courseidbuffer{$coursehombuf{$crsid}}) {
$courseidbuffer{$coursehombuf{$crsid}}.='&'.	$courseidbuffer{$coursehombuf{$crsid}}.='&'.
&escape($crsid).'='.&escape($coursedescrbuf{$crsid}).	&escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
'='.&escape($courseinstcodebuf{$crsid});	':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid});
} else {	} else {
$courseidbuffer{$coursehombuf{$crsid}}=	$courseidbuffer{$coursehombuf{$crsid}}=
&escape($crsid).'='.&escape($coursedescrbuf{$crsid}).	&escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
'='.&escape($courseinstcodebuf{$crsid});	':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid});
}	}
}	}
#	#
# Write course id database (reverse lookup) to homeserver of courses	# Write course id database (reverse lookup) to homeserver of courses
Line 1476 sub courselog {	Line 1551 sub courselog {
$ENV{'course.'.$ENV{'request.course.id'}.'.description'};	$ENV{'course.'.$ENV{'request.course.id'}.'.description'};
$courseinstcodebuf{$ENV{'request.course.id'}}=	$courseinstcodebuf{$ENV{'request.course.id'}}=
$ENV{'course.'.$ENV{'request.course.id'}.'.internal.coursecode'};	$ENV{'course.'.$ENV{'request.course.id'}.'.internal.coursecode'};
	$courseownerbuf{$ENV{'request.course.id'}}=
	$ENV{'course.'.$ENV{'request.course.id'}.'.internal.courseowner'};
if (defined $courselogs{$ENV{'request.course.id'}}) {	if (defined $courselogs{$ENV{'request.course.id'}}) {
$courselogs{$ENV{'request.course.id'}}.='&'.$what;	$courselogs{$ENV{'request.course.id'}}.='&'.$what;
} else {	} else {
Line 1492 sub courseacclog {	Line 1569 sub courseacclog {
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\|page)$/) {	if ($fnsymb=~/(problem\|exam\|quiz\|assess\|survey\|form\|page)$/) {
$what.=':POST';	$what.=':POST';
	# FIXME: Probably ought to escape things....
foreach (keys %ENV) {	foreach (keys %ENV) {
if ($_=~/^form\.(.*)/) {	if ($_=~/^form\.(.*)/) {
$what.=':'.$1.'='.$ENV{$_};	$what.=':'.$1.'='.$ENV{$_};
}	}
}	}
	} elsif ($fnsymb =~ m:^/adm/searchcat:) {
	# FIXME: We should not be depending on a form parameter that someone
	# editing lonsearchcat.pm might change in the future.
	if ($ENV{'form.phase'} eq 'course_search') {
	$what.= ':POST';
	# FIXME: Probably ought to escape things....
	foreach my $element ('courseexp','crsfulltext','crsrelated',
	'crsdiscuss') {
	$what.=':'.$element.'='.$ENV{'form.'.$element};
	}
	}
}	}
&courselog($what);	&courselog($what);
}	}
Line 1548 sub get_course_adv_roles {	Line 1637 sub get_course_adv_roles {
if (($tend) && ($tend<$now)) { next; }	if (($tend) && ($tend<$now)) { next; }
if (($tstart) && ($now<$tstart)) { next; }	if (($tstart) && ($now<$tstart)) { next; }
my ($role,$username,$domain,$section)=split(/\:/,$_);	my ($role,$username,$domain,$section)=split(/\:/,$_);
	if ($username eq '' \|\| $domain eq '') { next; }
if ((&privileged($username,$domain)) &&	if ((&privileged($username,$domain)) &&
(!$nothide{$username.':'.$domain})) { next; }	(!$nothide{$username.':'.$domain})) { next; }
my $key=&plaintext($role);	my $key=&plaintext($role);
Line 1619 sub courseidput {	Line 1709 sub courseidput {
}	}

sub courseiddump {	sub courseiddump {
my ($domfilter,$descfilter,$sincefilter,$hostidflag,$hostidref)=@_;	my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$hostidflag,$hostidref)=@_;
my %returnhash=();	my %returnhash=();
unless ($domfilter) { $domfilter=''; }	unless ($domfilter) { $domfilter=''; }
foreach my $tryserver (keys %libserv) {	foreach my $tryserver (keys %libserv) {
Line 1627 sub courseiddump {	Line 1717 sub courseiddump {
if ((!$domfilter) \|\| ($hostdom{$tryserver} eq $domfilter)) {	if ((!$domfilter) \|\| ($hostdom{$tryserver} eq $domfilter)) {
foreach (	foreach (
split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.	split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.
$sincefilter.':'.&escape($descfilter),	$sincefilter.':'.&escape($descfilter).':'.
	&escape($instcodefilter).':'.&escape($ownerfilter),
$tryserver))) {	$tryserver))) {
my ($key,$value)=split(/\=/,$_);	my ($key,$value)=split(/\=/,$_);
if (($key) && ($value)) {	if (($key) && ($value)) {
Line 1648 sub get_first_access {	Line 1739 sub get_first_access {
my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();	my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
if ($argsymb) { $symb=$argsymb; }	if ($argsymb) { $symb=$argsymb; }
my ($map,$id,$res)=&decode_symb($symb);	my ($map,$id,$res)=&decode_symb($symb);
if ($type eq 'map') { $res=$map; }	if ($type eq 'map') {
my %times=&get('firstaccesstimes',[$res],$udom,$uname);	$res=&symbread($map);
return $times{$res};	} else {
	$res=$symb;
	}
	my %times=&get('firstaccesstimes',["$courseid\0$res"],$udom,$uname);
	return $times{"$courseid\0$res"};
}	}

sub set_first_access {	sub set_first_access {
my ($type)=@_;	my ($type)=@_;
my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();	my ($symb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
my ($map,$id,$res)=&decode_symb($symb);	my ($map,$id,$res)=&decode_symb($symb);
if ($type eq 'map') { $res=$map; }	if ($type eq 'map') {
my $firstaccess=&get_first_access($type);	$res=&symbread($map);
	} else {
	$res=$symb;
	}
	my $firstaccess=&get_first_access($type,$symb);
if (!$firstaccess) {	if (!$firstaccess) {
return &put('firstaccesstimes',{$res=>time},$udom,$uname);	return &put('firstaccesstimes',{"$courseid\0$res"=>time},$udom,$uname);
}	}
return 'already_set';	return 'already_set';
}	}
Line 1718 sub checkin {	Line 1817 sub checkin {
my $now=time;	my $now=time;
my ($ta,$tb,$lonhost)=split(/\*/,$token);	my ($ta,$tb,$lonhost)=split(/\*/,$token);
$lonhost=~tr/A-Z/a-z/;	$lonhost=~tr/A-Z/a-z/;
my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb;	my $dtoken=$ta.'_'.$hostname{$lonhost}.'_'.$tb;
$dtoken=~s/\W/\_/g;	$dtoken=~s/\W/\_/g;
my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=	my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));	split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
Line 1777 sub devalidate {	Line 1876 sub devalidate {
# - 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
	# - current conditional state info
my $key=$uname.':'.$udom.':';	my $key=$uname.':'.$udom.':';
my $status=	my $status=
&del('nohist_calculatedsheets',	&del('nohist_calculatedsheets',
Line 1791 sub devalidate {	Line 1891 sub devalidate {
$uname.' at '.$udom.' for '.	$uname.' at '.$udom.' for '.
$symb.': '.$status);	$symb.': '.$status);
}	}
	&delenv('user.state.'.$cid);
}	}
}	}

Line 1999 sub tmpreset {	Line 2100 sub tmpreset {
$namespace=~s/\//\_/g;	$namespace=~s/\//\_/g;
$namespace=~s/\W//g;	$namespace=~s/\W//g;

#FIXME needs to do something for /pub resources
if (!$domain) { $domain=$ENV{'user.domain'}; }	if (!$domain) { $domain=$ENV{'user.domain'}; }
if (!$stuname) { $stuname=$ENV{'user.name'}; }	if (!$stuname) { $stuname=$ENV{'user.name'}; }
	if ($domain eq 'public' && $stuname eq 'public') {
	$stuname=$ENV{'REMOTE_ADDR'};
	}
my $path=$perlvar{'lonDaemons'}.'/tmp';	my $path=$perlvar{'lonDaemons'}.'/tmp';
my %hash;	my %hash;
if (tie(%hash,'GDBM_File',	if (tie(%hash,'GDBM_File',
Line 2034 sub tmpstore {	Line 2137 sub tmpstore {
}	}
$namespace=~s/\//\_/g;	$namespace=~s/\//\_/g;
$namespace=~s/\W//g;	$namespace=~s/\W//g;
#FIXME needs to do something for /pub resources
if (!$domain) { $domain=$ENV{'user.domain'}; }	if (!$domain) { $domain=$ENV{'user.domain'}; }
if (!$stuname) { $stuname=$ENV{'user.name'}; }	if (!$stuname) { $stuname=$ENV{'user.name'}; }
	if ($domain eq 'public' && $stuname eq 'public') {
	$stuname=$ENV{'REMOTE_ADDR'};
	}
my $now=time;	my $now=time;
my %hash;	my %hash;
my $path=$perlvar{'lonDaemons'}.'/tmp';	my $path=$perlvar{'lonDaemons'}.'/tmp';
Line 2048 sub tmpstore {	Line 2153 sub tmpstore {
my $allkeys='';	my $allkeys='';
foreach my $key (keys(%$storehash)) {	foreach my $key (keys(%$storehash)) {
$allkeys.=$key.':';	$allkeys.=$key.':';
$hash{"$version:$symb:$key"}=$$storehash{$key};	$hash{"$version:$symb:$key"}=&freeze_escape($$storehash{$key});
}	}
$hash{"$version:$symb:timestamp"}=$now;	$hash{"$version:$symb:timestamp"}=$now;
$allkeys.='timestamp';	$allkeys.='timestamp';
Line 2075 sub tmprestore {	Line 2180 sub tmprestore {
$symb=escape($symb);	$symb=escape($symb);

if (!$namespace) { $namespace=$ENV{'request.state'}; }	if (!$namespace) { $namespace=$ENV{'request.state'}; }
#FIXME needs to do something for /pub resources
if (!$domain) { $domain=$ENV{'user.domain'}; }	if (!$domain) { $domain=$ENV{'user.domain'}; }
if (!$stuname) { $stuname=$ENV{'user.name'}; }	if (!$stuname) { $stuname=$ENV{'user.name'}; }
	if ($domain eq 'public' && $stuname eq 'public') {
	$stuname=$ENV{'REMOTE_ADDR'};
	}
my %returnhash;	my %returnhash;
$namespace=~s/\//\_/g;	$namespace=~s/\//\_/g;
$namespace=~s/\W//g;	$namespace=~s/\W//g;
Line 2096 sub tmprestore {	Line 2203 sub tmprestore {
my $key;	my $key;
$returnhash{"$scope:keys"}=$vkeys;	$returnhash{"$scope:keys"}=$vkeys;
foreach $key (@keys) {	foreach $key (@keys) {
$returnhash{"$scope:$key"}=$hash{"$scope:$symb:$key"};	$returnhash{"$scope:$key"}=&thaw_unescape($hash{"$scope:$symb:$key"});
$returnhash{"$key"}=$hash{"$scope:$symb:$key"};	$returnhash{"$key"}=&thaw_unescape($hash{"$scope:$symb:$key"});
}	}
}	}
if (!(untie(%hash))) {	if (!(untie(%hash))) {
Line 2138 sub store {	Line 2245 sub store {

my $namevalue='';	my $namevalue='';
foreach (keys %$storehash) {	foreach (keys %$storehash) {
$namevalue.=escape($_).'='.escape($$storehash{$_}).'&';	$namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';
}	}
$namevalue=~s/\&$//;	$namevalue=~s/\&$//;
&courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);	&courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);
Line 2174 sub cstore {	Line 2281 sub cstore {

my $namevalue='';	my $namevalue='';
foreach (keys %$storehash) {	foreach (keys %$storehash) {
$namevalue.=escape($_).'='.escape($$storehash{$_}).'&';	$namevalue.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';
}	}
$namevalue=~s/\&$//;	$namevalue=~s/\&$//;
&courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);	&courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);
Line 2208 sub restore {	Line 2315 sub restore {
my %returnhash=();	my %returnhash=();
foreach (split(/\&/,$answer)) {	foreach (split(/\&/,$answer)) {
my ($name,$value)=split(/\=/,$_);	my ($name,$value)=split(/\=/,$_);
$returnhash{&unescape($name)}=&unescape($value);	$returnhash{&unescape($name)}=&thaw_unescape($value);
}	}
my $version;	my $version;
for ($version=1;$version<=$returnhash{'version'};$version++) {	for ($version=1;$version<=$returnhash{'version'};$version++) {
Line 2264 sub privileged {	Line 2371 sub privileged {
my $now=time;	my $now=time;
if ($rolesdump ne '') {	if ($rolesdump ne '') {
foreach (split(/&/,$rolesdump)) {	foreach (split(/&/,$rolesdump)) {
if ($_!~/^rolesdef\&/) {	if ($_!~/^rolesdef_/) {
my ($area,$role)=split(/=/,$_);	my ($area,$role)=split(/=/,$_);
$area=~s/\_\w\w$//;	$area=~s/\_\w\w$//;
my ($trole,$tend,$tstart)=split(/_/,$role);	my ($trole,$tend,$tstart)=split(/_/,$role);
Line 2291 sub rolesinit {	Line 2398 sub rolesinit {
my $rolesdump=reply("dump:$domain:$username:roles",$authhost);	my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
if (($rolesdump eq 'con_lost') \|\| ($rolesdump eq '')) { return ''; }	if (($rolesdump eq 'con_lost') \|\| ($rolesdump eq '')) { return ''; }
my %allroles=();	my %allroles=();
my %thesepriv=();
my $now=time;	my $now=time;
my $userroles="user.login.time=$now\n";	my $userroles="user.login.time=$now\n";
my $thesestr;

if ($rolesdump ne '') {	if ($rolesdump ne '') {
foreach (split(/&/,$rolesdump)) {	foreach (split(/&/,$rolesdump)) {
if ($_!~/^rolesdef\&/) {	if ($_!~/^rolesdef_/) {
my ($area,$role)=split(/=/,$_);	my ($area,$role)=split(/=/,$_);
$area=~s/\_\w\w$//;	$area=~s/\_\w\w$//;
my ($trole,$tend,$tstart)=split(/_/,$role);
$userroles.='user.role.'.$trole.'.'.$area.'='.	my ($trole,$tend,$tstart);
$tstart.'.'.$tend."\n";	if ($role=~/^cr/) {
# log the associated role with the area	($trole,my $trest)=($role=~m\|^(cr/\w+/\w+/[a-zA-Z0-9]+)_(.*)$\|);
&userrolelog($trole,$username,$domain,$area,$tstart,$tend);	($tend,$tstart)=split('_',$trest);
if ($tend!=0) {	} else {
if ($tend<$now) {	($trole,$tend,$tstart)=split(/_/,$role);
$trole='';	}
}	$userroles.=&set_arearole($trole,$area,$tstart,$tend,$domain,$username);
}	if (($tend!=0) && ($tend<$now)) { $trole=''; }
if ($tstart!=0) {	if (($tstart!=0) && ($tstart>$now)) { $trole=''; }
if ($tstart>$now) {
$trole='';
}
}
if (($area ne '') && ($trole ne '')) {	if (($area ne '') && ($trole ne '')) {
my $spec=$trole.'.'.$area;	my $spec=$trole.'.'.$area;
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);	&custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
my $homsvr=homeserver($rauthor,$rdomain);
if ($hostname{$homsvr} ne '') {
my ($rdummy,$roledef)=
&get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);

if (($rdummy ne 'con_lost') && ($roledef ne '')) {
my ($syspriv,$dompriv,$coursepriv)=
split(/\_/,$roledef);
if (defined($syspriv)) {
$allroles{'cm./'}.=':'.$syspriv;
$allroles{$spec.'./'}.=':'.$syspriv;
}
if ($tdomain ne '') {
if (defined($dompriv)) {
$allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;
$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
}
if ($trest ne '') {
if (defined($coursepriv)) {
$allroles{'cm.'.$area}.=':'.$coursepriv;
$allroles{$spec.'.'.$area}.=':'.$coursepriv;
}
}
}
}
}
} else {	} else {
if (defined($pr{$trole.':s'})) {	&standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
$allroles{'cm./'}.=':'.$pr{$trole.':s'};
$allroles{$spec.'./'}.=':'.$pr{$trole.':s'};
}
if ($tdomain ne '') {
if (defined($pr{$trole.':d'})) {
$allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
$allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
}
if ($trest ne '') {
if (defined($pr{$trole.':c'})) {
$allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};
$allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};
}
}
}
}	}
}	}
}	}
}	}
my $adv=0;	my ($author,$adv) = &set_userprivs(\$userroles,\%allroles);
my $author=0;
foreach (keys %allroles) {
%thesepriv=();
if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; }
if (($_=~/^au/) \|\| ($_=~/^ca/)) { $author=1; }
foreach (split(/:/,$allroles{$_})) {
if ($_ ne '') {
my ($privilege,$restrictions)=split(/&/,$_);
if ($restrictions eq '') {
$thesepriv{$privilege}='F';
} else {
if ($thesepriv{$privilege} ne 'F') {
$thesepriv{$privilege}.=$restrictions;
}
}
}
}
$thesestr='';
foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; }
$userroles.='user.priv.'.$_.'='.$thesestr."\n";
}
$userroles.='user.adv='.$adv."\n".	$userroles.='user.adv='.$adv."\n".
'user.author='.$author."\n";	'user.author='.$author."\n";
$ENV{'user.adv'}=$adv;	$ENV{'user.adv'}=$adv;
Line 2397 sub rolesinit {	Line 2436 sub rolesinit {
return $userroles;	return $userroles;
}	}

	sub set_arearole {
	my ($trole,$area,$tstart,$tend,$domain,$username) = @_;
	# log the associated role with the area
	&userrolelog($trole,$username,$domain,$area,$tstart,$tend);
	return 'user.role.'.$trole.'.'.$area.'='.$tstart.'.'.$tend."\n";
	}

	sub custom_roleprivs {
	my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;
	my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
	my $homsvr=homeserver($rauthor,$rdomain);
	if ($hostname{$homsvr} ne '') {
	my ($rdummy,$roledef)=
	&get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);
	if (($rdummy ne 'con_lost') && ($roledef ne '')) {
	my ($syspriv,$dompriv,$coursepriv)=split(/\_/,$roledef);
	if (defined($syspriv)) {
	$$allroles{'cm./'}.=':'.$syspriv;
	$$allroles{$spec.'./'}.=':'.$syspriv;
	}
	if ($tdomain ne '') {
	if (defined($dompriv)) {
	$$allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;
	$$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
	}
	if (($trest ne '') && (defined($coursepriv))) {
	$$allroles{'cm.'.$area}.=':'.$coursepriv;
	$$allroles{$spec.'.'.$area}.=':'.$coursepriv;
	}
	}
	}
	}
	}


	sub standard_roleprivs {
	my ($allroles,$trole,$tdomain,$spec,$trest,$area) = @_;
	if (defined($pr{$trole.':s'})) {
	$$allroles{'cm./'}.=':'.$pr{$trole.':s'};
	$$allroles{$spec.'./'}.=':'.$pr{$trole.':s'};
	}
	if ($tdomain ne '') {
	if (defined($pr{$trole.':d'})) {
	$$allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
	$$allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
	}
	if (($trest ne '') && (defined($pr{$trole.':c'}))) {
	$$allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};
	$$allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};
	}
	}
	}

	sub set_userprivs {
	my ($userroles,$allroles) = @_;
	my $author=0;
	my $adv=0;
	foreach (keys %{$allroles}) {
	my %thesepriv=();
	if (($_=~/^au/) \|\| ($_=~/^ca/)) { $author=1; }
	foreach (split(/:/,$$allroles{$_})) {
	if ($_ ne '') {
	my ($privilege,$restrictions)=split(/&/,$_);
	if ($restrictions eq '') {
	$thesepriv{$privilege}='F';
	} elsif ($thesepriv{$privilege} ne 'F') {
	$thesepriv{$privilege}.=$restrictions;
	}
	if ($thesepriv{'adv'} eq 'F') { $adv=1; }
	}
	}
	my $thesestr='';
	foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; }
	$$userroles.='user.priv.'.$_.'='.$thesestr."\n";
	}
	return ($author,$adv);
	}

# --------------------------------------------------------------- get interface	# --------------------------------------------------------------- get interface

sub get {	sub get {
Line 2418 sub get {	Line 2535 sub get {
my %returnhash=();	my %returnhash=();
my $i=0;	my $i=0;
foreach (@$storearr) {	foreach (@$storearr) {
$returnhash{$_}=unescape($pairs[$i]);	$returnhash{$_}=&thaw_unescape($pairs[$i]);
$i++;	$i++;
}	}
return %returnhash;	return %returnhash;
Line 2457 sub dump {	Line 2574 sub dump {
my %returnhash=();	my %returnhash=();
foreach (@pairs) {	foreach (@pairs) {
my ($key,$value)=split(/=/,$_);	my ($key,$value)=split(/=/,$_);
$returnhash{unescape($key)}=unescape($value);	$returnhash{unescape($key)}=&thaw_unescape($value);
}	}
return %returnhash;	return %returnhash;
}	}
Line 2503 sub currentdump {	Line 2620 sub currentdump {
my ($key,$value)=split(/=/,$_);	my ($key,$value)=split(/=/,$_);
my ($symb,$param) = split(/:/,$key);	my ($symb,$param) = split(/:/,$key);
$returnhash{&unescape($symb)}->{&unescape($param)} =	$returnhash{&unescape($symb)}->{&unescape($param)} =
&unescape($value);	&thaw_unescape($value);
}	}
}	}
return %returnhash;	return %returnhash;
Line 2569 sub put {	Line 2686 sub put {
my $uhome=&homeserver($uname,$udomain);	my $uhome=&homeserver($uname,$udomain);
my $items='';	my $items='';
foreach (keys %$storehash) {	foreach (keys %$storehash) {
$items.=&escape($_).'='.&escape($$storehash{$_}).'&';	$items.=&escape($_).'='.&freeze_escape($$storehash{$_}).'&';
	}
	$items=~s/\&$//;
	return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
	}

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

	sub putstore {
	my ($namespace,$storehash,$udomain,$uname)=@_;
	if (!$udomain) { $udomain=$ENV{'user.domain'}; }
	if (!$uname) { $uname=$ENV{'user.name'}; }
	my $uhome=&homeserver($uname,$udomain);
	my $items='';
	my %allitems = ();
	foreach (keys %$storehash) {
	if ($_ =~ m/^([^\:]+):([^\:]+):([^\:]+)$/) {
	my $key = $1.':keys:'.$2;
	$allitems{$key} .= $3.':';
	}
	$items.=$_.'='.&freeze_escape($$storehash{$_}).'&';
	}
	foreach (keys %allitems) {
	$allitems{$_} =~ s/\:$//;
	$items.= $_.'='.$allitems{$_}.'&';
}	}
$items=~s/\&$//;	$items=~s/\&$//;
return &reply("put:$udomain:$uname:$namespace:$items",$uhome);	return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
Line 2584 sub cput {	Line 2725 sub cput {
my $uhome=&homeserver($uname,$udomain);	my $uhome=&homeserver($uname,$udomain);
my $items='';	my $items='';
foreach (keys %$storehash) {	foreach (keys %$storehash) {
$items.=escape($_).'='.escape($$storehash{$_}).'&';	$items.=escape($_).'='.&freeze_escape($$storehash{$_}).'&';
}	}
$items=~s/\&$//;	$items=~s/\&$//;
return &critical("put:$udomain:$uname:$namespace:$items",$uhome);	return &critical("put:$udomain:$uname:$namespace:$items",$uhome);
Line 2607 sub eget {	Line 2748 sub eget {
my %returnhash=();	my %returnhash=();
my $i=0;	my $i=0;
foreach (@$storearr) {	foreach (@$storearr) {
$returnhash{$_}=unescape($pairs[$i]);	$returnhash{$_}=&thaw_unescape($pairs[$i]);
$i++;	$i++;
}	}
return %returnhash;	return %returnhash;
Line 2650 sub customaccess {	Line 2791 sub customaccess {
# ------------------------------------------------- Check for a user privilege	# ------------------------------------------------- Check for a user privilege

sub allowed {	sub allowed {
my ($priv,$uri)=@_;	my ($priv,$uri,$symb)=@_;
$uri=&deversion($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}; }	if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; }
# Free bre access to adm and meta resources	# Free bre access to adm and meta resources
	if (((($uri=~/^adm\//) && ($uri !~ m\|/bulletinboard$\|))
if ((($uri=~/^adm\//) \|\| ($uri=~/\.meta$/)) && ($priv eq 'bre')) {	\|\| ($uri=~/\.meta$/)) && ($priv eq 'bre')) {
return 'F';	return 'F';
}	}

	# Free bre access to user's own portfolio contents
	my ($space,$domain,$name,$dir)=split('/',$uri);
	if (('uploaded' eq $space) && ($ENV{'user.name'} eq $name) &&
	($ENV{'user.domain'} eq $domain) && ('portfolio' eq $dir)) {
	return 'F';
	}

# Free bre to public access	# Free bre to public access

if ($priv eq 'bre') {	if ($priv eq 'bre') {
Line 2922 sub allowed {	Line 3072 sub allowed {

if ($thisallowed=~/X/) {	if ($thisallowed=~/X/) {
if ($ENV{'acc.randomout'}) {	if ($ENV{'acc.randomout'}) {
my $symb=&symbread($uri,1);	if (!$symb) { $symb=&symbread($uri,1); }
if (($symb) && ($ENV{'acc.randomout'}=~/\&\Q$symb\E\&/)) {	if (($symb) && ($ENV{'acc.randomout'}=~/\&\Q$symb\E\&/)) {
return '';	return '';
}	}
Line 3063 sub log_query {	Line 3213 sub log_query {
sub fetch_enrollment_query {	sub fetch_enrollment_query {
my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;	my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;
my $homeserver;	my $homeserver;
	my $maxtries = 1;
if ($context eq 'automated') {	if ($context eq 'automated') {
$homeserver = $perlvar{'lonHostID'};	$homeserver = $perlvar{'lonHostID'};
	$maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout
} else {	} else {
$homeserver = &homeserver($cnum,$dom);	$homeserver = &homeserver($cnum,$dom);
}	}
Line 3077 sub fetch_enrollment_query {	Line 3229 sub fetch_enrollment_query {
$cmd = &escape($cmd);	$cmd = &escape($cmd);
my $query = 'fetchenrollment';	my $query = 'fetchenrollment';
my $queryid=&reply("querysend:".$query.':'.$dom.':'.$ENV{'user.name'}.':'.$cmd,$homeserver);	my $queryid=&reply("querysend:".$query.':'.$dom.':'.$ENV{'user.name'}.':'.$cmd,$homeserver);
unless ($queryid=~/^\Q$host\E\_/) { return 'error: '.$queryid; }	unless ($queryid=~/^\Q$host\E\_/) {
	&logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum);
	return 'error: '.$queryid;
	}
my $reply = &get_query_reply($queryid);	my $reply = &get_query_reply($queryid);
unless ( ($reply =~/^timeout/) \|\| ($reply =~/^error/) ) {	my $tries = 1;
	while (($reply=~/^timeout/) && ($tries < $maxtries)) {
	$reply = &get_query_reply($queryid);
	$tries ++;
	}
	if ( ($reply =~/^timeout/) \|\| ($reply =~/^error/) ) {
	&logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$ENV{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
	} else {
my @responses = split/:/,$reply;	my @responses = split/:/,$reply;
if ($homeserver eq $perlvar{'lonHostID'}) {	if ($homeserver eq $perlvar{'lonHostID'}) {
foreach (@responses) {	foreach (@responses) {
Line 3096 sub fetch_enrollment_query {	Line 3258 sub fetch_enrollment_query {
my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml';	my $filename = $dom.'_'.$key.'_'.$_.'_classlist.xml';
my $destname = $pathname.'/'.$filename;	my $destname = $pathname.'/'.$filename;
my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver);	my $xml_classlist = &reply("autoretrieve:".$filename,$homeserver);
unless ($xml_classlist =~ /^error/) {	if ($xml_classlist =~ /^error/) {
	&logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum);
	} else {
if ( open(FILE,">$destname") ) {	if ( open(FILE,">$destname") ) {
print FILE &unescape($xml_classlist);	print FILE &unescape($xml_classlist);
close(FILE);	close(FILE);
	} else {
	&logthis('fetch_enrollment_query - error opening classlist file '.$destname.' '.$context.' '.$cnum);
}	}
}	}
}	}
Line 3208 sub auto_instcode_format {	Line 3374 sub auto_instcode_format {
my $courses = '';	my $courses = '';
my $homeserver;	my $homeserver;
if ($caller eq 'global') {	if ($caller eq 'global') {
$homeserver = $perlvar{'lonHostID'};	foreach my $tryserver (keys %libserv) {
	if ($hostdom{$tryserver} eq $codedom) {
	$homeserver = $tryserver;
	last;
	}
	}
	if (($ENV{'user.name'}) && ($ENV{'user.domain'} eq $codedom)) {
	$homeserver = &homeserver($ENV{'user.name'},$codedom);
	}
} else {	} else {
$homeserver = &homeserver($caller,$codedom);	$homeserver = &homeserver($caller,$codedom);
}	}
my $host=$hostname{$homeserver};
foreach (keys %{$instcodes}) {	foreach (keys %{$instcodes}) {
$courses .= &escape($_).'='.&escape($$instcodes{$_}).'&';	$courses .= &escape($_).'='.&escape($$instcodes{$_}).'&';
}	}
Line 3403 sub modifyuser {	Line 3576 sub modifyuser {
if (defined($middle)) { $names{'middlename'} = $middle; }	if (defined($middle)) { $names{'middlename'} = $middle; }
if ($last) { $names{'lastname'} = $last; }	if ($last) { $names{'lastname'} = $last; }
if (defined($gene)) { $names{'generation'} = $gene; }	if (defined($gene)) { $names{'generation'} = $gene; }
if ($email) { $names{'notification'} = $email;	if ($email) {
$names{'critnotification'} = $email; }	$email=~s/[^\w\@\.\-\,]//gs;
	if ($email=~/\@/) { $names{'notification'} = $email;
	$names{'critnotification'} = $email;
	$names{'permanentemail'} = $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 3481 sub modify_student_enrollment {	Line 3657 sub modify_student_enrollment {
$gene = $tmp{'generation'} if (!defined($gene) \|\| $gene eq '');	$gene = $tmp{'generation'} if (!defined($gene) \|\| $gene eq '');
$uid = $tmp{'id'} if (!defined($uid) \|\| $uid eq '');	$uid = $tmp{'id'} if (!defined($uid) \|\| $uid eq '');
}	}
my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene,	my $fullname = &format_name($first,$middle,$last,$gene,'lastname');
$first,$middle);
my $reply=cput('classlist',	my $reply=cput('classlist',
{"$uname:$udom" =>	{"$uname:$udom" =>
join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },	join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },
Line 3499 sub modify_student_enrollment {	Line 3674 sub modify_student_enrollment {
return &assignrole($udom,$uname,$uurl,'st',$end,$start);	return &assignrole($udom,$uname,$uurl,'st',$end,$start);
}	}

	sub format_name {
	my ($firstname,$middlename,$lastname,$generation,$first)=@_;
	my $name;
	if ($first ne 'lastname') {
	$name=$firstname.' '.$middlename.' '.$lastname.' '.$generation;
	} else {
	if ($lastname=~/\S/) {
	$name.= $lastname.' '.$generation.', '.$firstname.' '.$middlename;
	$name=~s/\s+,/,/;
	} else {
	$name.= $firstname.' '.$middlename.' '.$generation;
	}
	}
	$name=~s/^\s+//;
	$name=~s/\s+$//;
	$name=~s/\s+/ /g;
	return $name;
	}

# ------------------------------------------------- Write to course preferences	# ------------------------------------------------- Write to course preferences

sub writecoursepref {	sub writecoursepref {
Line 3521 sub writecoursepref {	Line 3715 sub writecoursepref {
# ---------------------------------------------------------- Make/modify course	# ---------------------------------------------------------- Make/modify course

sub createcourse {	sub createcourse {
my ($udom,$description,$url,$course_server,$nonstandard,$inst_code)=@_;	my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner)=@_;
$url=&declutter($url);	$url=&declutter($url);
my $cid='';	my $cid='';
unless (&allowed('ccc',$udom)) {	unless (&allowed('ccc',$udom)) {
Line 3556 sub createcourse {	Line 3750 sub createcourse {
# ----------------------------------------------------------------- Course made	# ----------------------------------------------------------------- Course made
# log existence	# log existence
&courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).	&courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).
'='.&escape($inst_code),$uhome);	':'.&escape($inst_code).':'.&escape($course_owner),$uhome);
&flushcourselogs();	&flushcourselogs();
# set toplevel url	# set toplevel url
my $topurl=$url;	my $topurl=$url;
Line 3609 sub revokecustomrole {	Line 3803 sub revokecustomrole {
$deleteflag);	$deleteflag);
}	}

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

# ------------------------------------------------------------ Portfolio Director Lister	sub is_locked {
# returns listing of contents of user's /userfiles/portfolio/ directory	my ($file_name, $domain, $user) = @_;
#	my @check;
	my $is_locked;
	push @check, $file_name;
	my %locked = &Apache::lonnet::get('file_permissions',\@check,
	$ENV{'user.domain'},$ENV{'user.name'});
	if (ref($locked{$file_name}) eq 'ARRAY') {
	$is_locked = 'true';
	} else {
	$is_locked = 'false';
	}
	}

sub portfoliolist {	# ------------------------------------------------------------- Mark as Read Only
my ($currentPath, $currentFile) = @_;
my ($udom, $uname, $portfolioRoot);	sub mark_as_readonly {
$uname=$ENV{'user.name'};	my ($domain,$user,$files,$what) = @_;
$udom=$ENV{'user.domain'};	my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user);
# really should interrogate the system for home directory information, but . . .	foreach my $file (@{$files}) {
$portfolioRoot = '/home/httpd/lonUsers/'.$udom.'/';	push(@{$current_permissions{$file}},$what);
$uname =~ /^(.?)(.?)(.?)/;	}
$portfolioRoot = $portfolioRoot.$1.'/'.$2.'/'.$3.'/'.$uname.'/userfiles/portfolio';	&Apache::lonnet::put('file_permissions',\%current_permissions,$domain,$user);
my $listing = &reply('ls:'.$portfolioRoot.$currentPath, &homeserver($uname,$udom));	return;
return $listing;
}	}

sub portfoliomanage {	# ------------------------------------------------------------Save Selected Files

#FIXME please user the existing remove userfile function instead and	sub save_selected_files {
#add a userfilerename functions.	my ($user, $path, @files) = @_;
#FIXME uhome should never be an argument to any lonnet functions	my $filename = $user."savedfiles";
	my @other_files = &files_not_in_path($user, $path);
# handles deleting and renaming files in user's userfiles/portfolio/ directory	open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
#	foreach my $file (@files) {
my ($filename, $fileaction, $filenewname) = @_;	print (OUT $ENV{'form.currentpath'}.$file."\n");
my ($udom, $uname, $uhome);	}
$uname=$ENV{'user.name'};	foreach my $file (@other_files) {
$udom=$ENV{'user.domain'};	print (OUT $file."\n");
$uhome=$ENV{'user.home'};	}
my $listing = reply('portfoliomanage:'.$uname.':'.$udom.':'.$filename.':'.$fileaction.':'.$filenewname, $uhome);	close (OUT);
return $listing;	return 'ok';
}	}

	sub clear_selected_files {
	my ($user) = @_;
	my $filename = $user."savedfiles";
	open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
	print (OUT undef);
	close (OUT);
	return ("ok");
	}

	sub files_in_path {
	my ($user, $path) = @_;
	my $filename = $user."savedfiles";
	my %return_files;
	open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
	while (my $line_in = <IN>) {
	chomp ($line_in);
	my @paths_and_file = split (m!/!, $line_in);
	my $file_part = pop (@paths_and_file);
	my $path_part = join ('/', @paths_and_file);
	$path_part.='/';
	my $path_and_file = $path_part.$file_part;
	if ($path_part eq $path) {
	$return_files{$file_part}= 'selected';
	}
	}
	close (IN);
	return (\%return_files);
	}

	# called in portfolio select mode, to show files selected NOT in current directory
	sub files_not_in_path {
	my ($user, $path) = @_;
	my $filename = $user."savedfiles";
	my @return_files;
	my $path_part;
	open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
	while (<IN>) {
	#ok, I know it's clunky, but I want it to work
	my @paths_and_file = split m!/!, $_;
	my $file_part = pop (@paths_and_file);
	chomp ($file_part);
	my $path_part = join ('/', @paths_and_file);
	$path_part .= '/';
	my $path_and_file = $path_part.$file_part;
	if ($path_part ne $path) {
	push (@return_files, ($path_and_file));
	}
	}
	close (OUT);
	return (@return_files);
	}

	#--------------------------------------------------------------Get Marked as Read Only

	sub get_marked_as_readonly {
	my ($domain,$user,$what) = @_;
	my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user);
	my @readonly_files;
	while (my ($file_name,$value) = each(%current_permissions)) {
	if (ref($value) eq "ARRAY"){
	foreach my $stored_what (@{$value}) {
	if ($stored_what eq $what) {
	push(@readonly_files, $file_name);
	} elsif (!defined($what)) {
	push(@readonly_files, $file_name);
	}
	}
	}
	}
	return @readonly_files;
	}
	#-----------------------------------------------------------Get Marked as Read Only Hash

	sub get_marked_as_readonly_hash {
	my ($domain,$user,$what) = @_;
	my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user);
	my %readonly_files;
	while (my ($file_name,$value) = each(%current_permissions)) {
	if (ref($value) eq "ARRAY"){
	foreach my $stored_what (@{$value}) {
	if ($stored_what eq $what) {
	$readonly_files{$file_name} = 'locked';
	} elsif (!defined($what)) {
	$readonly_files{$file_name} = 'locked';
	}
	}
	}
	}
	return %readonly_files;
	}
	# ------------------------------------------------------------ Unmark as Read Only

	sub unmark_as_readonly {
	# unmarks all files locked by $what
	# for portfolio submissions, $what contains $crsid and $symb
	my ($domain,$user,$what) = @_;
	my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user);
	my @readonly_files = &Apache::lonnet::get_marked_as_readonly($domain,$user,$what);
	foreach my $file(@readonly_files){
	my $current_locks = $current_permissions{$file};
	my @new_locks;
	my @del_keys;
	if (ref($current_locks) eq "ARRAY"){
	foreach my $locker (@{$current_locks}) {
	unless ($locker eq $what) {
	push(@new_locks, $what);
	}
	}
	if (@new_locks > 0) {
	$current_permissions{$file} = \@new_locks;
	} else {
	push(@del_keys, $file);
	&Apache::lonnet::del('file_permissions',\@del_keys, $domain, $user);
	delete $current_permissions{$file};
	}
	}
	}
	&Apache::lonnet::put('file_permissions',\%current_permissions,$domain,$user);
	return;
	}

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

Line 3753 sub GetFileTimestamp {	Line 4083 sub GetFileTimestamp {

sub directcondval {	sub directcondval {
my $number=shift;	my $number=shift;
	if (!defined($ENV{'user.state.'.$ENV{'request.course.id'}})) {
	&Apache::lonuserstate::evalstate();
	}
if ($ENV{'user.state.'.$ENV{'request.course.id'}}) {	if ($ENV{'user.state.'.$ENV{'request.course.id'}}) {
return substr($ENV{'user.state.'.$ENV{'request.course.id'}},$number,1);	return substr($ENV{'user.state.'.$ENV{'request.course.id'}},$number,1);
} else {	} else {
Line 3978 sub EXT {	Line 4311 sub EXT {

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

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

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

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

my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;	my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;	my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;
my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;	my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;

my $courselevel=$courseid.'.'.$spacequalifierrest;	$courselevel=$courseid.'.'.$spacequalifierrest;
my $courselevelr=$courseid.'.'.$symbparm;	my $courselevelr=$courseid.'.'.$symbparm;
my $courselevelm=$courseid.'.'.$mapparm;	$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
Line 4035 sub EXT {	Line 4372 sub EXT {
$uname." at ".$udom.": ".	$uname." at ".$udom.": ".
$tmp."</font>");	$tmp."</font>");
} elsif ($tmp=~/error: 2 /) {	} elsif ($tmp=~/error: 2 /) {
&EXT_cache_set($udom,$uname);	&EXT_cache_set($udom,$uname);
} elsif ($tmp =~ /^(con_lost\|no_such_host)/) {	} elsif ($tmp =~ /^(con_lost\|no_such_host)/) {
return $tmp;	return $tmp;
}	}
}	}
}	}

# -------------------------------------------------------- second, check course	# ------------------------------------------------ second, check some of course

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

# ------------------------------------------------------ third, check map parms	# ------------------------------------------------------ third, check map parms
Line 4062 sub EXT {	Line 4398 sub EXT {
}	}
if ($thisparm) { return $thisparm; }	if ($thisparm) { return $thisparm; }
}	}
# --------------------------------------------- last, look in resource metadata	# ------------------------------------------ fourth, look in resource metadata

$spacequalifierrest=~s/\./\_/;	$spacequalifierrest=~s/\./\_/;
my $filename;	my $filename;
Line 4077 sub EXT {	Line 4413 sub EXT {
$metadata=&metadata($filename,'parameter_'.$spacequalifierrest);	$metadata=&metadata($filename,'parameter_'.$spacequalifierrest);
if (defined($metadata)) { return $metadata; }	if (defined($metadata)) { return $metadata; }

	# ---------------------------------------------- fourth, look in rest pf course
	if ($symbparm && defined($courseid) &&
	$courseid eq $ENV{'request.course.id'}) {
	my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'},
	$ENV{'course.'.$courseid.'.domain'},
	($courselevelm,$courselevel));
	if (defined($coursereply)) { return $coursereply; }
	}
# ------------------------------------------------------------------ Cascade up	# ------------------------------------------------------------------ Cascade up
unless ($space eq '0') {	unless ($space eq '0') {
my @parts=split(/_/,$space);	my @parts=split(/_/,$space);
Line 4119 sub packages_tab_default {	Line 4463 sub packages_tab_default {
if (defined($packagetab{"$pack_type&$name&default"})) {	if (defined($packagetab{"$pack_type&$name&default"})) {
return $packagetab{"$pack_type&$name&default"};	return $packagetab{"$pack_type&$name&default"};
}	}
	if ($pack_type eq 'part') { $pack_part='0'; }
if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) {	if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) {
return $packagetab{$pack_type."_".$pack_part."&$name&default"};	return $packagetab{$pack_type."_".$pack_part."&$name&default"};
}	}
Line 4148 sub metadata {	Line 4493 sub metadata {
my ($uri,$what,$liburi,$prefix,$depthcount)=@_;	my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
$uri=&declutter($uri);	$uri=&declutter($uri);
# if it is a non metadata possible uri return quickly	# if it is a non metadata possible uri return quickly
if (($uri eq '') \|\| (($uri =~ m\|^/*adm/\|) && ($uri !~ m\|^adm/includes\|)) \|\|	if (($uri eq '') \|\|
	(($uri =~ m\|^/*adm/\|) &&
	($uri !~ m\|^adm/includes\|) && ($uri !~ m\|/bulletinboard$\|)) \|\|
($uri =~ m\|/$\|) \|\| ($uri =~ m\|/.meta$\|) \|\| ($uri =~ /^~/) \|\|	($uri =~ m\|/$\|) \|\| ($uri =~ m\|/.meta$\|) \|\| ($uri =~ /^~/) \|\|
($uri =~ m\|home/[^/]+/public_html/\|)) {	($uri =~ m\|home/[^/]+/public_html/\|)) {
return undef;	return undef;
Line 4181 sub metadata {	Line 4528 sub metadata {
unless ($filename=~/\.meta$/) { $filename.='.meta'; }	unless ($filename=~/\.meta$/) { $filename.='.meta'; }
my $metastring;	my $metastring;
if ($uri !~ m\|^uploaded/\|) {	if ($uri !~ m\|^uploaded/\|) {
$metastring=&getfile(&filelocation('',&clutter($filename)));	my $file=&filelocation('',&clutter($filename));
	push(@{$metacache{$uri.'.file'}},$file);
	$metastring=&getfile($file);
}	}
my $parser=HTML::LCParser->new(\$metastring);	my $parser=HTML::LCParser->new(\$metastring);
my $token;	my $token;
Line 4394 sub metadata_generate_part0 {	Line 4743 sub metadata_generate_part0 {
sub gettitle {	sub gettitle {
my $urlsymb=shift;	my $urlsymb=shift;
my $symb=&symbread($urlsymb);	my $symb=&symbread($urlsymb);
unless ($symb) {	if ($symb) {
unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; }	my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);
return &metadata($urlsymb,'title');	if (defined($cached)) {
}	return $result;
my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);	}
if (defined($cached)) { return $result; }	my ($map,$resid,$url)=&decode_symb($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',	&GDBM_READER(),0640)) {
&GDBM_READER(),0640)) {	my $mapid=$bighash{'map_pc_'.&clutter($map)};
my $mapid=$bighash{'map_pc_'.&clutter($map)};	$title=$bighash{'title_'.$mapid.'.'.$resid};
$title=$bighash{'title_'.$mapid.'.'.$resid};	untie %bighash;
untie %bighash;	}
}	$title=~s/\&colon\;/\:/gs;
$title=~s/\&colon\;/\:/gs;	if ($title) {
if ($title) {	return &do_cache(\%titlecache,$symb,$title,'title');
return &do_cache(\%titlecache,$symb,$title,'title');	}
} else {	$urlsymb=$url;
return &metadata($urlsymb,'title');	}
}	my $title=&metadata($urlsymb,'title');
	if (!$title) { $title=(split('/',$urlsymb))[-1]; }
	return $title;
}	}

# ------------------------------------------------- Update symbolic store links	# ------------------------------------------------- Update symbolic store links
Line 4472 sub symbverify {	Line 4823 sub symbverify {
if (	if (
&symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)	&symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
eq $symb) {	eq $symb) {
$okay=1;	if (($ENV{'request.role.adv'}) \|\|
}	$bighash{'encrypted_'.$_} eq $ENV{'request.enc'}) {
	$okay=1;
	}
	}
}	}
}	}
untie(%bighash);	untie(%bighash);
Line 4485 sub symbverify {	Line 4839 sub symbverify {

sub symbclean {	sub symbclean {
my $symb=shift;	my $symb=shift;
	if ($symb=~m\|^/enc/\|) { $symb=&Apache::lonenc::unencrypted($symb); }
# remove version from map	# remove version from map
$symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/;	$symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/;

Line 4506 sub encode_symb {	Line 4860 sub encode_symb {
}	}

sub decode_symb {	sub decode_symb {
my ($map,$resid,$url)=split(/\_\_\_/,shift);	my $symb=shift;
	if ($symb=~m\|^/enc/\|) { $symb=&Apache::lonenc::unencrypted($symb); }
	my ($map,$resid,$url)=split(/___/,$symb);
return (&fixversion($map),$resid,&fixversion($url));	return (&fixversion($map),$resid,&fixversion($url));
}	}

Line 4546 sub deversion {	Line 4902 sub deversion {

sub symbread {	sub symbread {
my ($thisfn,$donotrecurse)=@_;	my ($thisfn,$donotrecurse)=@_;
	my $cache_str='request.symbread.cached.'.$thisfn;
	if (defined($ENV{$cache_str})) { return $ENV{$cache_str}; }
# no filename provided? try from environment	# no filename provided? try from environment
unless ($thisfn) {	unless ($thisfn) {
if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); }	if ($ENV{'request.symb'}) {
	return $ENV{$cache_str}=&symbclean($ENV{'request.symb'});
	}
$thisfn=$ENV{'request.filename'};	$thisfn=$ENV{'request.filename'};
}	}
	if ($thisfn=~m\|^/enc/\|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
# is that filename actually a symb? Verify, clean, and return	# is that filename actually a symb? Verify, clean, and return
if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {	if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {
if (&symbverify($thisfn,$1)) { return &symbclean($thisfn); }	if (&symbverify($thisfn,$1)) {
	return $ENV{$cache_str}=&symbclean($thisfn);
	}
}	}
$thisfn=declutter($thisfn);	$thisfn=declutter($thisfn);
my %hash;	my %hash;
Line 4574 sub symbread {	Line 4937 sub symbread {
unless ($syval=~/\_\d+$/) {	unless ($syval=~/\_\d+$/) {
unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {	unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {
&appenv('request.ambiguous' => $thisfn);	&appenv('request.ambiguous' => $thisfn);
return '';	return $ENV{$cache_str}='';
}	}
$syval.=$1;	$syval.=$1;
}	}
Line 4621 sub symbread {	Line 4984 sub symbread {
}	}
}	}
if ($syval) {	if ($syval) {
return &symbclean($syval.'___'.$thisfn);	return $ENV{$cache_str}=&symbclean($syval.'___'.$thisfn);
}	}
}	}
&appenv('request.ambiguous' => $thisfn);	&appenv('request.ambiguous' => $thisfn);
return '';	return $ENV{$cache_str}='';
}	}

# ---------------------------------------------------------- Return random seed	# ---------------------------------------------------------- Return random seed
Line 4639 sub numval {	Line 5002 sub numval {
$txt=~tr/U-Z/0-5/;	$txt=~tr/U-Z/0-5/;
$txt=~tr/u-z/0-5/;	$txt=~tr/u-z/0-5/;
$txt=~s/\D//g;	$txt=~s/\D//g;
	if ($_64bit) { if ($txt > 2**32) { return -1; } }
return int($txt);	return int($txt);
}	}

Line 4654 sub numval2 {	Line 5018 sub numval2 {
my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt);	my @txts=split(/(\d\d\d\d\d\d\d\d\d)/,$txt);
my $total;	my $total;
foreach my $val (@txts) { $total+=$val; }	foreach my $val (@txts) { $total+=$val; }
	if ($_64bit) { if ($total > 2**32) { return -1; } }
return int($total);	return int($total);
}	}

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

sub latest_rnd_algorithm_id {	sub latest_rnd_algorithm_id {
return '64bit3';	return '64bit4';
}	}

sub get_rand_alg {	sub get_rand_alg {
Line 4670 sub get_rand_alg {	Line 5052 sub get_rand_alg {
return &latest_rnd_algorithm_id();	return &latest_rnd_algorithm_id();
}	}

	sub validCODE {
	my ($CODE)=@_;
	if (defined($CODE) && $CODE ne '' && $CODE =~ /^\w+$/) { return 1; }
	return 0;
	}

sub getCODE {	sub getCODE {
if (defined($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; }	if (&validCODE($ENV{'form.CODE'})) { return $ENV{'form.CODE'}; }
if (defined($Apache::lonhomework::parsing_a_problem) &&	if (defined($Apache::lonhomework::parsing_a_problem) &&
defined($Apache::lonhomework::history{'resource.CODE'})) {	&validCODE($Apache::lonhomework::history{'resource.CODE'})) {
return $Apache::lonhomework::history{'resource.CODE'};	return $Apache::lonhomework::history{'resource.CODE'};
}	}
return undef;	return undef;
Line 4691 sub rndseed {	Line 5079 sub rndseed {
if (!$username) { $username=$wusername }	if (!$username) { $username=$wusername }
my $which=&get_rand_alg();	my $which=&get_rand_alg();
if (defined(&getCODE())) {	if (defined(&getCODE())) {
return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);	if ($which eq '64bit4') {
	return &rndseed_CODE_64bit4($symb,$courseid,$domain,$username);
	} else {
	return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);
	}
	} elsif ($which eq '64bit4') {
	return &rndseed_64bit4($symb,$courseid,$domain,$username);
} elsif ($which eq '64bit3') {	} elsif ($which eq '64bit3') {
return &rndseed_64bit3($symb,$courseid,$domain,$username);	return &rndseed_64bit3($symb,$courseid,$domain,$username);
} elsif ($which eq '64bit2') {	} elsif ($which eq '64bit2') {
Line 4715 sub rndseed_32bit {	Line 5109 sub rndseed_32bit {
my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;	my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed\|$courseseed;$namechck:$symbchck");	#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed\|$courseseed;$namechck:$symbchck");
#&Apache::lonxml::debug("rndseed :$num:$symb");	#&Apache::lonxml::debug("rndseed :$num:$symb");
	if ($_64bit) { $num=(($num<<32)>>32); }
return $num;	return $num;
}	}
}	}
Line 4735 sub rndseed_64bit {	Line 5130 sub rndseed_64bit {
my $num2=$nameseed+$domainseed+$courseseed;	my $num2=$nameseed+$domainseed+$courseseed;
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed\|$courseseed;$namechck:$symbchck");	#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed\|$courseseed;$namechck:$symbchck");
#&Apache::lonxml::debug("rndseed :$num:$symb");	#&Apache::lonxml::debug("rndseed :$num:$symb");
	if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
	if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }
return "$num1,$num2";	return "$num1,$num2";
}	}
}	}
Line 4778 sub rndseed_64bit3 {	Line 5175 sub rndseed_64bit3 {
my $num1=$symbchck+$symbseed+$namechck;	my $num1=$symbchck+$symbseed+$namechck;
my $num2=$nameseed+$domainseed+$courseseed;	my $num2=$nameseed+$domainseed+$courseseed;
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed\|$courseseed;$namechck:$symbchck");	#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed\|$courseseed;$namechck:$symbchck");
#&Apache::lonxml::debug("rndseed :$num:$symb");	#&Apache::lonxml::debug("rndseed :$num1:$num2:$_64bit");
	if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }

	return "$num1:$num2";
	}
	}

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

	my $nameseed=numval3($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 :$num1:$num2:$_64bit");
	if ($_64bit) { $num1=(($num1<<32)>>32); $num2=(($num2<<32)>>32); }

return "$num1:$num2";	return "$num1:$num2";
}	}
}	}
Line 4796 sub rndseed_CODE_64bit {	Line 5219 sub rndseed_CODE_64bit {
my $num2=$CODEseed+$courseseed+$symbchck;	my $num2=$CODEseed+$courseseed+$symbchck;
#&Apache::lonxml::debug("$symbseed:$CODEchck\|$CODEseed:$courseseed:$symbchck");	#&Apache::lonxml::debug("$symbseed:$CODEchck\|$CODEseed:$courseseed:$symbchck");
#&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");	#&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");
	if ($_64bit) { $num1=(($num1<<32)>>32); }
	if ($_64bit) { $num2=(($num2<<32)>>32); }
	return "$num1:$num2";
	}
	}

	sub rndseed_CODE_64bit4 {
	my ($symb,$courseid,$domain,$username)=@_;
	{
	use integer;
	my $symbchck=unpack("%32S*",$symb.' ') << 16;
	my $symbseed=numval3($symb);
	my $CODEchck=unpack("%32S*",&getCODE().' ') << 16;
	my $CODEseed=numval3(&getCODE());
	my $courseseed=unpack("%32S*",$courseid.' ');
	my $num1=$symbseed+$CODEchck;
	my $num2=$CODEseed+$courseseed+$symbchck;
	#&Apache::lonxml::debug("$symbseed:$CODEchck\|$CODEseed:$courseseed:$symbchck");
	#&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");
	if ($_64bit) { $num1=(($num1<<32)>>32); }
	if ($_64bit) { $num2=(($num2<<32)>>32); }
return "$num1:$num2";	return "$num1:$num2";
}	}
}	}
Line 4886 sub receipt {	Line 5330 sub receipt {
# the local server.	# the local server.

sub getfile {	sub getfile {
my ($file,$caller) = @_;	my ($file) = @_;

if ($file !~ m\|^/*uploaded/(\w+)/(\w+)/(.+)$\|) {	if ($file =~ m\|^/*uploaded/\|) { $file=&filelocation("",$file); }
# normal file from res space	&repcopy($file);
&repcopy($file);	return &readfile($file);
return &readfile($file);	}
}
	sub repcopy_userfile {
my $info;	my ($file)=@_;
my $cdom = $1;
my $cnum = $2;	if ($file =~ m\|^/*uploaded/\|) { $file=&filelocation("",$file); }
my $filename = $3;	if ($file =~ m\|^/home/httpd/html/lonUsers/\|) { return OK; }
my $path = $Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles';
my ($lwpresp,$rtncode);	my ($cdom,$cnum,$filename) =
my $localfile = $path.'/'.$cdom.'/'.$cnum.'/'.$filename;	($file=~m\|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)\|);
if (-e "$localfile") {	my ($info,$rtncode);
my @fileinfo = stat($localfile);	my $uri="/uploaded/$cdom/$cnum/$filename";
$lwpresp = &getuploaded('HEAD',$file,$cdom,$cnum,\$info,\$rtncode);	if (-e "$file") {
	my @fileinfo = stat($file);
	my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode);
if ($lwpresp ne 'ok') {	if ($lwpresp ne 'ok') {
if ($rtncode eq '404') {	if ($rtncode eq '404') {
unlink($localfile);	unlink($file);
}	}
#my $ua=new LWP::UserAgent;	#my $ua=new LWP::UserAgent;
#my $request=new HTTP::Request('GET',&tokenwrapper($file));	#my $request=new HTTP::Request('GET',&tokenwrapper($uri));
#my $response=$ua->request($request);	#my $response=$ua->request($request);
#if ($response->is_success()) {	#if ($response->is_success()) {
# return $response->content;	# return $response->content;
Line 4919 sub getfile {	Line 5365 sub getfile {
return -1;	return -1;
}	}
if ($info < $fileinfo[9]) {	if ($info < $fileinfo[9]) {
return &readfile($localfile);	return OK;
}	}
$info = '';	$info = '';
$lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode);	$lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);
if ($lwpresp ne 'ok') {	if ($lwpresp ne 'ok') {
return -1;	return -1;
}	}
} else {	} else {
$lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode);	my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);
if ($lwpresp ne 'ok') {	if ($lwpresp ne 'ok') {
my $ua=new LWP::UserAgent;	my $ua=new LWP::UserAgent;
my $request=new HTTP::Request('GET',&tokenwrapper($file));	my $request=new HTTP::Request('GET',&tokenwrapper($uri));
my $response=$ua->request($request);	my $response=$ua->request($request);
if ($response->is_success()) {	if ($response->is_success()) {
return $response->content;	$info=$response->content;
} else {	} else {
return -1;	return -1;
}	}
Line 4942 sub getfile {	Line 5388 sub getfile {
if ($filename =~ m\|^(.+)/[^/]+$\|) {	if ($filename =~ m\|^(.+)/[^/]+$\|) {
push @parts, split(/\//,$1);	push @parts, split(/\//,$1);
}	}
	my $path = $perlvar{'lonDocRoot'}.'/userfiles';
foreach my $part (@parts) {	foreach my $part (@parts) {
$path .= '/'.$part;	$path .= '/'.$part;
if (!-e $path) {	if (!-e $path) {
Line 4949 sub getfile {	Line 5396 sub getfile {
}	}
}	}
}	}
open (FILE,">$localfile");	open(FILE,">$file");
print FILE $info;	print FILE $info;
close(FILE);	close(FILE);
if ($caller eq 'uploadrep') {	return OK;
return 'ok';
}
return $info;
}	}

sub tokenwrapper {	sub tokenwrapper {
my $uri=shift;	my $uri=shift;
$uri=~s/^http\:\/\/([^\/]+)//;	$uri=~s\|^http\://([^/]+)\|\|;
$uri=~s/^\///;	$uri=~s\|^/\|\|;
$ENV{'user.environment'}=~/\/([^\/]+)\.id/;	$ENV{'user.environment'}=~/\/([^\/]+)\.id/;
my $token=$1;	my $token=$1;
if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.)$/) {	my (undef,$udom,$uname,$file)=split('/',$uri,4);
&appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});	if ($udom && $uname && $file) {
return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.	$file=~s\|(\?\.)$\|\|;
	&appenv("userfile.$udom/$uname/$file" => $ENV{'request.course.id'});
	return 'http://'.$hostname{ &homeserver($uname,$udom)}.'/'.$uri.
(($uri=~/\?/)?'&':'?').'token='.$token.	(($uri=~/\?/)?'&':'?').'token='.$token.
'&tokenissued='.$perlvar{'lonHostID'};	'&tokenissued='.$perlvar{'lonHostID'};
} else {	} else {
Line 5004 sub readfile {	Line 5450 sub readfile {
}	}

sub filelocation {	sub filelocation {
my ($dir,$file) = @_;	my ($dir,$file) = @_;
my $location;	my $location;
$file=~ s/^\s(\S+)\s$/$1/; ## strip off leading and trailing spaces	$file=~ s/^\s(\S+)\s$/$1/; ## strip off leading and trailing spaces
if ($file=~m:^/~:) { # is a contruction space reference	if ($file=~m:^/~:) { # is a contruction space reference
$location = $file;	$location = $file;
$location =~ s:/~(.?)/(.):/home/$1/public_html/$2:;	$location =~ s:/~(.?)/(.):/home/$1/public_html/$2:;
} elsif ($file=~/^\/*uploaded/) { # is an uploaded file	} elsif ($file=~/^\/*uploaded/) { # is an uploaded file
$location=$file;	my ($udom,$uname,$filename)=
} else {	($file=~m\|^/+uploaded/+([^/]+)/+([^/]+)/+(.*)$\|);
$file=~s/^\Q$perlvar{'lonDocRoot'}\E//;	my $home=&homeserver($uname,$udom);
$file=~s:^/res/:/:;	my $is_me=0;
if ( !( $file =~ m:^/:) ) {	my @ids=&current_machine_ids();
$location = $dir. '/'.$file;	foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
} else {	if ($is_me) {
$location = '/home/httpd/html/res'.$file;	$location=&Apache::loncommon::propath($udom,$uname).
	'/userfiles/'.$filename;
	} else {
	$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
	$udom.'/'.$uname.'/'.$filename;
	}
	} elsif ($file =~ /^\/adm\/portfolio\//) {
	$file =~ s:^/adm/portfolio/::;
	$location = $location=&Apache::loncommon::propath($ENV{'user.domain'},$ENV{'user.name'}).'/userfiles/portfolio/'.$file;
	} else {
	$file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
	$file=~s:^/res/:/:;
	if ( !( $file =~ m:^/:) ) {
	$location = $dir. '/'.$file;
	} else {
	$location = '/home/httpd/html/res'.$file;
	}
}	}
}	$location=~s://+:/:g; # remove duplicate /
$location=~s://+:/:g; # remove duplicate /	while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..	while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./
while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./	return $location;
return $location;
}	}

sub hreflocation {	sub hreflocation {
Line 5070 sub current_machine_ids {	Line 5531 sub current_machine_ids {

sub declutter {	sub declutter {
my $thisfn=shift;	my $thisfn=shift;
	if ($thisfn=~m\|^/enc/\|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
$thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;	$thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;
$thisfn=~s/^\///;	$thisfn=~s/^\///;
$thisfn=~s/^res\///;	$thisfn=~s/^res\///;
Line 5087 sub clutter {	Line 5549 sub clutter {
return $thisfn;	return $thisfn;
}	}

	sub freeze_escape {
	my ($value)=@_;
	if (ref($value)) {
	$value=&nfreeze($value);
	return '__FROZEN__'.&escape($value);
	}
	return &escape($value);
	}

# -------------------------------------------------------- Escape Special Chars	# -------------------------------------------------------- Escape Special Chars

sub escape {	sub escape {
Line 5103 sub unescape {	Line 5574 sub unescape {
return $str;	return $str;
}	}

	sub thaw_unescape {
	my ($value)=@_;
	if ($value =~ /^__FROZEN__/) {
	substr($value,0,10,undef);
	$value=&unescape($value);
	return &thaw($value);
	}
	return &unescape($value);
	}

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

sub correct_line_ends {	sub correct_line_ends {
Line 5128 sub goodbye {	Line 5609 sub goodbye {
&logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache)));	&logthis(sprintf("%-20s is %s",'%courseresdatacache',scalar(%courseresdatacache)));
#1.1 only	#1.1 only
&logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache)));	&logthis(sprintf("%-20s is %s",'%userresdatacache',scalar(%userresdatacache)));
&logthis(sprintf("%-20s is %s",'%usectioncache',scalar(%usectioncache)));	&logthis(sprintf("%-20s is %s",'%getsectioncache',scalar(%getsectioncache)));
&logthis(sprintf("%-20s is %s",'%courseresversioncache',scalar(%courseresversioncache)));	&logthis(sprintf("%-20s is %s",'%courseresversioncache',scalar(%courseresversioncache)));
&logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache)));	&logthis(sprintf("%-20s is %s",'%resversioncache',scalar(%resversioncache)));
&flushcourselogs();	&flushcourselogs();
Line 5140 BEGIN {	Line 5621 BEGIN {
# ----------------------------------- Read loncapa.conf and loncapa_apache.conf	# ----------------------------------- Read loncapa.conf and loncapa_apache.conf
unless ($readit) {	unless ($readit) {
{	{
	# FIXME: Use LONCAPA::Configuration::read_conf here and omit next block
open(my $config,"</etc/httpd/conf/loncapa.conf");	open(my $config,"</etc/httpd/conf/loncapa.conf");

while (my $configline=<$config>) {	while (my $configline=<$config>) {
Line 5200 BEGIN {	Line 5682 BEGIN {
while (my $configline=<$config>) {	while (my $configline=<$config>) {
next if ($configline =~ /^(\#\|\s*$)/);	next if ($configline =~ /^(\#\|\s*$)/);
chomp($configline);	chomp($configline);
my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline);	my ($id,$domain,$role,$name)=split(/:/,$configline);
if ($id && $domain && $role && $name && $ip) {	$name=~s/\s//g;
	if ($id && $domain && $role && $name) {
	my $ip = gethostbyname($name);
	if (length($ip) ne 4) {
	&logthis("Skipping host $id name $name no IP $ip found\n");
	next;
	}
	$ip=inet_ntoa($ip);
	push(@{$iphost{$ip}},$id);
$hostname{$id}=$name;	$hostname{$id}=$name;
$hostdom{$id}=$domain;	$hostdom{$id}=$domain;
$hostip{$id}=$ip;
$iphost{$ip}=$id;
if ($role eq 'library') { $libserv{$id}=$name; }	if ($role eq 'library') { $libserv{$id}=$name; }
} else {
if ($configline) {
&logthis("Skipping hosts.tab line -$configline-");
}
}	}
}	}
close($config);	close($config);
Line 5287 $dumpcount=0;	Line 5771 $dumpcount=0;
&logtouch();	&logtouch();
&logthis('<font color=yellow>INFO: Read configuration</font>');	&logthis('<font color=yellow>INFO: Read configuration</font>');
$readit=1;	$readit=1;
	{
	use integer;
	my $test=(2**32)+1;
	if ($test != 0) { $_64bit=1; } else { $_64bit=0; }
	&logthis(" Detected 64bit platform ($_64bit)");
	}
}	}
}	}

Line 5514 X<rolesinit()>	Line 6004 X<rolesinit()>
B<rolesinit($udom,$username,$authhost)>: get user privileges	B<rolesinit($udom,$username,$authhost)>: get user privileges

=item *	=item *
X<usection()>	X<getsection()>
B<usection($udom,$uname,$cname)>: finds the section of student in the	B<getsection($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"

Line 5773 returns the data handle	Line 6263 returns the data handle
=item *	=item *

symbverify($symb,$thisfn) : verifies that $symb actually exists and is	symbverify($symb,$thisfn) : verifies that $symb actually exists and is
a possible symb for the URL in $thisfn, returns a 1 on success, 0 on	a possible symb for the URL in $thisfn, and if is an encryypted
failure, user must be in a course, as it assumes the existance of the	resource that the user accessed using /enc/ returns a 1 on success, 0
course initi hash, and uses $ENV('request.course.id'}	on failure, user must be in a course, as it assumes the existance of
	the course initial hash, and uses $ENV('request.course.id'}


=item *	=item *
Line 5902 put($namespace,$storehash,$udom,$uname)	Line 6393 put($namespace,$storehash,$udom,$uname)

=item *	=item *

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

	=item *

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

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

Removed from v.1.522
changed lines
	Added in v.1.597