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.488 and 1.559

version 1.488, 2004/04/23 19:36:46	version 1.559, 2004/11/03 00:11:42
Line 38 use vars	Line 38 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 %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);

use IO::Socket;	use IO::Socket;
Line 47 use GDBM_File;	Line 47 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 642 sub assign_access_key {	Line 668 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}=~/^\Q$uname\E\:\Q$udom\E\#(.*)$/)) {	($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#(.*)$/)) {
# assigned to this person	# assigned to this person
Line 658 sub assign_access_key {	Line 688 sub assign_access_key {
# 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 755 sub validate_access_key {	Line 785 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}=~/^\Q$uname\E\:\Q$udom\E\#/);	return ($existing{$ckey}=~/^\Q$uname\E\:\Q$udom\E\#/);
}	}
Line 767 sub getsection {	Line 797 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 791 sub getsection {	Line 826 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 822 my $disk_caching_disabled=1;	Line 857 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 852 sub is_cached {	Line 889 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 877 sub do_cache {	Line 930 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 931 sub load_cache_item {	Line 1009 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 953 EVALBLOCK	Line 1039 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 1043 sub currentversion {	Line 1097 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 1062 sub subscribe {	Line 1117 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 1127 sub ssi_body {	Line 1188 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 1165 sub externalssi {	Line 1226 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);
if ($uri=~m\|^uploaded/([^/]+)/([^/]+)/(.+)(\?\.)$\|) {	$httpref{'httpref.'.$httpurl}=$srcurl;
&appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});	&Apache::lonnet::appenv(%httpref);
return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.
(($uri=~/\?/)?'&':'?').'token='.$token.
'&tokenissued='.$perlvar{'lonHostID'};
} else {
return '/adm/notfound.html';
}
}	}

# --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course	# --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
Line 1269 sub process_coursefile {	Line 1324 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)=@_;	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 1280 sub userfileupload {	Line 1334 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'};
Line 1309 sub finishuserfileupload {	Line 1391 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 1319 sub finishuserfileupload {	Line 1407 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:'.$docudom.'/'.$docuname.'/'.$fname,	my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
$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 1377 sub flushcourselogs {	Line 1490 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 1454 sub courselog {	Line 1569 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 1578 sub getannounce {	Line 1695 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 1597 sub courseidput {	Line 1714 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 1620 sub courseiddump {	Line 1738 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 1732 sub devalidate {	Line 1872 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 1746 sub devalidate {	Line 1887 sub devalidate {
$uname.' at '.$udom.' for '.	$uname.' at '.$udom.' for '.
$symb.': '.$status);	$symb.': '.$status);
}	}
	&delenv('user.state.'.$cid);
}	}
}	}

Line 1798 sub hash2str {	Line 1940 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 2327 sub rolesinit {	Line 2469 sub rolesinit {
my $author=0;	my $author=0;
foreach (keys %allroles) {	foreach (keys %allroles) {
%thesepriv=();	%thesepriv=();
if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; }
if (($_=~/^au/) \|\| ($_=~/^ca/)) { $author=1; }	if (($_=~/^au/) \|\| ($_=~/^ca/)) { $author=1; }
foreach (split(/:/,$allroles{$_})) {	foreach (split(/:/,$allroles{$_})) {
if ($_ ne '') {	if ($_ ne '') {
Line 2339 sub rolesinit {	Line 2480 sub rolesinit {
$thesepriv{$privilege}.=$restrictions;	$thesepriv{$privilege}.=$restrictions;
}	}
}	}
	if ($thesepriv{'adv'} eq 'F') { $adv=1; }
}	}
}	}
$thesestr='';	$thesestr='';
Line 2373 sub get {	Line 2515 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 2412 sub dump {	Line 2554 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 2458 sub currentdump {	Line 2600 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 2524 sub put {	Line 2666 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.=$_.'='.&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 2539 sub cput {	Line 2705 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 2562 sub eget {	Line 2728 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 2609 sub allowed {	Line 2775 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 2682 sub allowed {	Line 2857 sub allowed {

# 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 3008 sub log_query {	Line 3188 sub log_query {
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 3052 sub userlog_query {	Line 3301 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 3242 sub modifyuser {	Line 3565 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 3257 sub modifystudent {	Line 3580 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 3305 sub modify_student_enrollment {	Line 3627 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) },	join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },
$cdom,$cnum);	$cdom,$cnum);
unless (($reply eq 'ok') \|\| ($reply eq 'delayed')) {	unless (($reply eq 'ok') \|\| ($reply eq 'delayed')) {
return 'error: '.$reply;	return 'error: '.$reply;
Line 3323 sub modify_student_enrollment {	Line 3644 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 3345 sub writecoursepref {	Line 3685 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 3378 sub createcourse {	Line 3718 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 3433 sub revokecustomrole {	Line 3773 sub revokecustomrole {
$deleteflag);	$deleteflag);
}	}

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

	# ------------------------------------------------------------- Mark as Read Only

	sub mark_as_readonly {
	my ($domain,$user,$files,$what) = @_;
	my %current_permissions = &Apache::lonnet::dump('file_permissions',$domain,$user);
	foreach my $file ($files) {
	$current_permissions{$file}.=':'.$what.':';
	}
	&Apache::lonnet::put('file_permissions',{ 'locked_files' => %current_permissions },$domain,$user);
	return;
	}

	# ------------------------------------------------------------ Unmark as Read Only

	sub unmark_as_readonly {
	my ($domain,$user,$file,$what) = @_;
	my $current_permissions = &Apache::lonnet::get('file_permissions',$file,$domain,$user);
	$current_permissions =~ s/:$file://;
	&Apache::lonnet::put('file_permissions',{ $file => $current_permissions },$domain,$user);
	return;
	}

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

sub dirlist {	sub dirlist {
Line 3541 sub GetFileTimestamp {	Line 3911 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 3766 sub EXT {	Line 4139 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 3781 sub EXT {	Line 4157 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;
Line 3823 sub EXT {	Line 4199 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 3833 sub EXT {	Line 4209 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 3936 sub metadata {	Line 4312 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 3967 sub metadata {	Line 4345 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 4179 sub metadata_generate_part0 {	Line 4562 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 4225 sub symblist {	Line 4608 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 4235 sub symbverify {	Line 4621 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 4242 sub symbverify {	Line 4629 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 4273 sub symbclean {	Line 4660 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 4324 sub deversion {	Line 4714 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;
Line 4352 sub symbread {	Line 4748 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 4399 sub symbread {	Line 4795 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 4436 sub numval2 {	Line 4832 sub numval2 {
}	}

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 4449 sub rndseed {	Line 4863 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{'form.CODE'};	if (defined(&getCODE())) {
if (defined($CODE)) {
return &rndseed_CODE_64bit($symb,$courseid,$domain,$username);	return &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 4520 sub rndseed_64bit2 {	Line 4935 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=numval2($symb);	my $symbseed=numval2($symb);
my $CODEchck=unpack("%32S*",$ENV{'form.CODE'}.' ') << 16;	my $CODEchck=unpack("%32S*",&getCODE().' ') << 16;
my $CODEseed=numval($ENV{'form.CODE'});	my $CODEseed=numval(&getCODE());
my $courseseed=unpack("%32S*",$courseid.' ');	my $courseseed=unpack("%32S*",$courseid.' ');
my $num1=$symbseed+$CODEchck;	my $num1=$symbseed+$CODEchck;
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");
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);
Line 4623 sub receipt {	Line 5060 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 $request=new HTTP::Request('GET',&tokenwrapper($uri));
	#my $response=$ua->request($request);
	#if ($response->is_success()) {
	# return $response->content;
	# } else {
	# return -1;
	# }
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') {
return -1;	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 {
	return -1;
	}
}	}
my @parts = ($cdom,$cnum);	my @parts = ($cdom,$cnum);
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 4671 sub getfile {	Line 5126 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';	}

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

sub getuploaded {	sub getuploaded {
Line 4717 sub filelocation {	Line 5187 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/^\Q$perlvar{'lonDocRoot'}\E//;	$file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
$file=~s:^/res/:/:;	$file=~s:^/res/:/:;
Line 4787 sub declutter {	Line 5269 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;
}	}

	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 4809 sub unescape {	Line 5300 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 {
if (defined($perlvar{'MODPERL2'})) {	if (defined($perlvar{'MODPERL2'})) {
return 2;	return 2;
Line 4834 sub goodbye {	Line 5335 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 4913 BEGIN {	Line 5414 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 5220 X<rolesinit()>	Line 5717 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 5608 put($namespace,$storehash,$udom,$uname)	Line 6105 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.488
changed lines
	Added in v.1.559