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.450 and 1.479

version 1.450, 2003/11/12 21:37:33	version 1.479, 2004/03/19 16:45:25
Line 377 sub delenv {	Line 377 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 506 sub changepass {	Line 511 sub changepass {

sub queryauthenticate {	sub queryauthenticate {
my ($uname,$udom)=@_;	my ($uname,$udom)=@_;
if (($perlvar{'lonRole'} eq 'library') &&	my $uhome=&homeserver($uname,$udom);
($udom eq $perlvar{'lonDefDomain'})) {	if (!$uhome) {
my $answer=reply("encrypt:currentauth:$udom:$uname",	&logthis("User $uname at $udom is unknown when looking for authentication mechanism");
$perlvar{'lonHostID'});	return 'no_host';
unless ($answer eq 'unknown_user' or $answer eq 'refused') {	}
if (length($answer)) {	my $answer=reply("encrypt:currentauth:$udom:$uname",$uhome);
return $answer;	if ($answer =~ /^(unknown_user\|refused\|con_lost)/) {
}	&logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
else {
&logthis("User $uname at $udom lacks an authentication mechanism");
return 'no_host';
}
}
}

my $tryserver;
foreach $tryserver (keys %libserv) {
if ($hostdom{$tryserver} eq $udom) {
my $answer=reply("encrypt:currentauth:$udom:$uname",$tryserver);
unless ($answer eq 'unknown_user' or $answer eq 'refused') {
if (length($answer)) {
return $answer;
}
else {
&logthis("User $uname at $udom lacks an authentication mechanism");
return 'no_host';
}
}
}
}	}
&logthis("User $uname at $udom lacks an authentication mechanism");	return $answer;
return 'no_host';
}	}

# --------- Try to authenticate user from domain's lib servers (first this one)	# --------- Try to authenticate user from domain's lib servers (first this one)
Line 546 sub authenticate {	Line 529 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");	my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome);
return $perlvar{'lonHostID'};	if ($answer eq 'authorized') {
}	&logthis("User $uname at $udom authorized by $uhome");
if ($answer eq 'non_authorized') {	return $uhome;
&logthis("User $uname at $udom rejected by local server");	}
return 'no_host';	if ($answer eq 'non_authorized') {
}	&logthis("User $uname at $udom rejected by $uhome");
}	return 'no_host';
}

my $tryserver;
foreach $tryserver (keys %libserv) {
if ($hostdom{$tryserver} eq $udom) {
my $answer=reply("encrypt:auth:$udom:$uname:$upass",$tryserver);
if ($answer =~ /authorized/) {
if ($answer eq 'authorized') {
&logthis("User $uname at $udom authorized by $tryserver");
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 683 sub assign_access_key {	Line 649 sub assign_access_key {
$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],$cdom,$cnum);
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
Line 790 sub validate_access_key {	Line 756 sub validate_access_key {
$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],$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 818 sub getsection {	Line 784 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 848 sub getsection {	Line 814 sub getsection {
return '-1';	return '-1';
}	}


	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};	delete $$cache{$id};
	if ($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");	open(DB,"$filename.lock");
flock(DB,LOCK_EX);	flock(DB,LOCK_EX);
Line 907 sub do_cache {	Line 877 sub do_cache {

sub save_cache_item {	sub save_cache_item {
my ($cache,$name,$id)=@_;	my ($cache,$name,$id)=@_;
	if ($disk_caching_disabled) { return; }
my $starttime=&Time::HiRes::time();	my $starttime=&Time::HiRes::time();
# &logthis("Saving :$name:$id");	# &logthis("Saving :$name:$id");
my %hash;	my %hash;
Line 936 EVALBLOCK	Line 907 EVALBLOCK

sub load_cache_item {	sub load_cache_item {
my ($cache,$name,$id)=@_;	my ($cache,$name,$id)=@_;
	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;
Line 991 sub usection {	Line 963 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 1153 sub ssi_body {	Line 1125 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[^\>]\>//si;
$output=~s/\<\/body\s\>.$//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;
return $output;	return $output;
Line 1199 sub tokenwrapper {	Line 1171 sub tokenwrapper {
$uri=~s/^\///;	$uri=~s/^\///;
$ENV{'user.environment'}=~/\/([^\/]+)\.id/;	$ENV{'user.environment'}=~/\/([^\/]+)\.id/;
my $token=$1;	my $token=$1;
if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.)$/) {	# if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.)$/) {
	if ($uri=~m\|^uploaded/([^/]+)/([^/]+)/(.+)(\?\.)$\|) {
&appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});	&appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});
return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.	return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.
(($uri=~/\?/)?'&':'?').'token='.$token.	(($uri=~/\?/)?'&':'?').'token='.$token.
Line 1208 sub tokenwrapper {	Line 1181 sub tokenwrapper {
return '/adm/notfound.html';	return '/adm/notfound.html';
}	}
}	}

	# --------- 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: ok if successful, diagnostic message otherwise
	#
	# 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.

	sub process_coursefile {
	my ($action,$docuname,$docudom,$docuhome,$file,$source)=@_;
	my $fetchresult;
	if ($action eq 'propagate') {
	$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file
	,$docuhome);
	} elsif ($action eq 'copy') {
	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 ($source eq '') {
	$fetchresult = 'no source file';
	} else {
	my $destination = $filepath.'/'.$fname;
	print STDERR "Getting ready to rename $source to $destination\n";
	rename($source,$destination);
	$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
	$docuhome);
	}
	}
	unless ( ($fetchresult eq 'ok') \|\| ($fetchresult eq 'no source file') ) {
	&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
Line 1264 sub finishuserfileupload {	Line 1295 sub finishuserfileupload {
}	}
# Notify homeserver to grep it	# Notify homeserver to grep it
#	#
	my $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,
my $fetchresult=	$docuhome);
&reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,$docuhome);
if ($fetchresult eq 'ok') {	if ($fetchresult eq 'ok') {
#	#
# Return the URL to it	# Return the URL to it
Line 1335 sub flushcourselogs {	Line 1365 sub flushcourselogs {
# Writes to the dynamic metadata of resources to get hit counts, etc.	# Writes to the dynamic metadata of resources to get hit counts, etc.
#	#
foreach my $entry (keys(%accesshash)) {	foreach my $entry (keys(%accesshash)) {
my ($dom,$name,undef,$type)=($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:);	if ($entry =~ /___count$/) {
if ($type eq 'count'){	my ($dom,$name);
	($dom,$name,undef)=($entry=~m:___(\w+)/(\w+)/(.*)___count$:);
	if (! defined($dom) \|\| $dom eq '' \|\|
	! defined($name) \|\| $name eq '') {
	my $cid = $ENV{'request.course.id'};
	$dom = $ENV{'request.'.$cid.'.domain'};
	$name = $ENV{'request.'.$cid.'.num'};
	}
my $value = $accesshash{$entry};	my $value = $accesshash{$entry};
my (undef,$url,undef) = ($entry =~ /^(.)___(.)___count$/);	my (undef,$url,undef) = ($entry =~ /^(.)___(.)___count$/);
my %temphash=($url => $value);	my %temphash=($url => $value);
Line 1351 sub flushcourselogs {	Line 1388 sub flushcourselogs {
}	}
}	}
} else {	} else {
	my ($dom,$name) = ($entry=~m:___(\w+)/(\w+)/(.*)___(\w+)$:);
my %temphash=($entry => $accesshash{$entry});	my %temphash=($entry => $accesshash{$entry});
if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {	if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
delete $accesshash{$entry};	delete $accesshash{$entry};
Line 1391 sub courselog {	Line 1429 sub courselog {
} else {	} else {
$courselogs{$ENV{'request.course.id'}}.=$what;	$courselogs{$ENV{'request.course.id'}}.=$what;
}	}
# if (length($courselogs{$ENV{'request.course.id'}})>4048) {	if (length($courselogs{$ENV{'request.course.id'}})>4048) {
if (length($courselogs{$ENV{'request.course.id'}})>48) {
&flushcourselogs();	&flushcourselogs();
}	}
}	}
Line 1414 sub courseacclog {	Line 1451 sub courseacclog {

sub countacc {	sub countacc {
my $url=&declutter(shift);	my $url=&declutter(shift);
	return if (! defined($url) \|\| $url eq '');
unless ($ENV{'request.course.id'}) { return ''; }	unless ($ENV{'request.course.id'}) { return ''; }
$accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1;	$accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1;
my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';	my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';
Line 1432 sub userrolelog {	Line 1470 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 1444 sub get_course_adv_roles {	Line 1482 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 1454 sub get_course_adv_roles {	Line 1496 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)) &&
	(!$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 2135 sub coursedescription {	Line 2179 sub coursedescription {
return %returnhash;	return %returnhash;
}	}

	# -------------------------------------------------See if a user is privileged

	sub privileged {
	my ($username,$domain)=@_;
	my $rolesdump=&reply("dump:$domain:$username:roles",
	&homeserver($username,$domain));
	if (($rolesdump eq 'con_lost') \|\| ($rolesdump eq '')) { return 0; }
	my $now=time;
	if ($rolesdump ne '') {
	foreach (split(/&/,$rolesdump)) {
	if ($_!~/^rolesdef\&/) {
	my ($area,$role)=split(/=/,$_);
	$area=~s/\_\w\w$//;
	my ($trole,$tend,$tstart)=split(/_/,$role);
	if (($trole eq 'dc') \|\| ($trole eq 'su')) {
	my $active=1;
	if ($tend) {
	if ($tend<$now) { $active=0; }
	}
	if ($tstart) {
	if ($tstart>$now) { $active=0; }
	}
	if ($active) { return 1; }
	}
	}
	}
	}
	return 0;
	}

# -------------------------------------------------------- Get user privileges	# -------------------------------------------------------- Get user privileges

sub rolesinit {	sub rolesinit {
Line 2555 sub allowed {	Line 2629 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 2572 sub allowed {	Line 2646 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;
}	}

Line 2590 sub allowed {	Line 2664 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 2611 sub allowed {	Line 2685 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 2639 sub allowed {	Line 2713 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 2692 sub allowed {	Line 2766 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 2703 sub allowed {	Line 2777 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 2737 sub allowed {	Line 2811 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 2745 sub allowed {	Line 2819 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 2757 sub allowed {	Line 2831 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 2769 sub allowed {	Line 2843 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 2833 sub definerole {	Line 2907 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 2900 sub log_query {	Line 2974 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);
}	}

Line 3138 sub modifyuser {	Line 3212 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)=@_;	$end,$start,$forceid,$desiredhome,$email,$type,$cid)=@_;
my $cid='';	if (!$cid) {
unless ($cid=$ENV{'request.course.id'}) {	unless ($cid=$ENV{'request.course.id'}) {
return 'not_in_class';	return 'not_in_class';
	}
}	}
# --------------------------------------------------------------- Make the user	# --------------------------------------------------------------- Make the user
my $reply=&modifyuser	my $reply=&modifyuser
Line 3151 sub modifystudent {	Line 3226 sub modifystudent {
# This will cause &modify_student_enrollment to get the uid from the	# This will cause &modify_student_enrollment to get the uid from the
# students environment	# students environment
$uid = undef if (!$forceid);	$uid = undef if (!$forceid);
$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,	$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
$last,$gene,$usec,$end,$start);	$gene,$usec,$end,$start,$type,$cid);
return $reply;	return $reply;
}	}

sub modify_student_enrollment {	sub modify_student_enrollment {
my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start) = @_;	my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,
# Get the course id from the environment	$cid) = @_;
my $cid='';	my ($cdom,$cnum,$chome);
unless ($cid=$ENV{'request.course.id'}) {	if (!$cid) {
return 'not_in_class';	unless ($cid=$ENV{'request.course.id'}) {
	return 'not_in_class';
	}
	$cdom=$ENV{'course.'.$cid.'.domain'};
	$cnum=$ENV{'course.'.$cid.'.num'};
	} else {
	($cdom,$cnum)=split(/_/,$cid);
}	}
	$chome=$ENV{'course.'.$cid.'.home'};
	if (!$chome) {
	$chome=&homeserver($cnum,$cdom);
	}
	if (!$chome) { return 'unknown_course'; }
# Make sure the user exists	# Make sure the user exists
my $uhome=&homeserver($uname,$udom);	my $uhome=&homeserver($uname,$udom);
if (($uhome eq '') \|\| ($uhome eq 'no_host')) {	if (($uhome eq '') \|\| ($uhome eq 'no_host')) {
return 'error: no such user';	return 'error: no such user';
}	}
#
# Get student data if we were not given enough information	# Get student data if we were not given enough information
if (!defined($first) \|\| $first eq '' \|\|	if (!defined($first) \|\| $first eq '' \|\|
!defined($last) \|\| $last eq '' \|\|	!defined($last) \|\| $last eq '' \|\|
Line 3181 sub modify_student_enrollment {	Line 3266 sub modify_student_enrollment {
['firstname','middlename','lastname', 'generation','id']	['firstname','middlename','lastname', 'generation','id']
,$udom,$uname);	,$udom,$uname);

foreach (keys(%tmp)) {	#foreach (keys(%tmp)) {
&logthis("key $_ = ".$tmp{$_});	# &logthis("key $_ = ".$tmp{$_});
}	#}
$first = $tmp{'firstname'} if (!defined($first) \|\| $first eq '');	$first = $tmp{'firstname'} if (!defined($first) \|\| $first eq '');
$middle = $tmp{'middlename'} if (!defined($middle) \|\| $middle eq '');	$middle = $tmp{'middlename'} if (!defined($middle) \|\| $middle eq '');
$last = $tmp{'lastname'} if (!defined($last) \|\| $last eq '');	$last = $tmp{'lastname'} if (!defined($last) \|\| $last eq '');
Line 3192 sub modify_student_enrollment {	Line 3277 sub modify_student_enrollment {
}	}
my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene,	my $fullname = &Apache::loncoursedata::ProcessFullName($last,$gene,
$first,$middle);	$first,$middle);
my $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'.	my $value=&escape($uname.':'.$udom).'='.
$ENV{'course.'.$cid.'.num'}.':classlist:'.	&escape(join(':',$end,$start,$uid,$usec,$fullname,$type));
&escape($uname.':'.$udom).'='.	my $reply=critical('put:'.$cdom.':'.$cnum.':classlist:'.$value,$chome);
&escape(join(':',$end,$start,$uid,$usec,$fullname)),
$ENV{'course.'.$cid.'.home'});
unless (($reply eq 'ok') \|\| ($reply eq 'delayed')) {	unless (($reply eq 'ok') \|\| ($reply eq 'delayed')) {
return 'error: '.$reply;	return 'error: '.$reply;
}	}
Line 3688 sub EXT {	Line 3771 sub EXT {
my $hashid="$udom:$uname";	my $hashid="$udom:$uname";
my ($result,$cached)=&is_cached(\%userresdatacache,$hashid,	my ($result,$cached)=&is_cached(\%userresdatacache,$hashid,
'userres');	'userres');
if (!defined($cached)) {	if (!defined($cached)) {
my %resourcedata=&get('resourcedata',	my %resourcedata=&dump('resourcedata',$udom,$uname);
[$courselevelr,$courselevelm,
$courselevel],$udom,$uname);
$result=\%resourcedata;	$result=\%resourcedata;
&do_cache(\%userresdatacache,$hashid,$result,'userres');	&do_cache(\%userresdatacache,$hashid,$result,'userres');
}	}
Line 3704 sub EXT {	Line 3785 sub EXT {
if ($$result{$courselevel}) {	if ($$result{$courselevel}) {
return $$result{$courselevel}; }	return $$result{$courselevel}; }
} else {	} else {
if ($tmp!~/No such file/) {	#error 2 occurs when the .db doesn't exist
	if ($tmp!~/error: 2 /) {
&logthis("<font color=blue>WARNING:".	&logthis("<font color=blue>WARNING:".
" Trying to get resource data for ".	" Trying to get resource data for ".
$uname." at ".$udom.": ".	$uname." at ".$udom.": ".
$tmp."</font>");	$tmp."</font>");
} elsif ($tmp=~/error:No such file/) {	} 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 3791 sub packages_tab_default {	Line 3873 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"})) {
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 3822 sub metadata {	Line 3907 sub metadata {
# 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\|/$\|) \|\| ($uri =~ m\|/.meta$\|) \|\| ($uri =~ /^~/) \|\|	($uri =~ m\|/$\|) \|\| ($uri =~ m\|/.meta$\|) \|\| ($uri =~ /^~/) \|\|
($uri =~ m\|home/[^/]+/public_html/\|)) {	($uri =~ m\|home/[^/]+/public_html/\|) \|\| ($uri =~ m\|^uploaded/\|)) {
return '';	return undef;
}	}
my $filename=$uri;	my $filename=$uri;
$uri=~s/\.meta$//;	$uri=~s/\.meta$//;
Line 3840 sub metadata {	Line 3925 sub metadata {
#	#
# Is this a recursive call for a library?	# Is this a recursive call for a library?
#	#
my %lcmetacache;	if (! exists($metacache{$uri})) {
	$metacache{$uri}={};
	}
if ($liburi) {	if ($liburi) {
$liburi=&declutter($liburi);	$liburi=&declutter($liburi);
$filename=$liburi;	$filename=$liburi;
Line 3864 sub metadata {	Line 3951 sub metadata {
if (defined($token->[2]->{'id'})) {	if (defined($token->[2]->{'id'})) {
$keyroot.='_'.$token->[2]->{'id'};	$keyroot.='_'.$token->[2]->{'id'};
}	}
if ($lcmetacache{':packages'}) {	if ($metacache{$uri}->{':packages'}) {
$lcmetacache{':packages'}.=','.$package.$keyroot;	$metacache{$uri}->{':packages'}.=','.$package.$keyroot;
} else {	} else {
$lcmetacache{':packages'}=$package.$keyroot;	$metacache{$uri}->{':packages'}=$package.$keyroot;
}	}
foreach (keys %packagetab) {	foreach (keys %packagetab) {
my $part=$keyroot;	my $part=$keyroot;
Line 3889 sub metadata {	Line 3976 sub metadata {
if ($subp eq 'display') {	if ($subp eq 'display') {
$value.=' [Part: '.$part.']';	$value.=' [Part: '.$part.']';
}	}
$lcmetacache{':'.$unikey.'.part'}=$part;	$metacache{$uri}->{':'.$unikey.'.part'}=$part;
$metathesekeys{$unikey}=1;	$metathesekeys{$unikey}=1;
unless (defined($lcmetacache{':'.$unikey.'.'.$subp})) {	unless (defined($metacache{$uri}->{':'.$unikey.'.'.$subp})) {
$lcmetacache{':'.$unikey.'.'.$subp}=$value;	$metacache{$uri}->{':'.$unikey.'.'.$subp}=$value;
}	}
if (defined($lcmetacache{':'.$unikey.'.default'})) {	if (defined($metacache{$uri}->{':'.$unikey.'.default'})) {
$lcmetacache{':'.$unikey}=	$metacache{$uri}->{':'.$unikey}=
$lcmetacache{':'.$unikey.'.default'};	$metacache{$uri}->{':'.$unikey.'.default'};
}	}
}	}
}	}
Line 3929 sub metadata {	Line 4016 sub metadata {
foreach (sort(split(/\,/,&metadata($uri,'keys',	foreach (sort(split(/\,/,&metadata($uri,'keys',
$location,$unikey,	$location,$unikey,
$depthcount+1)))) {	$depthcount+1)))) {
	$metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_};
$metathesekeys{$_}=1;	$metathesekeys{$_}=1;
}	}
}	}
Line 3939 sub metadata {	Line 4027 sub metadata {
}	}
$metathesekeys{$unikey}=1;	$metathesekeys{$unikey}=1;
foreach (@{$token->[3]}) {	foreach (@{$token->[3]}) {
$lcmetacache{':'.$unikey.'.'.$_}=$token->[2]->{$_};	$metacache{$uri}->{':'.$unikey.'.'.$_}=$token->[2]->{$_};
}	}
my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));	my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
my $default=$lcmetacache{':'.$unikey.'.default'};	my $default=$metacache{$uri}->{':'.$unikey.'.default'};
if ( $internaltext =~ /^\s$/ && $default !~ /^\s$/) {	if ( $internaltext =~ /^\s$/ && $default !~ /^\s$/) {
# only ws inside the tag, and not in default, so use default	# only ws inside the tag, and not in default, so use default
# as value	# as value
$lcmetacache{':'.$unikey}=$default;	$metacache{$uri}->{':'.$unikey}=$default;
} else {	} else {
# either something interesting inside the tag or default	# either something interesting inside the tag or default
# uninteresting	# uninteresting
$lcmetacache{':'.$unikey}=$internaltext;	$metacache{$uri}->{':'.$unikey}=$internaltext;
}	}
# end of not-a-package not-a-library import	# end of not-a-package not-a-library import
}	}
Line 3960 sub metadata {	Line 4048 sub metadata {
}	}
}	}
# are there custom rights to evaluate	# are there custom rights to evaluate
if ($lcmetacache{':copyright'} eq 'custom') {	if ($metacache{$uri}->{':copyright'} eq 'custom') {

#	#
# Importing a rights file here	# Importing a rights file here
#	#
unless ($depthcount) {	unless ($depthcount) {
my $location=$lcmetacache{':customdistributionfile'};	my $location=$metacache{$uri}->{':customdistributionfile'};
my $dir=$filename;	my $dir=$filename;
$dir=~s\|[^/]*$\|\|;	$dir=~s\|[^/]*$\|\|;
$location=&filelocation($dir,$location);	$location=&filelocation($dir,$location);
foreach (sort(split(/\,/,&metadata($uri,'keys',	foreach (sort(split(/\,/,&metadata($uri,'keys',
$location,'_rights',	$location,'_rights',
$depthcount+1)))) {	$depthcount+1)))) {
	$metacache{$uri}->{':'.$_}=$metacache{$uri}->{':'.$_};
$metathesekeys{$_}=1;	$metathesekeys{$_}=1;
}	}
}	}
}	}
$lcmetacache{':keys'}=join(',',keys %metathesekeys);	$metacache{$uri}->{':keys'}=join(',',keys %metathesekeys);
&metadata_generate_part0(\%metathesekeys,\%lcmetacache,$uri);	&metadata_generate_part0(\%metathesekeys,$metacache{$uri},$uri);
$lcmetacache{':allpossiblekeys'}=join(',',keys %metathesekeys);	$metacache{$uri}->{':allpossiblekeys'}=join(',',keys %metathesekeys);
&do_cache(\%metacache,$uri,\%lcmetacache,'meta');	&do_cache(\%metacache,$uri,$metacache{$uri},'meta');
# this is the end of "was not already recently cached	# this is the end of "was not already recently cached
}	}
return $metacache{$uri}->{':'.$what};	return $metacache{$uri}->{':'.$what};
Line 4009 sub metadata_generate_part0 {	Line 4098 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 4367 sub setup_random_from_rndseed {	Line 4456 sub setup_random_from_rndseed {
}	}
}	}

	sub latest_receipt_algorithm_id {
	return 'receipt2';
	}

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=unpack("%32C*",$perlvar{'lonReceipt'});
return unpack("%32C*",$perlvar{'lonHostID'}).'-'.	my $cpart=unpack("%32S*",$part);
($cunique%$cuname+	my $return =unpack("%32C*",$perlvar{'lonHostID'}).'-';
$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
	# -2 if an error occured when trying to aqcuire the file

sub getfile {	sub getfile {
my $file=shift;	my $file=shift;
if ($file=~/^\/*uploaded\//) { # user file	if ($file=~/^\/*uploaded\//) { # user file
my $ua=new LWP::UserAgent;	my $ua=new LWP::UserAgent;
my $request=new HTTP::Request('GET',&tokenwrapper($file));	my $request=new HTTP::Request('GET',&tokenwrapper($file));
my $response=$ua->request($request);	my $response=$ua->request($request);
if ($response->is_success()) {	if ($response->is_success()) {
return $response->content;	return $response->content;
} else {	} else {
return -1;	#&logthis("Return Code is ".$response->code." for $file ".
}	# &tokenwrapper($file));
} else { # normal file from res space	# 500 for ISE when tokenwrapper can't figure out what server to
&repcopy($file);	# contact
if (! -e $file ) { return -1; };	# 503 when lonuploadacc can't contact the requested server
my $fh;	if ($response->code eq 503 \|\| $response->code eq 500) {
open($fh,"<$file");	return -2;
my $a='';	} else {
while (<$fh>) { $a .=$_; }	return -1;
return $a;	}
}	}
	} else { # normal file from res space
	&repcopy($file);
	if (! -e $file ) { return -1; };
	my $fh;
	open($fh,"<$file");
	my $a='';
	while (<$fh>) { $a .=$_; }
	return $a;
	}
}	}

sub filelocation {	sub filelocation {
Line 4422 sub filelocation {	Line 4545 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;
} else {	} else {
Line 4432 sub filelocation {	Line 4555 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;
}	}

sub hreflocation {	sub hreflocation {
my ($dir,$file)=@_;	my ($dir,$file)=@_;
unless (($file=~/^http:\/\//i) \|\| ($file=~/^\//)) {	unless (($file=~m-^http://-i) \|\| ($file=~m-^/-)) {
my $finalpath=filelocation($dir,$file);	my $finalpath=filelocation($dir,$file);
$finalpath=~s/^\/home\/httpd\/html//;	$finalpath=~s-^/home/httpd/html--;
$finalpath=~s-/home/(\w+)/public_html/-/~$1/-;	$finalpath=~s-^/home/(\w+)/public_html/-/~$1/-;
return $finalpath;	return $finalpath;
} else {	} elsif ($file=~m-^/home-) {
return $file;	$file=~s-^/home/httpd/html--;
	$file=~s-^/home/(\w+)/public_html/-/~$1/-;
	return $file;
	}
	return $file;
	}

	sub current_machine_domains {
	my $hostname=$hostname{$perlvar{'lonHostID'}};
	my @domains;
	while( my($id, $name) = each(%hostname)) {
	# &logthis("-$id-$name-$hostname-");
	if ($hostname eq $name) {
	push(@domains,$hostdom{$id});
	}
	}
	return @domains;
	}

	sub current_machine_ids {
	my $hostname=$hostname{$perlvar{'lonHostID'}};
	my @ids;
	while( my($id, $name) = each(%hostname)) {
	# &logthis("-$id-$name-$hostname-");
	if ($hostname eq $name) {
	push(@ids,$id);
	}
}	}
	return @ids;
}	}

# ------------------------------------------------------------- Declutters URLs	# ------------------------------------------------------------- Declutters URLs

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/\?.+$//;

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

Removed from v.1.450
changed lines
	Added in v.1.479