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.467 and 1.522

version 1.467, 2004/01/30 14:42:00	version 1.522, 2004/07/16 17:56:01
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 377 sub delenv {	Line 379 sub delenv {
return 'error: '.$!;	return 'error: '.$!;
}	}
foreach (@oldenv) {	foreach (@oldenv) {
unless ($_=~/^$delthis/) { print $fh $_; }	if ($_=~/^$delthis/) {
	my ($key,undef) = split('=',$_);
	delete($ENV{$key});
	} else {
	print $fh $_;
	}
}	}
close($fh);	close($fh);
}	}
Line 427 sub overloaderror {	Line 434 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 524 sub authenticate {	Line 531 sub authenticate {
my ($uname,$upass,$udom)=@_;	my ($uname,$upass,$udom)=@_;
$upass=escape($upass);	$upass=escape($upass);
$uname=~s/\W//g;	$uname=~s/\W//g;
if (($perlvar{'lonRole'} eq 'library') &&	my $uhome=&homeserver($uname,$udom);
($udom eq $perlvar{'lonDefDomain'})) {	if (!$uhome) {
my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'});	&logthis("User $uname at $udom is unknown in authenticate");
if ($answer =~ /authorized/) {	return 'no_host';
if ($answer eq 'authorized') {
&logthis("User $uname at $udom authorized by local server");
return $perlvar{'lonHostID'};
}
if ($answer eq 'non_authorized') {
&logthis("User $uname at $udom rejected by local server");
return 'no_host';
}
}
}	}
	my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome);
my $tryserver;	if ($answer eq 'authorized') {
foreach $tryserver (keys %libserv) {	&logthis("User $uname at $udom authorized by $uhome");
if ($hostdom{$tryserver} eq $udom) {	return $uhome;
my $answer=reply("encrypt:auth:$udom:$uname:$upass",$tryserver);	}
if ($answer =~ /authorized/) {	if ($answer eq 'non_authorized') {
if ($answer eq 'authorized') {	&logthis("User $uname at $udom rejected by $uhome");
&logthis("User $uname at $udom authorized by $tryserver");	return 'no_host';
return $tryserver;
}
if ($answer eq 'non_authorized') {
&logthis("User $uname at $udom rejected by $tryserver");
return 'no_host';
}
}
}
}	}
&logthis("User $uname at $udom could not be authenticated");	&logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
return 'no_host';	return 'no_host';
}	}

Line 627 sub idput {	Line 617 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 637 sub idput {	Line 628 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 652 sub assign_access_key {	Line 642 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 765 sub validate_access_key {	Line 759 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 796 sub getsection {	Line 790 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));
Line 975 sub usection {	Line 969 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 1175 sub externalssi {	Line 1169 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 userfileupload {
my ($formname,$coursedoc)=@_;	my ($formname,$coursedoc,$subdir)=@_;
	if (!defined($subdir)) { $subdir='unknown'; }
my $fname=$ENV{'form.'.$formname.'.filename'};	my $fname=$ENV{'form.'.$formname.'.filename'};
# Replace Windows backslashes by forward slashes	# Replace Windows backslashes by forward slashes
$fname=~s/\\/\//g;	$fname=~s/\\/\//g;
Line 1215 sub userfileupload {	Line 1286 sub userfileupload {
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 1242 sub finishuserfileupload {	Line 1325 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);
	}

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

sub log {	sub log {
Line 1301 sub flushcourselogs {	Line 1395 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 1378 sub courselog {	Line 1474 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 1424 sub userrolelog {	Line 1522 sub userrolelog {
my ($trole,$username,$domain,$area,$tstart,$tend)=@_;	my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
if (($trole=~/^ca/) \|\| ($trole=~/^in/) \|\|	if (($trole=~/^ca/) \|\| ($trole=~/^in/) \|\|
($trole=~/^cc/) \|\| ($trole=~/^ep/) \|\|	($trole=~/^cc/) \|\| ($trole=~/^ep/) \|\|
($trole=~/^cr/)) {	($trole=~/^cr/) \|\| ($trole=~/^ta/)) {
my (undef,$rudom,$runame,$rsec)=split(/\//,$area);	my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
$userrolehash	$userrolehash
{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}	{$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
Line 1436 sub get_course_adv_roles {	Line 1534 sub get_course_adv_roles {
my $cid=shift;	my $cid=shift;
$cid=$ENV{'request.course.id'} unless (defined($cid));	$cid=$ENV{'request.course.id'} unless (defined($cid));
my %coursehash=&coursedescription($cid);	my %coursehash=&coursedescription($cid);
	my %nothide=();
	foreach (split(/\s\,\s/,$coursehash{'nothideprivileged'})) {
	$nothide{join(':',split(/[\@\:]/,$_))}=1;
	}
my %returnhash=();	my %returnhash=();
my %dumphash=	my %dumphash=
&dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});	&dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
Line 1446 sub get_course_adv_roles {	Line 1548 sub get_course_adv_roles {
if (($tend) && ($tend<$now)) { next; }	if (($tend) && ($tend<$now)) { next; }
if (($tstart) && ($now<$tstart)) { next; }	if (($tstart) && ($now<$tstart)) { next; }
my ($role,$username,$domain,$section)=split(/\:/,$_);	my ($role,$username,$domain,$section)=split(/\:/,$_);
if (&privileged($username,$domain)) { next; }	if ((&privileged($username,$domain)) &&
	(!$nothide{$username.':'.$domain})) { next; }
my $key=&plaintext($role);	my $key=&plaintext($role);
if ($section) { $key.=' (Sec/Grp '.$section.')'; }	if ($section) { $key.=' (Sec/Grp '.$section.')'; }
if ($returnhash{$key}) {	if ($returnhash{$key}) {
Line 1497 sub getannounce {	Line 1600 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 1516 sub courseidput {	Line 1619 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 1539 sub courseiddump {	Line 1643 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 1717 sub hash2str {	Line 1843 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 2578 sub allowed {	Line 2704 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 2595 sub allowed {	Line 2721 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 2613 sub allowed {	Line 2744 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 2634 sub allowed {	Line 2765 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 2662 sub allowed {	Line 2793 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 2715 sub allowed {	Line 2846 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 2726 sub allowed {	Line 2857 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 2760 sub allowed {	Line 2891 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 2768 sub allowed {	Line 2899 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 2780 sub allowed {	Line 2911 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 2792 sub allowed {	Line 2923 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 2856 sub definerole {	Line 2987 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 2923 sub log_query {	Line 3054 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;
	if ($context eq 'automated') {
	$homeserver = $perlvar{'lonHostID'};
	} 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\_/) { return 'error: '.$queryid; }
	my $reply = &get_query_reply($queryid);
	unless ( ($reply =~/^timeout/) \|\| ($reply =~/^error/) ) {
	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);
	unless ($xml_classlist =~ /^error/) {
	if ( open(FILE,">$destname") ) {
	print FILE &unescape($xml_classlist);
	close(FILE);
	}
	}
	}
	}
	}
	}
	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 2971 sub userlog_query {	Line 3155 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 3161 sub modifyuser {	Line 3419 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 3176 sub modifystudent {	Line 3434 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 3226 sub modify_student_enrollment {	Line 3483 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 3263 sub writecoursepref {	Line 3521 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 3296 sub createcourse {	Line 3554 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 3351 sub revokecustomrole {	Line 3609 sub revokecustomrole {
$deleteflag);	$deleteflag);
}	}


	# ------------------------------------------------------------ Portfolio Director Lister
	# returns listing of contents of user's /userfiles/portfolio/ directory
	#

	sub portfoliolist {
	my ($currentPath, $currentFile) = @_;
	my ($udom, $uname, $portfolioRoot);
	$uname=$ENV{'user.name'};
	$udom=$ENV{'user.domain'};
	# really should interrogate the system for home directory information, but . . .
	$portfolioRoot = '/home/httpd/lonUsers/'.$udom.'/';
	$uname =~ /^(.?)(.?)(.?)/;
	$portfolioRoot = $portfolioRoot.$1.'/'.$2.'/'.$3.'/'.$uname.'/userfiles/portfolio';
	my $listing = &reply('ls:'.$portfolioRoot.$currentPath, &homeserver($uname,$udom));
	return $listing;
	}

	sub portfoliomanage {

	#FIXME please user the existing remove userfile function instead and
	#add a userfilerename functions.
	#FIXME uhome should never be an argument to any lonnet functions

	# handles deleting and renaming files in user's userfiles/portfolio/ directory
	#
	my ($filename, $fileaction, $filenewname) = @_;
	my ($udom, $uname, $uhome);
	$uname=$ENV{'user.name'};
	$udom=$ENV{'user.domain'};
	$uhome=$ENV{'user.home'};
	my $listing = reply('portfoliomanage:'.$uname.':'.$udom.':'.$filename.':'.$fileaction.':'.$filenewname, $uhome);
	return $listing;
	}


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

sub dirlist {	sub dirlist {
Line 3822 sub packages_tab_default {	Line 4116 sub packages_tab_default {
my $packages=&metadata($uri,'packages');	my $packages=&metadata($uri,'packages');
foreach my $package (split(/,/,$packages)) {	foreach my $package (split(/,/,$packages)) {
my ($pack_type,$pack_part)=split(/_/,$package,2);	my ($pack_type,$pack_part)=split(/_/,$package,2);
if ($pack_part eq $part) {	if (defined($packagetab{"$pack_type&$name&default"})) {
if (defined($packagetab{"$pack_type&$name&default"})) {	return $packagetab{"$pack_type&$name&default"};
return $packagetab{"$pack_type&$name&default"};	}
}	if (defined($packagetab{$pack_type."_".$pack_part."&$name&default"})) {
	return $packagetab{$pack_type."_".$pack_part."&$name&default"};
}	}
}	}
return undef;	return undef;
Line 3856 sub metadata {	Line 4151 sub metadata {
if (($uri eq '') \|\| (($uri =~ m\|^/*adm/\|) && ($uri !~ m\|^adm/includes\|)) \|\|	if (($uri eq '') \|\| (($uri =~ m\|^/*adm/\|) && ($uri !~ m\|^adm/includes\|)) \|\|
($uri =~ m\|/$\|) \|\| ($uri =~ m\|/.meta$\|) \|\| ($uri =~ /^~/) \|\|	($uri =~ m\|/$\|) \|\| ($uri =~ m\|/.meta$\|) \|\| ($uri =~ /^~/) \|\|
($uri =~ m\|home/[^/]+/public_html/\|)) {	($uri =~ m\|home/[^/]+/public_html/\|)) {
return '';	return undef;
}	}
my $filename=$uri;	my $filename=$uri;
$uri=~s/\.meta$//;	$uri=~s/\.meta$//;
Line 3884 sub metadata {	Line 4179 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/\|) {
	$metastring=&getfile(&filelocation('',&clutter($filename)));
	}
my $parser=HTML::LCParser->new(\$metastring);	my $parser=HTML::LCParser->new(\$metastring);
my $token;	my $token;
undef %metathesekeys;	undef %metathesekeys;
Line 3995 sub metadata {	Line 4293 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 4023 sub metadata {	Line 4337 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 4046 sub metadata_generate_part0 {	Line 4384 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 4102 sub symblist {	Line 4440 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 4112 sub symbverify {	Line 4453 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 4119 sub symbverify {	Line 4461 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 4150 sub symbclean {	Line 4492 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 4215 sub symbread {	Line 4560 sub symbread {
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 4269 sub symbread {	Line 4618 sub symbread {
}	}
}	}
untie(%bighash)	untie(%bighash)
}	}
}	}
if ($syval) {	if ($syval) {
return &symbclean($syval.'___'.$thisfn);	return &symbclean($syval.'___'.$thisfn);
Line 4293 sub numval {	Line 4642 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 4307 sub rndseed {	Line 4689 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 4378 sub rndseed_64bit2 {	Line 4761 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 a -1	# returns either the contents of the file or
	# -1 if the file doesn't exist
	#
	# 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,$caller) = @_;
if ($file=~/^\/*uploaded\//) { # user file
	if ($file !~ m\|^/*uploaded/(\w+)/(\w+)/(.+)$\|) {
	# normal file from res space
	&repcopy($file);
	return &readfile($file);
	}

	my $info;
	my $cdom = $1;
	my $cnum = $2;
	my $filename = $3;
	my $path = $Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles';
	my ($lwpresp,$rtncode);
	my $localfile = $path.'/'.$cdom.'/'.$cnum.'/'.$filename;
	if (-e "$localfile") {
	my @fileinfo = stat($localfile);
	$lwpresp = &getuploaded('HEAD',$file,$cdom,$cnum,\$info,\$rtncode);
	if ($lwpresp ne 'ok') {
	if ($rtncode eq '404') {
	unlink($localfile);
	}
	#my $ua=new LWP::UserAgent;
	#my $request=new HTTP::Request('GET',&tokenwrapper($file));
	#my $response=$ua->request($request);
	#if ($response->is_success()) {
	# return $response->content;
	# } else {
	# return -1;
	# }
	return -1;
	}
	if ($info < $fileinfo[9]) {
	return &readfile($localfile);
	}
	$info = '';
	$lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode);
	if ($lwpresp ne 'ok') {
	return -1;
	}
	} else {
	$lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode);
	if ($lwpresp ne 'ok') {
	my $ua=new LWP::UserAgent;
	my $request=new HTTP::Request('GET',&tokenwrapper($file));
	my $response=$ua->request($request);
	if ($response->is_success()) {
	return $response->content;
	} else {
	return -1;
	}
	}
	my @parts = ($cdom,$cnum);
	if ($filename =~ m\|^(.+)/[^/]+$\|) {
	push @parts, split(/\//,$1);
	}
	foreach my $part (@parts) {
	$path .= '/'.$part;
	if (!-e $path) {
	mkdir($path,0770);
	}
	}
	}
	open (FILE,">$localfile");
	print FILE $info;
	close(FILE);
	if ($caller eq 'uploadrep') {
	return 'ok';
	}
	return $info;
	}

	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 $ua=new LWP::UserAgent;
my $request=new HTTP::Request('GET',&tokenwrapper($file));	my $request=new HTTP::Request($reqtype,$uri);
my $response=$ua->request($request);	my $response=$ua->request($request);
if ($response->is_success()) {	$$rtncode = $response->code;
return $response->content;	if (! $response->is_success()) {
} else {	return 'failed';
return -1;	}
}	if ($reqtype eq 'HEAD') {
} else { # normal file from res space	$$info = &HTTP::Date::str2time( $response->header('Last-modified') );
&repcopy($file);	} elsif ($reqtype eq 'GET') {
if (! -e $file ) { return -1; };	$$info = $response->content;
my $fh;	}
open($fh,"<$file");	return 'ok';
my $a='';	}
while (<$fh>) { $a .=$_; }
return $a;	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 4459 sub filelocation {	Line 5013 sub filelocation {
} elsif ($file=~/^\/*uploaded/) { # is an uploaded file	} elsif ($file=~/^\/*uploaded/) { # is an uploaded file
$location=$file;	$location=$file;
} 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 4469 sub filelocation {	Line 5023 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 4515 sub current_machine_ids {	Line 5070 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 4526 sub declutter {	Line 5081 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 4588 BEGIN {	Line 5143 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 4706 BEGIN {	Line 5261 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 5451 messages of critical importance should g	Line 6007 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.467
changed lines
	Added in v.1.522