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.473 and 1.549

version 1.473, 2004/02/24 16:26:06	version 1.549, 2004/10/05 11:24:34
Line 32 package Apache::lonnet;	Line 32 package Apache::lonnet;
use strict;	use strict;
use LWP::UserAgent();	use LWP::UserAgent();
use HTTP::Headers;	use HTTP::Headers;
	use HTTP::Date;
	# use Date::Parse;
use vars	use vars
qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom	qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom
%libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache	%libserv %pr %prp %metacache %packagetab %titlecache %courseresversioncache %resversioncache
%courselogs %accesshash %userrolehash $processmarker $dumpcount	%courselogs %accesshash %userrolehash $processmarker $dumpcount
%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache	%coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseresdatacache
%userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def	%userresdatacache %usectioncache %domaindescription %domain_auth_def %domain_auth_arg_def
%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir);	%domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir);

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

=pod	=pod
Line 114 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";
	#
	# With loncnew process trimming, there's a timing hole between lonc server
	# process exit and the master server picking up the listen on the AF_UNIX
	# socket. In that time interval, a lock file will exist:

	my $lockfile=$peerfile.".lock";
	while (-e $lockfile) { # Need to wait for the lockfile to disappear.
	sleep(1);
	}
	# At this point, either a loncnew parent is listening or an old lonc
	# or loncnew child is listening so we can connect.
	#
my $client=IO::Socket::UNIX->new(Peer =>"$peerfile",	my $client=IO::Socket::UNIX->new(Peer =>"$peerfile",
Type => SOCK_STREAM,	Type => SOCK_STREAM,
Timeout => 10)	Timeout => 10)
Line 432 sub overloaderror {	Line 446 sub overloaderror {
if ($overload>0) {	if ($overload>0) {
$r->err_headers_out->{'Retry-After'}=$overload;	$r->err_headers_out->{'Retry-After'}=$overload;
$r->log_error('Overload of '.$overload.' on '.$checkserver);	$r->log_error('Overload of '.$overload.' on '.$checkserver);
return 413;	return 409;
}	}
return '';	return '';
}	}
Line 615 sub idput {	Line 629 sub idput {
my ($udom,%ids)=@_;	my ($udom,%ids)=@_;
my %servers=();	my %servers=();
foreach (keys %ids) {	foreach (keys %ids) {
	&cput('environment',{'id'=>$ids{$_}},$udom,$_);
my $uhom=&homeserver($_,$udom);	my $uhom=&homeserver($_,$udom);
if ($uhom ne 'no_host') {	if ($uhom ne 'no_host') {
my $id=&escape($ids{$_});	my $id=&escape($ids{$_});
Line 625 sub idput {	Line 640 sub idput {
} else {	} else {
$servers{$uhom}=$id.'='.$unam;	$servers{$uhom}=$id.'='.$unam;
}	}
&critical('put:'.$udom.':'.$unam.':environment:id='.$id,$uhom);
}	}
}	}
foreach (keys %servers) {	foreach (keys %servers) {
Line 640 sub assign_access_key {	Line 654 sub assign_access_key {
# a valid key looks like uname:udom#comments	# a valid key looks like uname:udom#comments
# comments are being appended	# comments are being appended
#	#
my ($ckey,$cdom,$cnum,$udom,$uname,$logentry)=@_;	my ($ckey,$kdom,$knum,$cdom,$cnum,$udom,$uname,$logentry)=@_;
	$kdom=
	$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($kdom));
	$knum=
	$ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($knum));
$cdom=	$cdom=
$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));	$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
$cnum=	$cnum=
$ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));	$ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
$udom=$ENV{'user.name'} unless (defined($udom));	$udom=$ENV{'user.name'} unless (defined($udom));
$uname=$ENV{'user.domain'} unless (defined($uname));	$uname=$ENV{'user.domain'} unless (defined($uname));
my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);	my %existing=&get('accesskeys',[$ckey],$kdom,$knum);
if (($existing{$ckey}=~/^\#(.*)$/) \|\| # - new key	if (($existing{$ckey}=~/^\#(.*)$/) \|\| # - new key
($existing{$ckey}=~/^$uname\:$udom\#(.*)$/)) {	($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#(.*)$/)) {
# assigned to this person	# assigned to this person
# - this should not happen,	# - this should not happen,
# unless something went wrong	# unless something went wrong
# the first time around	# the first time around
# ready to assign	# ready to assign
$logentry=$1.'; '.$logentry;	$logentry=$1.'; '.$logentry;
if (&put('accesskey',{$ckey=>$uname.':'.$udom.'#'.$logentry},	if (&put('accesskeys',{$ckey=>$uname.':'.$udom.'#'.$logentry},
$cdom,$cnum) eq 'ok') {	$kdom,$knum) eq 'ok') {
# key now belongs to user	# key now belongs to user
my $envkey='key.'.$cdom.'_'.$cnum;	my $envkey='key.'.$cdom.'_'.$cnum;
if (&put('environment',{$envkey => $ckey}) eq 'ok') {	if (&put('environment',{$envkey => $ckey}) eq 'ok') {
Line 753 sub validate_access_key {	Line 771 sub validate_access_key {
$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));	$ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
$cnum=	$cnum=
$ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));	$ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
$udom=$ENV{'user.name'} unless (defined($udom));	$udom=$ENV{'user.domain'} unless (defined($udom));
$uname=$ENV{'user.domain'} unless (defined($uname));	$uname=$ENV{'user.name'} unless (defined($uname));
my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);	my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
return ($existing{$ckey}=~/^$uname\:$udom\#/);	return ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#/);
}	}

# ------------------------------------- Find the section of student in a course	# ------------------------------------- Find the section of student in a course
Line 784 sub getsection {	Line 802 sub getsection {
&homeserver($unam,$udom)))) {	&homeserver($unam,$udom)))) {
my ($key,$value)=split(/\=/,$_);	my ($key,$value)=split(/\=/,$_);
$key=&unescape($key);	$key=&unescape($key);
next if ($key !~/^$courseid(?:\/)(\w+)\_st$/);	next if ($key !~/^\Q$courseid\E(?:\/)(\w+)\_st$/);
my $section=$1;	my $section=$1;
if ($key eq $courseid.'_st') { $section=''; }	if ($key eq $courseid.'_st') { $section=''; }
my ($dummy,$end,$start)=split(/\_/,&unescape($value));	my ($dummy,$end,$start)=split(/\_/,&unescape($value));
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;
}	}
Line 815 sub getsection {	Line 833 sub getsection {
}	}


my $disk_caching_disabled=1;	my $disk_caching_disabled=0;

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 850 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 875 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 929 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 963 sub usection {	Line 1032 sub usection {
&homeserver($unam,$udom)))) {	&homeserver($unam,$udom)))) {
my ($key,$value)=split(/\=/,$_);	my ($key,$value)=split(/\=/,$_);
$key=&unescape($key);	$key=&unescape($key);
if ($key=~/^$courseid(?:\/)(\w+)\_st$/) {	if ($key=~/^\Q$courseid\E(?:\/)(\w+)\_st$/) {
my $section=$1;	my $section=$1;
if ($key eq $courseid.'_st') { $section=''; }	if ($key eq $courseid.'_st') { $section=''; }
my ($dummy,$end,$start)=split(/\_/,&unescape($value));	my ($dummy,$end,$start)=split(/\_/,&unescape($value));
Line 1041 sub currentversion {	Line 1110 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 1060 sub subscribe {	Line 1130 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 1125 sub ssi_body {	Line 1201 sub ssi_body {
my ($filelink,%form)=@_;	my ($filelink,%form)=@_;
my $output=($filelink=~/^http\:/?&externalssi($filelink):	my $output=($filelink=~/^http\:/?&externalssi($filelink):
&ssi($filelink,%form));	&ssi($filelink,%form));
$output=~s/^.?\<body[^\>]\>//si;
$output=~s/(.)\<\/body\s\>.*?$/$1/si;
$output=~	$output=~
s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs;	s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs;
	$output=~s/^.?\<body[^\>]\>//si;
	$output=~s/(.)\<\/body\s\>.*?$/$1/si;
return $output;	return $output;
}	}

Line 1163 sub externalssi {	Line 1239 sub externalssi {
return $response->content;	return $response->content;
}	}

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

sub tokenwrapper {	sub allowuploaded {
my $uri=shift;	my ($srcurl,$url)=@_;
$uri=~s/^http\:\/\/([^\/]+)//;	$url=&clutter(&declutter($url));
$uri=~s/^\///;	my $dir=$url;
$ENV{'user.environment'}=~/\/([^\/]+)\.id/;	$dir=~s/\/[^\/]+$//;
my $token=$1;	my %httpref=();
if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.)$/) {	my $httpurl=&hreflocation('',$url);
&appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});	$httpref{'httpref.'.$httpurl}=$srcurl;
return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.	&Apache::lonnet::appenv(%httpref);
(($uri=~/\?/)?'&':'?').'token='.$token.	}
'&tokenissued='.$perlvar{'lonHostID'};
	# --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
	# input: action, courseID, current domain, home server for course, intended
	# path to file, source of file.
	# output: url to file (if action was uploaddoc),
	# ok if successful, or diagnostic message otherwise (if action was propagate or copy)
	#
	# Allows directory structure to be used within lonUsers/../userfiles/ for a
	# course.
	#
	# action = propagate - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
	# will be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles in
	# course's home server.
	#
	# action = copy - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file will
	# be copied from $source (current location) to
	# /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
	# and will then be copied to
	# /home/httpd/lonUsers/$domain/1/2/3/$course/userfiles/$file in
	# course's home server.
	#
	# action = uploaddoc - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
	# will be retrived from $ENV{form.uploaddoc} (from DOCS interface) to
	# /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
	# and will then be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles/$file
	# in course's home server.


	sub process_coursefile {
	my ($action,$docuname,$docudom,$docuhome,$file,$source)=@_;
	my $fetchresult;
	if ($action eq 'propagate') {
	$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file
	,$docuhome);
} else {	} else {
return '/adm/notfound.html';	my $fetchresult = '';
	my $fpath = '';
	my $fname = $file;
	($fpath,$fname) = ($file =~ m\|^(.*)/([^/]+)$\|);
	$fpath=$docudom.'/'.$docuname.'/'.$fpath;
	my $filepath=$perlvar{'lonDocRoot'}.'/userfiles';
	unless ($fpath eq '') {
	my @parts=split('/',$fpath);
	foreach my $part (@parts) {
	$filepath.= '/'.$part;
	if ((-e $filepath)!=1) {
	mkdir($filepath,0777);
	}
	}
	}
	if ($action eq 'copy') {
	if ($source eq '') {
	$fetchresult = 'no source file';
	return $fetchresult;
	} else {
	my $destination = $filepath.'/'.$fname;
	rename($source,$destination);
	$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
	$docuhome);
	}
	} elsif ($action eq 'uploaddoc') {
	open(my $fh,'>'.$filepath.'/'.$fname);
	print $fh $ENV{'form.'.$source};
	close($fh);
	$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
	$docuhome);
	if ($fetchresult eq 'ok') {
	return '/uploaded/'.$fpath.'/'.$fname;
	} else {
	&logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
	' to host '.$docuhome.': '.$fetchresult);
	return '/adm/notfound.html';
	}
	}
}	}
	unless ( $fetchresult eq 'ok') {
	&logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
	' to host '.$docuhome.': '.$fetchresult);
	}
	return $fetchresult;
}	}

# --------------- Take an uploaded file and put it into the userfiles directory	# --------------- Take an uploaded file and put it into the userfiles directory
# input: name of form element, coursedoc=1 means this is for the course	# input: name of form element, coursedoc=1 means this is for the course
# output: url of file in userspace	# output: url of file in userspace

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

	sub userfileupload {
	my ($formname,$coursedoc,$subdir)=@_;
	if (!defined($subdir)) { $subdir='unknown'; }
	my $fname=$ENV{'form.'.$formname.'.filename'};
	$fname=&clean_filename($fname);
# See if there is anything left	# See if there is anything left
unless ($fname) { return 'error: no uploaded file'; }	unless ($fname) { return 'error: no uploaded file'; }
chop($ENV{'form.'.$formname});	chop($ENV{'form.'.$formname});
	if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { #files uploaded to help request form are handled differently
	my $now = time;
	my $filepath = 'tmp/helprequests/'.$now;
	my @parts=split(/\//,$filepath);
	my $fullpath = $perlvar{'lonDaemons'};
	for (my $i=0;$i<@parts;$i++) {
	$fullpath .= '/'.$parts[$i];
	if ((-e $fullpath)!=1) {
	mkdir($fullpath,0777);
	}
	}
	open(my $fh,'>'.$fullpath.'/'.$fname);
	print $fh $ENV{'form.'.$formname};
	close($fh);
	return $fullpath.'/'.$fname;
	}
# Create the directory if not present	# Create the directory if not present
my $docuname='';	my $docuname='';
my $docudom='';	my $docudom='';
my $docuhome='';	my $docuhome='';
	$fname="$subdir/$fname";
if ($coursedoc) {	if ($coursedoc) {
$docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'};	$docuname=$ENV{'course.'.$ENV{'request.course.id'}.'.num'};
$docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'};	$docudom=$ENV{'course.'.$ENV{'request.course.id'}.'.domain'};
$docuhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};	$docuhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
	if ($ENV{'form.folder'} =~ m/^default/) {
	return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);
	} else {
	$fname=$ENV{'form.folder'}.'/'.$fname;
	return &process_coursefile('uploaddoc',$docuname,$docudom,$docuhome,$fname,$formname);
	}
} else {	} else {
$docuname=$ENV{'user.name'};	$docuname=$ENV{'user.name'};
$docudom=$ENV{'user.domain'};	$docudom=$ENV{'user.domain'};
$docuhome=$ENV{'user.home'};	$docuhome=$ENV{'user.home'};
	return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);
}	}
return
&finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);
}	}

sub finishuserfileupload {	sub finishuserfileupload {
my ($docuname,$docudom,$docuhome,$formname,$fname)=@_;	my ($docuname,$docudom,$docuhome,$formname,$fname)=@_;
my $path=$docudom.'/'.$docuname.'/';	my $path=$docudom.'/'.$docuname.'/';
my $filepath=$perlvar{'lonDocRoot'};	my $filepath=$perlvar{'lonDocRoot'};
	my ($fnamepath,$file);
	$file=$fname;
	if ($fname=~m\|/\|) {
	($fnamepath,$file) = ($fname =~ m\|^(.*)/([^/]+)$\|);
	$path.=$fnamepath.'/';
	}
my @parts=split(/\//,$filepath.'/userfiles/'.$path);	my @parts=split(/\//,$filepath.'/userfiles/'.$path);
my $count;	my $count;
for ($count=4;$count<=$#parts;$count++) {	for ($count=4;$count<=$#parts;$count++) {
Line 1230 sub finishuserfileupload {	Line 1420 sub finishuserfileupload {
}	}
# Save the file	# Save the file
{	{
open(my $fh,'>'.$filepath.'/'.$fname);	#&Apache::lonnet::logthis("Saving to $filepath $file");
	open(my $fh,'>'.$filepath.'/'.$file);
print $fh $ENV{'form.'.$formname};	print $fh $ENV{'form.'.$formname};
close($fh);	close($fh);
}	}
# Notify homeserver to grep it	# Notify homeserver to grep it
#	#
	my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
my $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,
$docuhome);
if ($fetchresult eq 'ok') {	if ($fetchresult eq 'ok') {
#	#
# Return the URL to it	# Return the URL to it
return '/uploaded/'.$path.$fname;	return '/uploaded/'.$path.$file;
} else {	} else {
&logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$fname.	&logthis('Failed to transfer '.$path.$file.' to host '.$docuhome.
' to host '.$docuhome.': '.$fetchresult);	': '.$fetchresult);
return '/adm/notfound.html';	return '/adm/notfound.html';
}	}
}	}

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

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

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

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

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

sub log {	sub log {
Line 1289 sub flushcourselogs {	Line 1503 sub flushcourselogs {
}	}
if ($courseidbuffer{$coursehombuf{$crsid}}) {	if ($courseidbuffer{$coursehombuf{$crsid}}) {
$courseidbuffer{$coursehombuf{$crsid}}.='&'.	$courseidbuffer{$coursehombuf{$crsid}}.='&'.
&escape($crsid).'='.&escape($coursedescrbuf{$crsid});	&escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
	'='.&escape($courseinstcodebuf{$crsid});
} else {	} else {
$courseidbuffer{$coursehombuf{$crsid}}=	$courseidbuffer{$coursehombuf{$crsid}}=
&escape($crsid).'='.&escape($coursedescrbuf{$crsid});	&escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
	'='.&escape($courseinstcodebuf{$crsid});
}	}
}	}
#	#
Line 1366 sub courselog {	Line 1582 sub courselog {
$ENV{'course.'.$ENV{'request.course.id'}.'.home'};	$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
$coursedescrbuf{$ENV{'request.course.id'}}=	$coursedescrbuf{$ENV{'request.course.id'}}=
$ENV{'course.'.$ENV{'request.course.id'}.'.description'};	$ENV{'course.'.$ENV{'request.course.id'}.'.description'};
	$courseinstcodebuf{$ENV{'request.course.id'}}=
	$ENV{'course.'.$ENV{'request.course.id'}.'.internal.coursecode'};
if (defined $courselogs{$ENV{'request.course.id'}}) {	if (defined $courselogs{$ENV{'request.course.id'}}) {
$courselogs{$ENV{'request.course.id'}}.='&'.$what;	$courselogs{$ENV{'request.course.id'}}.='&'.$what;
} else {	} else {
Line 1490 sub getannounce {	Line 1708 sub getannounce {
if ($announcement=~/\w/) {	if ($announcement=~/\w/) {
return	return
'<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'.	'<table bgcolor="#FF5555" cellpadding="5" cellspacing="3">'.
'<tr><td bgcolor="#FFFFFF"><pre>'.$announcement.'</pre></td></tr></table>';	'<tr><td bgcolor="#FFFFFF"><tt>'.$announcement.'</tt></td></tr></table>';
} else {	} else {
return '';	return '';
}	}
Line 1509 sub courseidput {	Line 1727 sub courseidput {
}	}

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

}	}
}	}
return %returnhash;	return %returnhash;
Line 1532 sub courseiddump {	Line 1751 sub courseiddump {
#	#
# ----------------------------------------------------------- Check out an item	# ----------------------------------------------------------- Check out an item

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

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

sub checkout {	sub checkout {
my ($symb,$tuname,$tudom,$tcrsid)=@_;	my ($symb,$tuname,$tudom,$tcrsid)=@_;
my $now=time;	my $now=time;
Line 1710 sub hash2str {	Line 1951 sub hash2str {
sub hashref2str {	sub hashref2str {
my ($hashref)=@_;	my ($hashref)=@_;
my $result='__HASH_REF__';	my $result='__HASH_REF__';
foreach (keys(%$hashref)) {	foreach (sort(keys(%$hashref))) {
if (ref($_) eq 'ARRAY') {	if (ref($_) eq 'ARRAY') {
$result.=&arrayref2str($_).'=';	$result.=&arrayref2str($_).'=';
} elsif (ref($_) eq 'HASH') {	} elsif (ref($_) eq 'HASH') {
Line 2442 sub put {	Line 2683 sub put {
return &reply("put:$udomain:$uname:$namespace:$items",$uhome);	return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
}	}

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

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

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

sub cput {	sub cput {
Line 2521 sub allowed {	Line 2786 sub allowed {
$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 2571 sub allowed {	Line 2845 sub allowed {

# Course	# Course

if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/$priv\&([^\:]*)/) {	if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) {
$thisallowed.=$1;	$thisallowed.=$1;
}	}

# Domain	# Domain

if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}	if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}
=~/$priv\&([^\:]*)/) {	=~/\Q$priv\E\&([^\:]*)/) {
$thisallowed.=$1;	$thisallowed.=$1;
}	}

Line 2588 sub allowed {	Line 2862 sub allowed {
$courseuri=~s/^([^\/])/\/$1/;	$courseuri=~s/^([^\/])/\/$1/;

if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri}	if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri}
=~/$priv\&([^\:]*)/) {	=~/\Q$priv\E\&([^\:]*)/) {
$thisallowed.=$1;	$thisallowed.=$1;
}	}

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

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

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

if ($thisallowed=~/F/) {	if ($thisallowed=~/F/) {
Line 2606 sub allowed {	Line 2885 sub allowed {

# If this is generating or modifying users, exit with special codes	# If this is generating or modifying users, exit with special codes

if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:$priv\:/) {	if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:\Q$priv\E\:/) {
return $thisallowed;	return $thisallowed;
}	}
#	#
Line 2627 sub allowed {	Line 2906 sub allowed {
if ($match) {	if ($match) {
$statecond=$cond;	$statecond=$cond;
if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}	if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}
=~/$priv\&([^\:]*)/) {	=~/\Q$priv\E\&([^\:]*)/) {
$thisallowed.=$1;	$thisallowed.=$1;
$checkreferer=0;	$checkreferer=0;
}	}
Line 2655 sub allowed {	Line 2934 sub allowed {
if ($match) {	if ($match) {
my $refstatecond=$cond;	my $refstatecond=$cond;
if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}	if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}
=~/$priv\&([^\:]*)/) {	=~/\Q$priv\E\&([^\:]*)/) {
$thisallowed.=$1;	$thisallowed.=$1;
$uri=$refuri;	$uri=$refuri;
$statecond=$refstatecond;	$statecond=$refstatecond;
Line 2708 sub allowed {	Line 2987 sub allowed {
if ((time-$ENV{$prefix.'last_cache'})>$expiretime) {	if ((time-$ENV{$prefix.'last_cache'})>$expiretime) {
&coursedescription($courseid);	&coursedescription($courseid);
}	}
if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,$csec\,/)	if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,\Q$csec\E\,/)
\|\| ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {	\|\| ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {
if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) {	if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) {
&log($ENV{'user.domain'},$ENV{'user.name'},	&log($ENV{'user.domain'},$ENV{'user.name'},
Line 2719 sub allowed {	Line 2998 sub allowed {
return '';	return '';
}	}
}	}
if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,$csec\,/)	if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/)
\|\| ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {	\|\| ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {
if ($ENV{'priv.'.$priv.'.lock.expire'}>time) {	if ($ENV{'priv.'.$priv.'.lock.expire'}>time) {
&log($ENV{'user.domain'},$ENV{'user.name'},	&log($ENV{'user.domain'},$ENV{'user.name'},
Line 2753 sub allowed {	Line 3032 sub allowed {
my $rolecode=(split(/\./,$ENV{'request.role'}))[0];	my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
my $unamedom=$ENV{'user.name'}.':'.$ENV{'user.domain'};	my $unamedom=$ENV{'user.name'}.':'.$ENV{'user.domain'};
if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'}	if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'}
=~/$rolecode/) {	=~/\Q$rolecode\E/) {
&log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},	&log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.	'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
$ENV{'request.course.id'});	$ENV{'request.course.id'});
Line 2761 sub allowed {	Line 3040 sub allowed {
}	}

if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.users.denied'}	if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.users.denied'}
=~/$unamedom/) {	=~/\Q$unamedom\E/) {
&log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},	&log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.	'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
$ENV{'request.course.id'});	$ENV{'request.course.id'});
Line 2773 sub allowed {	Line 3052 sub allowed {

if ($thisallowed=~/R/) {	if ($thisallowed=~/R/) {
my $rolecode=(split(/\./,$ENV{'request.role'}))[0];	my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
if (&metadata($uri,'roledeny')=~/$rolecode/) {	if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {
&log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},	&log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);	'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
return '';	return '';
Line 2785 sub allowed {	Line 3064 sub allowed {
if ($thisallowed=~/X/) {	if ($thisallowed=~/X/) {
if ($ENV{'acc.randomout'}) {	if ($ENV{'acc.randomout'}) {
my $symb=&symbread($uri,1);	my $symb=&symbread($uri,1);
if (($symb) && ($ENV{'acc.randomout'}=~/\&$symb\&/)) {	if (($symb) && ($ENV{'acc.randomout'}=~/\&\Q$symb\E\&/)) {
return '';	return '';
}	}
}	}
Line 2849 sub definerole {	Line 3128 sub definerole {
my ($rolename,$sysrole,$domrole,$courole)=@_;	my ($rolename,$sysrole,$domrole,$courole)=@_;
foreach (split(':',$sysrole)) {	foreach (split(':',$sysrole)) {
my ($crole,$cqual)=split(/\&/,$_);	my ($crole,$cqual)=split(/\&/,$_);
if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; }	if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; }
if ($pr{'cr:s'}=~/$crole\&/) {	if ($pr{'cr:s'}=~/\Q$crole\E\&/) {
if ($pr{'cr:s'}!~/$crole\&\w*$cqual/) {	if ($pr{'cr:s'}!~/\Q$crole\E\&\w*\Q$cqual\E/) {
return "refused:s:$crole&$cqual";	return "refused:s:$crole&$cqual";
}	}
}	}
}	}
foreach (split(':',$domrole)) {	foreach (split(':',$domrole)) {
my ($crole,$cqual)=split(/\&/,$_);	my ($crole,$cqual)=split(/\&/,$_);
if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; }	if ($pr{'cr:d'}!~/\Q$crole\E/) { return "refused:d:$crole"; }
if ($pr{'cr:d'}=~/$crole\&/) {	if ($pr{'cr:d'}=~/\Q$crole\E\&/) {
if ($pr{'cr:d'}!~/$crole\&\w*$cqual/) {	if ($pr{'cr:d'}!~/\Q$crole\W\&\w*\Q$cqual\E/) {
return "refused:d:$crole&$cqual";	return "refused:d:$crole&$cqual";
}	}
}	}
}	}
foreach (split(':',$courole)) {	foreach (split(':',$courole)) {
my ($crole,$cqual)=split(/\&/,$_);	my ($crole,$cqual)=split(/\&/,$_);
if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; }	if ($pr{'cr:c'}!~/\Q$crole\E/) { return "refused:c:$crole"; }
if ($pr{'cr:c'}=~/$crole\&/) {	if ($pr{'cr:c'}=~/\Q$crole\E\&/) {
if ($pr{'cr:c'}!~/$crole\&\w*$cqual/) {	if ($pr{'cr:c'}!~/\Q$crole\E\&\w*\Q$cqual\E/) {
return "refused:c:$crole&$cqual";	return "refused:c:$crole&$cqual";
}	}
}	}
Line 2916 sub log_query {	Line 3195 sub log_query {
my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys %filters));	my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys %filters));
my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,	my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,
$uhome);	$uhome);
unless ($queryid=~/^$uhost\_/) { return 'error: '.$queryid; }	unless ($queryid=~/^\Q$uhost\E\_/) { return 'error: '.$queryid; }
return get_query_reply($queryid);	return get_query_reply($queryid);
}	}

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

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

sub get_query_reply {	sub get_query_reply {
my $queryid=shift;	my $queryid=shift;
my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid;	my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid;
Line 2964 sub userlog_query {	Line 3312 sub userlog_query {
return &log_query($uname,$udom,'userlog',%filters);	return &log_query($uname,$udom,'userlog',%filters);
}	}

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

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

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

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

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

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

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

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

sub plaintext {	sub plaintext {
Line 3154 sub modifyuser {	Line 3576 sub modifyuser {

sub modifystudent {	sub modifystudent {
my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,	my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
$end,$start,$forceid,$desiredhome,$email,$type,$cid)=@_;	$end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_;
if (!$cid) {	if (!$cid) {
unless ($cid=$ENV{'request.course.id'}) {	unless ($cid=$ENV{'request.course.id'}) {
return 'not_in_class';	return 'not_in_class';
Line 3169 sub modifystudent {	Line 3591 sub modifystudent {
# students environment	# students environment
$uid = undef if (!$forceid);	$uid = undef if (!$forceid);
$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,	$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
$gene,$usec,$end,$start,$type,$cid);	$gene,$usec,$end,$start,$type,$locktype,$cid);
return $reply;	return $reply;
}	}

sub modify_student_enrollment {	sub modify_student_enrollment {
my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,	my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_;
$cid) = @_;
my ($cdom,$cnum,$chome);	my ($cdom,$cnum,$chome);
if (!$cid) {	if (!$cid) {
unless ($cid=$ENV{'request.course.id'}) {	unless ($cid=$ENV{'request.course.id'}) {
Line 3219 sub modify_student_enrollment {	Line 3640 sub modify_student_enrollment {
}	}
my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene,	my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene,
$first,$middle);	$first,$middle);
my $value=&escape($uname.':'.$udom).'='.	my $reply=cput('classlist',
&escape(join(':',$end,$start,$uid,$usec,$fullname,$type));	{"$uname:$udom" =>
my $reply=critical('put:'.$cdom.':'.$cnum.':classlist:'.$value,$chome);	join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },
	$cdom,$cnum);
unless (($reply eq 'ok') \|\| ($reply eq 'delayed')) {	unless (($reply eq 'ok') \|\| ($reply eq 'delayed')) {
return 'error: '.$reply;	return 'error: '.$reply;
}	}
Line 3256 sub writecoursepref {	Line 3678 sub writecoursepref {
# ---------------------------------------------------------- Make/modify course	# ---------------------------------------------------------- Make/modify course

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

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


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

sub dirlist {	sub dirlist {
Line 3677 sub EXT {	Line 4108 sub EXT {

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

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

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

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

my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;	my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
Line 3734 sub EXT {	Line 4168 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;
}	}
Line 3744 sub EXT {	Line 4178 sub EXT {
# -------------------------------------------------------- second, check course	# -------------------------------------------------------- second, check course

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

# ------------------------------------------------------ third, check map parms	# ------------------------------------------------------ third, check map parms
Line 3847 sub metadata {	Line 4281 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\|^uploaded/\|)) {	($uri =~ m\|home/[^/]+/public_html/\|)) {
return undef;	return undef;
}	}
my $filename=$uri;	my $filename=$uri;
Line 3878 sub metadata {	Line 4314 sub metadata {
}	}
my %metathesekeys=();	my %metathesekeys=();
unless ($filename=~/\.meta$/) { $filename.='.meta'; }	unless ($filename=~/\.meta$/) { $filename.='.meta'; }
my $metastring=&getfile(&filelocation('',&clutter($filename)));	my $metastring;
	if ($uri !~ m\|^uploaded/\|) {
	my $file=&filelocation('',&clutter($filename));
	push(@{$metacache{$uri.'.file'}},$file);
	$metastring=&getfile($file);
	}
my $parser=HTML::LCParser->new(\$metastring);	my $parser=HTML::LCParser->new(\$metastring);
my $token;	my $token;
undef %metathesekeys;	undef %metathesekeys;
Line 3989 sub metadata {	Line 4430 sub metadata {
# the next is the end of "start tag"	# the next is the end of "start tag"
}	}
}	}
	my ($extension) = ($uri =~ /\.(\w+)$/);
	foreach my $key (sort(keys(%packagetab))) {
	#&logthis("extsion1 $extension $key !!");
	#no specific packages #how's our extension
	if ($key!~/^extension_\Q$extension\E&/) { next; }
	&metadata_create_package_def($uri,$key,'extension_'.$extension,
	\%metathesekeys);
	}
	if (!exists($metacache{$uri}->{':packages'})) {
	foreach my $key (sort(keys(%packagetab))) {
	#no specific packages well let's get default then
	if ($key!~/^default&/) { next; }
	&metadata_create_package_def($uri,$key,'default',
	\%metathesekeys);
	}
	}
# are there custom rights to evaluate	# are there custom rights to evaluate
if ($metacache{$uri}->{':copyright'} eq 'custom') {	if ($metacache{$uri}->{':copyright'} eq 'custom') {

Line 4017 sub metadata {	Line 4474 sub metadata {
return $metacache{$uri}->{':'.$what};	return $metacache{$uri}->{':'.$what};
}	}

	sub metadata_create_package_def {
	my ($uri,$key,$package,$metathesekeys)=@_;
	my ($pack,$name,$subp)=split(/\&/,$key);
	if ($subp eq 'default') { next; }

	if (defined($metacache{$uri}->{':packages'})) {
	$metacache{$uri}->{':packages'}.=','.$package;
	} else {
	$metacache{$uri}->{':packages'}=$package;
	}
	my $value=$packagetab{$key};
	my $unikey;
	$unikey='parameter_0_'.$name;
	$metacache{$uri}->{':'.$unikey.'.part'}=0;
	$$metathesekeys{$unikey}=1;
	unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) {
	$metacache{$uri}->{':'.$unikey.'.'.$subp}=$value;
	}
	if (defined($metacache{$uri}->{':'.$unikey.'.default'})) {
	$metacache{$uri}->{':'.$unikey}=
	$metacache{$uri}->{':'.$unikey.'.default'};
	}
	}

sub metadata_generate_part0 {	sub metadata_generate_part0 {
my ($metadata,$metacache,$uri) = @_;	my ($metadata,$metacache,$uri) = @_;
my %allnames;	my %allnames;
Line 4040 sub metadata_generate_part0 {	Line 4521 sub metadata_generate_part0 {
my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name.	my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name.
'.display'};	'.display'};
my $expr='\\[Part: '.$allnames{$name}.'\\]';	my $expr='\\[Part: '.$allnames{$name}.'\\]';
$olddis=~s/$expr/\[Part: 0\]/;	$olddis=~s/\Q$expr\E/\[Part: 0\]/;
$$metacache{"$key.display"}=$olddis;	$$metacache{"$key.display"}=$olddis;
}	}
}	}
Line 4050 sub metadata_generate_part0 {	Line 4531 sub metadata_generate_part0 {
sub gettitle {	sub gettitle {
my $urlsymb=shift;	my $urlsymb=shift;
my $symb=&symbread($urlsymb);	my $symb=&symbread($urlsymb);
unless ($symb) {	if ($symb) {
unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; }	my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);
return &metadata($urlsymb,'title');	if (defined($cached)) { return $result; }
}	my ($map,$resid,$url)=&decode_symb($symb);
my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);	my $title='';
if (defined($cached)) { return $result; }	my %bighash;
my ($map,$resid,$url)=&decode_symb($symb);	if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
my $title='';	&GDBM_READER(),0640)) {
my %bighash;	my $mapid=$bighash{'map_pc_'.&clutter($map)};
if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',	$title=$bighash{'title_'.$mapid.'.'.$resid};
&GDBM_READER(),0640)) {	untie %bighash;
my $mapid=$bighash{'map_pc_'.&clutter($map)};	}
$title=$bighash{'title_'.$mapid.'.'.$resid};	$title=~s/\&colon\;/\:/gs;
untie %bighash;	if ($title) {
}	return &do_cache(\%titlecache,$symb,$title,'title');
$title=~s/\&colon\;/\:/gs;	}
if ($title) {	$urlsymb=$url;
return &do_cache(\%titlecache,$symb,$title,'title');	}
} else {	my $title=&metadata($urlsymb,'title');
return &metadata($urlsymb,'title');	if (!$title) { $title=(split('/',$urlsymb))[-1]; }
}	return $title;
}	}

# ------------------------------------------------- Update symbolic store links	# ------------------------------------------------- Update symbolic store links
Line 4096 sub symblist {	Line 4577 sub symblist {
# --------------------------------------------------------------- Verify a symb	# --------------------------------------------------------------- Verify a symb

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

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

my %bighash;	my %bighash;
Line 4113 sub symbverify {	Line 4598 sub symbverify {

if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',	if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
&GDBM_READER(),0640)) {	&GDBM_READER(),0640)) {
my $ids=$bighash{'ids_'.&clutter($thisfn)};	my $ids=$bighash{'ids_'.&clutter($thisurl)};
unless ($ids) {	unless ($ids) {
$ids=$bighash{'ids_/'.$thisfn};	$ids=$bighash{'ids_/'.$thisurl};
}	}
if ($ids) {	if ($ids) {
# ------------------------------------------------------------------- Has ID(s)	# ------------------------------------------------------------------- Has ID(s)
Line 4144 sub symbclean {	Line 4629 sub symbclean {
# remove version from URL	# remove version from URL
$symb=~s/\.(\d+)\.(\w+)$/\.$2/;	$symb=~s/\.(\d+)\.(\w+)$/\.$2/;

	# remove wrapper

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

Line 4195 sub deversion {	Line 4683 sub deversion {

sub symbread {	sub symbread {
my ($thisfn,$donotrecurse)=@_;	my ($thisfn,$donotrecurse)=@_;
	my $cache_str='request.symbread.cached.'.$thisfn;
	if (defined($ENV{$cache_str})) { return $ENV{$cache_str}; }
# no filename provided? try from environment	# no filename provided? try from environment
unless ($thisfn) {	unless ($thisfn) {
if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); }	if ($ENV{'request.symb'}) {
	return $ENV{$cache_str}=&symbclean($ENV{'request.symb'});
	}
$thisfn=$ENV{'request.filename'};	$thisfn=$ENV{'request.filename'};
}	}
# is that filename actually a symb? Verify, clean, and return	# is that filename actually a symb? Verify, clean, and return
if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {	if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {
if (&symbverify($thisfn,$1)) { return &symbclean($thisfn); }	if (&symbverify($thisfn,$1)) {
	return $ENV{$cache_str}=&symbclean($thisfn);
	}
}	}
$thisfn=declutter($thisfn);	$thisfn=declutter($thisfn);
my %hash;	my %hash;
my %bighash;	my %bighash;
my $syval='';	my $syval='';
if (($ENV{'request.course.fn'}) && ($thisfn)) {	if (($ENV{'request.course.fn'}) && ($thisfn)) {
	my $targetfn = $thisfn;
	if ( ($thisfn =~ m/^uploaded\//) && ($thisfn !~ m/\.(page\|sequence)$/) ) {
	$targetfn = 'adm/wrapper/'.$thisfn;
	}
if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',	if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
&GDBM_READER(),0640)) {	&GDBM_READER(),0640)) {
$syval=$hash{$thisfn};	$syval=$hash{$targetfn};
untie(%hash);	untie(%hash);
}	}
# ---------------------------------------------------------- There was an entry	# ---------------------------------------------------------- There was an entry
Line 4219 sub symbread {	Line 4717 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 4263 sub symbread {	Line 4761 sub symbread {
}	}
}	}
untie(%bighash)	untie(%bighash)
}	}
}	}
if ($syval) {	if ($syval) {
return &symbclean($syval.'___'.$thisfn);	return $ENV{$cache_str}=&symbclean($syval.'___'.$thisfn);
}	}
}	}
&appenv('request.ambiguous' => $thisfn);	&appenv('request.ambiguous' => $thisfn);
return '';	return $ENV{$cache_str}='';
}	}

# ---------------------------------------------------------- Return random seed	# ---------------------------------------------------------- Return random seed
Line 4287 sub numval {	Line 4785 sub numval {
return int($txt);	return int($txt);
}	}

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

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

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

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

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

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

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

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

sub rndseed_CODE_64bit {	sub rndseed_CODE_64bit {
my ($symb,$courseid,$domain,$username)=@_;	my ($symb,$courseid,$domain,$username)=@_;
{	{
use integer;	use integer;
my $symbchck=unpack("%32S*",$symb.' ') << 16;	my $symbchck=unpack("%32S*",$symb.' ') << 16;
my $symbseed=numval($symb);	my $symbseed=numval2($symb);
my $CODEseed=numval($ENV{'scantron.CODE'}) << 16;	my $CODEchck=unpack("%32S*",&getCODE().' ') << 16;
	my $CODEseed=numval(&getCODE());
my $courseseed=unpack("%32S*",$courseid.' ');	my $courseseed=unpack("%32S*",$courseid.' ');
my $num1=$symbseed+$CODEseed;	my $num1=$symbseed+$CODEchck;
my $num2=$courseseed+$symbchck;	my $num2=$CODEseed+$courseseed+$symbchck;
#&Apache::lonxml::debug("$symbseed:$CODEseed\|$courseseed:$symbchck");	#&Apache::lonxml::debug("$symbseed:$CODEchck\|$CODEseed:$courseseed:$symbchck");
#&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");	#&Apache::lonxml::debug("rndseed :$num1:$num2:$symb");
return "$num1,$num2";	return "$num1:$num2";
}	}
}	}

sub setup_random_from_rndseed {	sub setup_random_from_rndseed {
my ($rndseed)=@_;	my ($rndseed)=@_;
if ($rndseed =~/,/) {	if ($rndseed =~/([,:])/) {
my ($num1,$num2)=split(/,/,$rndseed);	my ($num1,$num2)=split(/[,:]/,$rndseed);
&Math::Random::random_set_seed(abs($num1),abs($num2));	&Math::Random::random_set_seed(abs($num1),abs($num2));
} else {	} else {
&Math::Random::random_set_seed_from_phrase($rndseed);	&Math::Random::random_set_seed_from_phrase($rndseed);
}	}
}	}

	sub latest_receipt_algorithm_id {
	return 'receipt2';
	}

	sub recunique {
	my $fucourseid=shift;
	my $unique;
	if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2') {
	$unique=$ENV{"course.$fucourseid.internal.encseed"};
	} else {
	$unique=$perlvar{'lonReceipt'};
	}
	return unpack("%32C*",$unique);
	}

	sub recprefix {
	my $fucourseid=shift;
	my $prefix;
	if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2') {
	$prefix=$ENV{"course.$fucourseid.internal.encpref"};
	} else {
	$prefix=$perlvar{'lonHostID'};
	}
	return unpack("%32C*",$prefix);
	}

sub ireceipt {	sub ireceipt {
my ($funame,$fudom,$fucourseid,$fusymb)=@_;	my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_;
my $cuname=unpack("%32C*",$funame);	my $cuname=unpack("%32C*",$funame);
my $cudom=unpack("%32C*",$fudom);	my $cudom=unpack("%32C*",$fudom);
my $cucourseid=unpack("%32C*",$fucourseid);	my $cucourseid=unpack("%32C*",$fucourseid);
my $cusymb=unpack("%32C*",$fusymb);	my $cusymb=unpack("%32C*",$fusymb);
my $cunique=unpack("%32C*",$perlvar{'lonReceipt'});	my $cunique=&recunique($fucourseid);
return unpack("%32C*",$perlvar{'lonHostID'}).'-'.	my $cpart=unpack("%32S*",$part);
($cunique%$cuname+	my $return =&recprefix($fucourseid).'-';
$cunique%$cudom+	if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2' \|\|
$cusymb%$cuname+	$ENV{'request.state'} eq 'construct') {
$cusymb%$cudom+	&Apache::lonxml::debug("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname).
$cucourseid%$cuname+	" and ".($cpart%$cudom));
$cucourseid%$cudom);
	$return.= ($cunique%$cuname+
	$cunique%$cudom+
	$cusymb%$cuname+
	$cusymb%$cudom+
	$cucourseid%$cuname+
	$cucourseid%$cudom+
	$cpart%$cuname+
	$cpart%$cudom);
	} else {
	$return.= ($cunique%$cuname+
	$cunique%$cudom+
	$cusymb%$cuname+
	$cusymb%$cudom+
	$cucourseid%$cuname+
	$cucourseid%$cudom);
	}
	return $return;
}	}

sub receipt {	sub receipt {
my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser();	my ($part)=@_;
return &ireceipt($name,$domain,$courseid,$symb);	my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser();
	return &ireceipt($name,$domain,$courseid,$symb,$part);
}	}

# ------------------------------------------------------------ Serves up a file	# ------------------------------------------------------------ Serves up a file
# returns either the contents of the file or	# returns either the contents of the file or
# -1 if the file doesn't exist	# -1 if the file doesn't exist
# -2 if an error occured when trying to aqcuire the file	#
	# if the target is a file that was uploaded via DOCS,
	# a check will be made to see if a current copy exists on the local server,
	# if it does this will be served, otherwise a copy will be retrieved from
	# the home server for the course and stored in /home/httpd/html/userfiles on
	# the local server.

sub getfile {	sub getfile {
my $file=shift;	my ($file) = @_;
if ($file=~/^\/*uploaded\//) { # user file
my $ua=new LWP::UserAgent;	if ($file =~ m\|^/*uploaded/\|) { $file=&filelocation("",$file); }
my $request=new HTTP::Request('GET',&tokenwrapper($file));	&repcopy($file);
my $response=$ua->request($request);	return &readfile($file);
if ($response->is_success()) {	}
return $response->content;
} else {	sub repcopy_userfile {
#&logthis("Return Code is ".$response->code." for $file ".	my ($file)=@_;
# &tokenwrapper($file));
# 500 for ISE when tokenwrapper can't figure out what server to	if ($file =~ m\|^/*uploaded/\|) { $file=&filelocation("",$file); }
# contact	if ($file =~ m\|^/home/httpd/html/lonUsers/\|) { return OK; }
# 503 when lonuploadacc can't contact the requested server
if ($response->code eq 503 \|\| $response->code eq 500) {	my ($cdom,$cnum,$filename) =
return -2;	($file=~m\|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)\|);
	my ($info,$rtncode);
	my $uri="/uploaded/$cdom/$cnum/$filename";
	if (-e "$file") {
	my @fileinfo = stat($file);
	my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode);
	if ($lwpresp ne 'ok') {
	if ($rtncode eq '404') {
	unlink($file);
	}
	#my $ua=new LWP::UserAgent;
	#my $request=new HTTP::Request('GET',&tokenwrapper($uri));
	#my $response=$ua->request($request);
	#if ($response->is_success()) {
	# return $response->content;
	# } else {
	# return -1;
	# }
	return -1;
	}
	if ($info < $fileinfo[9]) {
	return OK;
	}
	$info = '';
	$lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);
	if ($lwpresp ne 'ok') {
	return -1;
	}
	} else {
	my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);
	if ($lwpresp ne 'ok') {
	my $ua=new LWP::UserAgent;
	my $request=new HTTP::Request('GET',&tokenwrapper($uri));
	my $response=$ua->request($request);
	if ($response->is_success()) {
	$info=$response->content;
} else {	} else {
return -1;	return -1;
}	}
}	}
} else { # normal file from res space	my @parts = ($cdom,$cnum);
&repcopy($file);	if ($filename =~ m\|^(.+)/[^/]+$\|) {
if (! -e $file ) { return -1; };	push @parts, split(/\//,$1);
my $fh;	}
open($fh,"<$file");	my $path = $perlvar{'lonDocRoot'}.'/userfiles';
my $a='';	foreach my $part (@parts) {
while (<$fh>) { $a .=$_; }	$path .= '/'.$part;
return $a;	if (!-e $path) {
	mkdir($path,0770);
	}
	}
}	}
	open(FILE,">$file");
	print FILE $info;
	close(FILE);
	return OK;
	}

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

	sub getuploaded {
	my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
	$uri=~s/^\///;
	$uri = 'http://'.$hostname{ &homeserver($cnum,$cdom)}.'/raw/'.$uri;
	my $ua=new LWP::UserAgent;
	my $request=new HTTP::Request($reqtype,$uri);
	my $response=$ua->request($request);
	$$rtncode = $response->code;
	if (! $response->is_success()) {
	return 'failed';
	}
	if ($reqtype eq 'HEAD') {
	$$info = &HTTP::Date::str2time( $response->header('Last-modified') );
	} elsif ($reqtype eq 'GET') {
	$$info = $response->content;
	}
	return 'ok';
	}

	sub readfile {
	my $file = shift;
	if ( (! -e $file ) \|\| ($file eq '') ) { return -1; };
	my $fh;
	open($fh,"<$file");
	my $a='';
	while (<$fh>) { $a .=$_; }
	return $a;
}	}

sub filelocation {	sub filelocation {
Line 4463 sub filelocation {	Line 5154 sub filelocation {
$location = $file;	$location = $file;
$location =~ s:/~(.?)/(.):/home/$1/public_html/$2:;	$location =~ s:/~(.?)/(.):/home/$1/public_html/$2:;
} elsif ($file=~/^\/*uploaded/) { # is an uploaded file	} elsif ($file=~/^\/*uploaded/) { # is an uploaded file
$location=$file;	my ($udom,$uname,$filename)=
	($file=~m\|^/+uploaded/+([^/]+)/+([^/]+)/+(.*)$\|);
	my $home=&homeserver($uname,$udom);
	my $is_me=0;
	my @ids=&current_machine_ids();
	foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
	if ($is_me) {
	$location=&Apache::loncommon::propath($udom,$uname).
	'/userfiles/'.$filename;
	} else {
	$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
	$udom.'/'.$uname.'/'.$filename;
	}
} else {	} else {
$file=~s/^$perlvar{'lonDocRoot'}//;	$file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
$file=~s:^/res/:/:;	$file=~s:^/res/:/:;
if ( !( $file =~ m:^/:) ) {	if ( !( $file =~ m:^/:) ) {
$location = $dir. '/'.$file;	$location = $dir. '/'.$file;
Line 4475 sub filelocation {	Line 5178 sub filelocation {
}	}
$location=~s://+:/:g; # remove duplicate /	$location=~s://+:/:g; # remove duplicate /
while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..	while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
	while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./
return $location;	return $location;
}	}

Line 4521 sub current_machine_ids {	Line 5225 sub current_machine_ids {

sub declutter {	sub declutter {
my $thisfn=shift;	my $thisfn=shift;
$thisfn=~s/^$perlvar{'lonDocRoot'}//;	$thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;
$thisfn=~s/^\///;	$thisfn=~s/^\///;
$thisfn=~s/^res\///;	$thisfn=~s/^res\///;
$thisfn=~s/\?.+$//;	$thisfn=~s/\?.+$//;
Line 4532 sub declutter {	Line 5236 sub declutter {

sub clutter {	sub clutter {
my $thisfn='/'.&declutter(shift);	my $thisfn='/'.&declutter(shift);
unless ($thisfn=~/^\/(uploaded\|adm\|userfiles\|ext\|raw\|priv)\//) {	unless ($thisfn=~/^\/(uploaded\|adm\|userfiles\|ext\|raw\|priv\|public)\//) {
$thisfn='/res'.$thisfn;	$thisfn='/res'.$thisfn;
}	}
return $thisfn;	return $thisfn;
Line 4594 BEGIN {	Line 5298 BEGIN {
open(my $config,"</etc/httpd/conf/loncapa.conf");	open(my $config,"</etc/httpd/conf/loncapa.conf");

while (my $configline=<$config>) {	while (my $configline=<$config>) {
if ($configline =~ /^[^\#]*PerlSetVar/) {	if ($configline=~/\S/ && $configline =~ /^[^\#]*PerlSetVar/) {
my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);	my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
chomp($varvalue);	chomp($varvalue);
$perlvar{$varname}=$varvalue;	$perlvar{$varname}=$varvalue;
Line 4658 BEGIN {	Line 5362 BEGIN {
$hostip{$id}=$ip;	$hostip{$id}=$ip;
$iphost{$ip}=$id;	$iphost{$ip}=$id;
if ($role eq 'library') { $libserv{$id}=$name; }	if ($role eq 'library') { $libserv{$id}=$name; }
} else {
if ($configline) {
&logthis("Skipping hosts.tab line -$configline-");
}
}	}
}	}
close($config);	close($config);
Line 4712 BEGIN {	Line 5412 BEGIN {
open(my $config,"<$perlvar{'lonTabDir'}/packages.tab");	open(my $config,"<$perlvar{'lonTabDir'}/packages.tab");

while (my $configline=<$config>) {	while (my $configline=<$config>) {
	if ($configline !~ /\S/ \|\| $configline=~/^#/) { next; }
chomp($configline);	chomp($configline);
my ($short,$plain)=split(/:/,$configline);	my ($short,$plain)=split(/:/,$configline);
my ($pack,$name)=split(/\&/,$short);	my ($pack,$name)=split(/\&/,$short);
Line 5352 put($namespace,$storehash,$udom,$uname)	Line 6053 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)

Line 5457 messages of critical importance should g	Line 6169 messages of critical importance should g

=item *	=item *

getfile($file) : returns the entire contents of a file or -1; it	getfile($file,$caller) : two cases - requests for files in /res or in /uploaded.
properly subscribes to and replicates the file if neccessary.	(a) files in /uploaded
	(i) If a local copy of the file exists -
	compares modification date of local copy with last-modified date for
	definitive version stored on home server for course. If local copy is
	stale, requests a new version from the home server and stores it.
	If the original has been removed from the home server, then local copy
	is unlinked.
	(ii) If local copy does not exist -
	requests the file from the home server and stores it.

	If $caller is 'uploadrep':
	This indicates a call from lonuploadrep.pm (PerlHeaderParserHandler phase)
	for request for files originally uploaded via DOCS.
	- returns 'ok' if fresh local copy now available, -1 otherwise.

	Otherwise:
	This indicates a call from the content generation phase of the request.
	- returns the entire contents of the file or -1.

	(b) files in /res
	- returns the entire contents of a file or -1;
	it properly subscribes to and replicates the file if neccessary.

=item *	=item *

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

Removed from v.1.473
changed lines
	Added in v.1.549