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.475 and 1.488

version 1.475, 2004/03/08 23:04:00	version 1.488, 2004/04/23 19:36:46
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
Line 615 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 625 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 649 sub assign_access_key {	Line 651 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 756 sub validate_access_key {	Line 758 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 784 sub getsection {	Line 786 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 963 sub usection {	Line 965 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 1171 sub tokenwrapper {	Line 1173 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 1180 sub tokenwrapper {	Line 1183 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: 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 {
	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
Line 1207 sub userfileupload {	Line 1291 sub userfileupload {
$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 {
Line 1236 sub finishuserfileupload {	Line 1325 sub finishuserfileupload {
}	}
# Notify homeserver to grep it	# Notify homeserver to grep it
#	#

my $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,	my $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,
$docuhome);	$docuhome);
if ($fetchresult eq 'ok') {	if ($fetchresult eq 'ok') {
Line 2571 sub allowed {	Line 2659 sub allowed {

# Course	# Course

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

# Domain	# Domain

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

Line 2588 sub allowed {	Line 2676 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 2606 sub allowed {	Line 2694 sub allowed {

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

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

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

if ($thisallowed=~/R/) {	if ($thisallowed=~/R/) {
my $rolecode=(split(/\./,$ENV{'request.role'}))[0];	my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
if (&metadata($uri,'roledeny')=~/$rolecode/) {	if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {
&log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},	&log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);	'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
return '';	return '';
Line 2785 sub allowed {	Line 2873 sub allowed {
if ($thisallowed=~/X/) {	if ($thisallowed=~/X/) {
if ($ENV{'acc.randomout'}) {	if ($ENV{'acc.randomout'}) {
my $symb=&symbread($uri,1);	my $symb=&symbread($uri,1);
if (($symb) && ($ENV{'acc.randomout'}=~/\&$symb\&/)) {	if (($symb) && ($ENV{'acc.randomout'}=~/\&\Q$symb\E\&/)) {
return '';	return '';
}	}
}	}
Line 2849 sub definerole {	Line 2937 sub definerole {
my ($rolename,$sysrole,$domrole,$courole)=@_;	my ($rolename,$sysrole,$domrole,$courole)=@_;
foreach (split(':',$sysrole)) {	foreach (split(':',$sysrole)) {
my ($crole,$cqual)=split(/\&/,$_);	my ($crole,$cqual)=split(/\&/,$_);
if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; }	if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; }
if ($pr{'cr:s'}=~/$crole\&/) {	if ($pr{'cr:s'}=~/\Q$crole\E\&/) {
if ($pr{'cr:s'}!~/$crole\&\w*$cqual/) {	if ($pr{'cr:s'}!~/\Q$crole\E\&\w*\Q$cqual\E/) {
return "refused:s:$crole&$cqual";	return "refused:s:$crole&$cqual";
}	}
}	}
}	}
foreach (split(':',$domrole)) {	foreach (split(':',$domrole)) {
my ($crole,$cqual)=split(/\&/,$_);	my ($crole,$cqual)=split(/\&/,$_);
if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; }	if ($pr{'cr:d'}!~/\Q$crole\E/) { return "refused:d:$crole"; }
if ($pr{'cr:d'}=~/$crole\&/) {	if ($pr{'cr:d'}=~/\Q$crole\E\&/) {
if ($pr{'cr:d'}!~/$crole\&\w*$cqual/) {	if ($pr{'cr:d'}!~/\Q$crole\W\&\w*\Q$cqual\E/) {
return "refused:d:$crole&$cqual";	return "refused:d:$crole&$cqual";
}	}
}	}
}	}
foreach (split(':',$courole)) {	foreach (split(':',$courole)) {
my ($crole,$cqual)=split(/\&/,$_);	my ($crole,$cqual)=split(/\&/,$_);
if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; }	if ($pr{'cr:c'}!~/\Q$crole\E/) { return "refused:c:$crole"; }
if ($pr{'cr:c'}=~/$crole\&/) {	if ($pr{'cr:c'}=~/\Q$crole\E\&/) {
if ($pr{'cr:c'}!~/$crole\&\w*$cqual/) {	if ($pr{'cr:c'}!~/\Q$crole\E\&\w*\Q$cqual\E/) {
return "refused:c:$crole&$cqual";	return "refused:c:$crole&$cqual";
}	}
}	}
Line 2916 sub log_query {	Line 3004 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 3219 sub modify_student_enrollment {	Line 3307 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) },
	$cdom,$cnum);
unless (($reply eq 'ok') \|\| ($reply eq 'delayed')) {	unless (($reply eq 'ok') \|\| ($reply eq 'delayed')) {
return 'error: '.$reply;	return 'error: '.$reply;
}	}
Line 3989 sub metadata {	Line 4078 sub metadata {
# the next is the end of "start tag"	# the next is the end of "start tag"
}	}
}	}
	my ($extension) = ($uri =~ /\.(\w+)$/);
	foreach my $key (sort(keys(%packagetab))) {
	#&logthis("extsion1 $extension $key !!");
	#no specific packages #how's our extension
	if ($key!~/^extension_\Q$extension\E&/) { next; }
	&metadata_create_package_def($uri,$key,'extension_'.$extension,
	\%metathesekeys);
	}
	if (!exists($metacache{$uri}->{':packages'})) {
	foreach my $key (sort(keys(%packagetab))) {
	#no specific packages well let's get default then
	if ($key!~/^default&/) { next; }
	&metadata_create_package_def($uri,$key,'default',
	\%metathesekeys);
	}
	}
# are there custom rights to evaluate	# are there custom rights to evaluate
if ($metacache{$uri}->{':copyright'} eq 'custom') {	if ($metacache{$uri}->{':copyright'} eq 'custom') {

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

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

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

sub metadata_generate_part0 {	sub metadata_generate_part0 {
my ($metadata,$metacache,$uri) = @_;	my ($metadata,$metacache,$uri) = @_;
my %allnames;	my %allnames;
Line 4040 sub metadata_generate_part0 {	Line 4169 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 4209 sub symbread {	Line 4338 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 4263 sub symbread {	Line 4396 sub symbread {
}	}
}	}
untie(%bighash)	untie(%bighash)
}	}
}	}
if ($syval) {	if ($syval) {
return &symbclean($syval.'___'.$thisfn);	return &symbclean($syval.'___'.$thisfn);
Line 4287 sub numval {	Line 4420 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 '64bit2';
}	}
Line 4302 sub rndseed {	Line 4450 sub rndseed {
if (!$domain) { $domain=$wdomain; }	if (!$domain) { $domain=$wdomain; }
if (!$username) { $username=$wusername }	if (!$username) { $username=$wusername }
my $which=$ENV{"course.$courseid.rndseed"};	my $which=$ENV{"course.$courseid.rndseed"};
my $CODE=$ENV{'scantron.CODE'};	my $CODE=$ENV{'form.CODE'};
if (defined($CODE)) {	if (defined($CODE)) {
&rndseed_CODE_64bit($symb,$courseid,$domain,$username);	return &rndseed_CODE_64bit($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 4377 sub rndseed_CODE_64bit {	Line 4525 sub rndseed_CODE_64bit {
{	{
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*",$ENV{'form.CODE'}.' ') << 16;
	my $CODEseed=numval($ENV{'form.CODE'});
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";
}	}
Line 4402 sub latest_receipt_algorithm_id {	Line 4551 sub latest_receipt_algorithm_id {
return 'receipt2';	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,$part)=@_;	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);
my $cpart=unpack("%32S*",$part);	my $cpart=unpack("%32S*",$part);
my $return =unpack("%32C*",$perlvar{'lonHostID'}).'-';	my $return =&recprefix($fucourseid).'-';
if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2' \|\|	if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2' \|\|
$ENV{'request.state'} eq 'construct') {	$ENV{'request.state'} eq 'construct') {
&Apache::lonxml::debug("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname).	&Apache::lonxml::debug("doing receipt2 using parts $cpart, uname $cuname and udom $cudom gets ".($cpart%$cuname).
Line 4444 sub receipt {	Line 4615 sub receipt {
# ------------------------------------------------------------ Serves up a file	# ------------------------------------------------------------ Serves up a file
# returns either the contents of the file or	# returns either the contents of the file or
# -1 if the file doesn't exist	# -1 if the file doesn't exist
# -2 if an error occured when trying to aqcuire the file	#
	# if the target is a file that was uploaded via DOCS,
	# a check will be made to see if a current copy exists on the local server,
	# if it does this will be served, otherwise a copy will be retrieved from
	# the home server for the course and stored in /home/httpd/html/userfiles on
	# the local server.

sub getfile {	sub getfile {
my $file=shift;	my ($file,$caller) = @_;
if ($file=~/^\/*uploaded\//) { # user file
my $ua=new LWP::UserAgent;	if ($file !~ m\|^/*uploaded/(\w+)/(\w+)/(.+)$\|) {
my $request=new HTTP::Request('GET',&tokenwrapper($file));	# normal file from res space
my $response=$ua->request($request);	&repcopy($file);
if ($response->is_success()) {	return &readfile($file);
return $response->content;	}
} else {
#&logthis("Return Code is ".$response->code." for $file ".	my $info;
# &tokenwrapper($file));	my $cdom = $1;
# 500 for ISE when tokenwrapper can't figure out what server to	my $cnum = $2;
# contact	my $filename = $3;
# 503 when lonuploadacc can't contact the requested server	my $path = $Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles';
if ($response->code eq 503 \|\| $response->code eq 500) {	my ($lwpresp,$rtncode);
return -2;	my $localfile = $path.'/'.$cdom.'/'.$cnum.'/'.$filename;
} else {	if (-e "$localfile") {
return -1;	my @fileinfo = stat($localfile);
	$lwpresp = &getuploaded('HEAD',$file,$cdom,$cnum,\$info,\$rtncode);
	if ($lwpresp ne 'ok') {
	if ($rtncode eq '404') {
	unlink($localfile);
}	}
	return -1;
}	}
} else { # normal file from res space	if ($info < $fileinfo[9]) {
&repcopy($file);	return &readfile($localfile);
if (! -e $file ) { return -1; };	}
my $fh;	$info = '';
open($fh,"<$file");	$lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode);
my $a='';	if ($lwpresp ne 'ok') {
while (<$fh>) { $a .=$_; }	return -1;
return $a;	}
	} else {
	$lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode);
	if ($lwpresp ne 'ok') {
	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 getuploaded {
	my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
	$uri=~s/^\///;
	$uri = 'http://'.$hostname{ &homeserver($cnum,$cdom)}.'/raw/'.$uri;
	my $ua=new LWP::UserAgent;
	my $request=new HTTP::Request($reqtype,$uri);
	my $response=$ua->request($request);
	$$rtncode = $response->code;
	if (! $response->is_success()) {
	return 'failed';
	}
	if ($reqtype eq 'HEAD') {
	$$info = &HTTP::Date::str2time( $response->header('Last-modified') );
	} elsif ($reqtype eq 'GET') {
	$$info = $response->content;
}	}
	return 'ok';
	}

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

sub filelocation {	sub filelocation {
Line 4487 sub filelocation {	Line 4719 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 4544 sub current_machine_ids {	Line 4776 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 4617 BEGIN {	Line 4849 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 4735 BEGIN {	Line 4967 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 5480 messages of critical importance should g	Line 5713 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.475
changed lines
	Added in v.1.488