Return to lonnet.pm CVS log

Up to [LON-CAPA] / loncom / lonnet / perl

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.87 and 1.165

version 1.87, 2001/01/05 20:45:09	version 1.165, 2001/10/16 18:41:01
Line 3	Line 3
#	#
# Functions for use by content handlers:	# Functions for use by content handlers:
#	#
	# metadata_query(sql-query-string,custom-metadata-regex) :
	# returns file handle of where sql and
	# regex results will be stored for query
# plaintext(short) : plain text explanation of short term	# plaintext(short) : plain text explanation of short term
# fileembstyle(ext) : embed style in page for file extension	# fileembstyle(ext) : embed style in page for file extension
# filedescription(ext) : descriptor text for file extension	# filedescription(ext) : descriptor text for file extension
Line 13	Line 16
# 1: user needs to choose course	# 1: user needs to choose course
# 2: browse allowed	# 2: browse allowed
# definerole(rolename,sys,dom,cou) : define a custom role rolename	# definerole(rolename,sys,dom,cou) : define a custom role rolename
# set priviledges in format of lonTabs/roles.tab for	# set privileges in format of lonTabs/roles.tab for
# system, domain and course level,	# system, domain and course level,
# assignrole(udom,uname,url,role,end,start) : give a role to a user for the	# assignrole(udom,uname,url,role,end,start) : give a role to a user for the
# level given by url. Optional start and end dates	# level given by url. Optional start and end dates
Line 25	Line 28
# revokecustomrole (udom,uname,url,rdom,rnam,rolename) : Revoke a custom role	# revokecustomrole (udom,uname,url,rdom,rnam,rolename) : Revoke a custom role
# appenv(hash) : adds hash to session environment	# appenv(hash) : adds hash to session environment
# delenv(varname) : deletes all environment entries starting with varname	# delenv(varname) : deletes all environment entries starting with varname
# store(hash) : stores hash permanently for this url	# store(hashref,symb,courseid,udom,uname)
# cstore(hash) : critical store	# : stores hash permanently for this url
# restore : returns hash for this url	# hashref needs to be given, and should be a \%hashname
# eget(namesp,array) : returns hash with keys from array filled in from namesp	# the remaining args aren't required and if they aren't
# get(namesp,array) : returns hash with keys from array filled in from namesp	# passed or are '' they will be derived from the ENV
# del(namesp,array) : deletes keys out of array from namesp	# cstore(hashref,symb,courseid,udom,uname)
# put(namesp,hash) : stores hash in namesp	# : same as store but uses the critical interface to
# cput(namesp,hash) : critical put	# guarentee a store
# dump(namesp) : dumps the complete namespace into a hash	# restore(symb,courseid,udom,uname)
	# : returns hash for this symb, all args are optional
	# if they aren't given they will be derived from the
	# current enviroment
	#
	#
	# for the next 6 functions udom and uname are optional
	# if supplied they use udom as the domain and uname
	# as the username for the function (supply a courseid
	# for the uname if you want a course database)
	# if not supplied it uses %ENV and looks at
	# user. attribute for the values
	#
	# eget(namesp,arrayref,udom,uname)
	# : returns hash with keys from array reference filled
	# in from namesp (encrypts the return communication)
	# get(namesp,arrayref,udom,uname)
	# : returns hash with keys from array reference filled
	# in from namesp
	# dump(namesp,udom,uname) : dumps the complete namespace into a hash
	# del(namesp,array,udom,uname) : deletes keys out of array from namesp
	# put(namesp,hash,udom,uname) : stores hash in namesp
	# cput(namesp,hash,udom,uname) : critical put
	#
	#
# ssi(url,hash) : does a complete request cycle on url to localhost, posts	# ssi(url,hash) : does a complete request cycle on url to localhost, posts
# hash	# hash
# coursedescription(id) : returns and caches course description for id	# coursedescription(id) : returns and caches course description for id
Line 45	Line 72
# EXT(name) : value of a variable	# EXT(name) : value of a variable
# symblist(map,hash) : Updates symbolic storage links	# symblist(map,hash) : Updates symbolic storage links
# symbread([filename]) : returns the data handle (filename optional)	# symbread([filename]) : returns the data handle (filename optional)
# rndseed() : returns a random seed	# rndseed([symb,courseid,domain,uname])
	# : returns a random seed, all arguments are optional,
	# if they aren't sent it use the environment to derive
	# them
	# Note: if symb isn't sent and it can't get one from
	# &symbread it will use the current time as it's return
# receipt() : returns a receipt to be given out to users	# receipt() : returns a receipt to be given out to users
# getfile(filename) : returns the contents of filename, or a -1 if it can't	# getfile(filename) : returns the contents of filename, or a -1 if it can't
# be found, replicates and subscribes to the file	# be found, replicates and subscribes to the file
# filelocation(dir,file) : returns a farily clean absolute reference to file	# filelocation(dir,file) : returns a fairly clean absolute reference to file
# from the directory dir	# from the directory dir
# hreflocation(dir,file) : same as filelocation, but for hrefs	# hreflocation(dir,file) : same as filelocation, but for hrefs
# log(domain,user,home,msg) : write to permanent log for user	# log(domain,user,home,msg) : write to permanent log for user
Line 83	Line 115
# 11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25,11/27,	# 11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25,11/27,
# 12/02,12/12,12/13,12/14,12/28,12/29 Gerd Kortemeyer	# 12/02,12/12,12/13,12/14,12/28,12/29 Gerd Kortemeyer
# 05/01/01 Guy Albertelli	# 05/01/01 Guy Albertelli
# 05/01 Gerd Kortemeyer	# 05/01,06/01,09/01 Gerd Kortemeyer
	# 09/01 Guy Albertelli
	# 09/01,10/01,11/01 Gerd Kortemeyer
	# YEAR=2001
	# 02/27/01 Scott Harrison
	# 3/2 Gerd Kortemeyer
	# 3/15,3/19 Scott Harrison
	# 3/19,3/20 Gerd Kortemeyer
	# 3/22,3/27,4/2,4/16,4/17 Scott Harrison
	# 5/26,5/28 Gerd Kortemeyer
	# 5/30 H. K. Ng
	# 6/1 Gerd Kortemeyer
	# July Guy Albertelli
	# 8/4,8/7,8/8,8/9,8/11,8/16,8/17,8/18,8/20,8/23,9/20,9/21,9/26,
	# 10/2 Gerd Kortemeyer
	# 10/5,10/10 Scott Harrison

package Apache::lonnet;	package Apache::lonnet;

Line 92 use Apache::File;	Line 139 use Apache::File;
use LWP::UserAgent();	use LWP::UserAgent();
use HTTP::Headers;	use HTTP::Headers;
use vars	use vars
qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache);	qw(%perlvar %hostname %homecache %hostip %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache %packagetab %courselogs);
use IO::Socket;	use IO::Socket;
use GDBM_File;	use GDBM_File;
use Apache::Constants qw(:common :http);	use Apache::Constants qw(:common :http);
use HTML::TokeParser;	use HTML::TokeParser;
	use Fcntl qw(:flock);

# --------------------------------------------------------------------- Logging	# --------------------------------------------------------------------- Logging

	sub logtouch {
	my $execdir=$perlvar{'lonDaemons'};
	unless (-e "$execdir/logs/lonnet.log") {
	my $fh=Apache::File->new(">>$execdir/logs/lonnet.log");
	close $fh;
	}
	my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];
	chown($wwwuid,$wwwgid,$execdir.'/logs/lonnet.log');
	}

sub logthis {	sub logthis {
my $message=shift;	my $message=shift;
my $execdir=$perlvar{'lonDaemons'};	my $execdir=$perlvar{'lonDaemons'};
Line 179 sub reconlonc {	Line 237 sub reconlonc {

sub critical {	sub critical {
my ($cmd,$server)=@_;	my ($cmd,$server)=@_;
	unless ($hostname{$server}) {
	&logthis("<font color=blue>WARNING:".
	" Critical message to unknown server ($server)</font>");
	return 'no_such_host';
	}
my $answer=reply($cmd,$server);	my $answer=reply($cmd,$server);
if ($answer eq 'con_lost') {	if ($answer eq 'con_lost') {
my $pingreply=reply('ping',$server);	my $pingreply=reply('ping',$server);
Line 231 sub appenv {	Line 294 sub appenv {
map {	map {
if (($newenv{$_}=~/^user\.role/) \|\| ($newenv{$_}=~/^user\.priv/)) {	if (($newenv{$_}=~/^user\.role/) \|\| ($newenv{$_}=~/^user\.priv/)) {
&logthis("<font color=blue>WARNING: ".	&logthis("<font color=blue>WARNING: ".
"Attempt to modify environment ".$_." to ".$newenv{$_});	"Attempt to modify environment ".$_." to ".$newenv{$_}
	.'</font>');
delete($newenv{$_});	delete($newenv{$_});
} else {	} else {
$ENV{$_}=$newenv{$_};	$ENV{$_}=$newenv{$_};
}	}
} keys %newenv;	} keys %newenv;

	my $lockfh;
	unless ($lockfh=Apache::File->new("$ENV{'user.environment'}")) {
	return 'error: '.$!;
	}
	unless (flock($lockfh,LOCK_EX)) {
	&logthis("<font color=blue>WARNING: ".
	'Could not obtain exclusive lock in appenv: '.$!);
	$lockfh->close();
	return 'error: '.$!;
	}

my @oldenv;	my @oldenv;
{	{
my $fh;	my $fh;
unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {	unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
return 'error';	return 'error: '.$!;
}	}
@oldenv=<$fh>;	@oldenv=<$fh>;
	$fh->close();
}	}
for (my $i=0; $i<=$#oldenv; $i++) {	for (my $i=0; $i<=$#oldenv; $i++) {
chomp($oldenv[$i]);	chomp($oldenv[$i]);
Line 260 sub appenv {	Line 337 sub appenv {
return 'error';	return 'error';
}	}
my $newname;	my $newname;
flock($fh,'LOCK_EX');
foreach $newname (keys %newenv) {	foreach $newname (keys %newenv) {
print $fh "$newname=$newenv{$newname}\n";	print $fh "$newname=$newenv{$newname}\n";
}	}
$fh->close();	$fh->close();
}	}

	$lockfh->close();
return 'ok';	return 'ok';
}	}
# ----------------------------------------------------- Delete from Environment	# ----------------------------------------------------- Delete from Environment
Line 284 sub delenv {	Line 362 sub delenv {
unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {	unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
return 'error';	return 'error';
}	}
	unless (flock($fh,LOCK_SH)) {
	&logthis("<font color=blue>WARNING: ".
	'Could not obtain shared lock in delenv: '.$!);
	$fh->close();
	return 'error: '.$!;
	}
@oldenv=<$fh>;	@oldenv=<$fh>;
	$fh->close();
}	}
{	{
my $fh;	my $fh;
unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) {	unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) {
return 'error';	return 'error';
}	}
flock($fh,'LOCK_EX');	unless (flock($fh,LOCK_EX)) {
	&logthis("<font color=blue>WARNING: ".
	'Could not obtain exclusive lock in delenv: '.$!);
	$fh->close();
	return 'error: '.$!;
	}
map {	map {
unless ($_=~/^$delthis/) { print $fh $_; }	unless ($_=~/^$delthis/) { print $fh $_; }
} @oldenv;	} @oldenv;
Line 588 sub log {	Line 678 sub log {
return critical("log:$dom:$nam:$what",$hom);	return critical("log:$dom:$nam:$what",$hom);
}	}

	# ------------------------------------------------------------------ Course Log

	sub flushcourselogs {
	&logthis('Flushing course log buffers');
	map {
	my $crsid=$_;
	if (&reply('log:'.$ENV{'course.'.$crsid.'.domain'}.':'.
	$ENV{'course.'.$crsid.'.num'}.':'.
	&escape($courselogs{$crsid}),
	$ENV{'course.'.$crsid.'.home'}) eq 'ok') {
	delete $courselogs{$crsid};
	} else {
	&logthis('Failed to flush log buffer for '.$crsid);
	if (length($courselogs{$crsid})>40000) {
	&logthis("<font color=blue>WARNING: Buffer for ".$crsid.
	" exceeded maximum size, deleting.</font>");
	delete $courselogs{$crsid};
	}
	}
	} keys %courselogs;
	}

	sub courselog {
	my $what=shift;
	$what=time.':'.$what;
	unless ($ENV{'request.course.id'}) { return ''; }
	if (defined $courselogs{$ENV{'request.course.id'}}) {
	$courselogs{$ENV{'request.course.id'}}.='&'.$what;
	} else {
	$courselogs{$ENV{'request.course.id'}}.=$what;
	}
	if (length($courselogs{$ENV{'request.course.id'}})>4048) {
	&flushcourselogs();
	}
	}

	sub courseacclog {
	my $fnsymb=shift;
	unless ($ENV{'request.course.id'}) { return ''; }
	my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'};
	if ($what=~/(problem\|exam\|quiz\|assess\|survey\|form)$/) {
	map {
	if ($_=~/^form\.(.*)/) {
	$what.=':'.$1.'='.$ENV{$_};
	}
	} keys %ENV;
	}
	&courselog($what);
	}

	# ----------------------------------------------------------- Check out an item

	sub checkout {
	my ($symb,$tuname,$tudom,$tcrsid)=@_;
	my $now=time;
	my $lonhost=$perlvar{'lonHostID'};
	my $infostr=&escape(
	$tuname.'&'.
	$tudom.'&'.
	$tcrsid.'&'.
	$symb.'&'.
	$now.'&'.$ENV{'REMOTE_ADDR'});
	my $token=&reply('tmpput:'.$infostr,$lonhost);
	if ($token=~/^error\:/) {
	&logthis("<font color=blue>WARNING: ".
	"Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
	"</font>");
	return '';
	}

	$token=~s/^(\d+)\_.\_(\d+)$/$1\$2\*$lonhost/;
	$token=~tr/a-z/A-Z/;

	my %infohash=('resource.0.outtoken' => $token,
	'resource.0.checkouttime' => $now,
	'resource.0.outremote' => $ENV{'REMOTE_ADDR'});

	unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
	return '';
	} else {
	&logthis("<font color=blue>WARNING: ".
	"Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
	"</font>");
	}

	if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
	&escape('Checkout '.$infostr.' - '.
	$token)) ne 'ok') {
	return '';
	} else {
	&logthis("<font color=blue>WARNING: ".
	"Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
	"</font>");
	}
	return $token;
	}

	# ------------------------------------------------------------ Check in an item

	sub checkin {
	my $token=shift;
	my $now=time;
	my ($ta,$tb,$lonhost)=split(/\*/,$token);
	$lonhost=~tr/A-Z/a-z/;
	my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb;
	$dtoken=~s/\W/\_/g;
	my ($tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
	split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));

	unless (($tuname) && ($tudom)) {
	&logthis('Check in '.$token.' ('.$dtoken.') failed');
	return '';
	}

	unless (&allowed('mgr',$tcrsid)) {
	&logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.
	$ENV{'user.name'}.' - '.$ENV{'user.domain'});
	return '';
	}

	my %infohash=('resource.0.intoken' => $token,
	'resource.0.checkintime' => $now,
	'resource.0.inremote' => $ENV{'REMOTE_ADDR'});

	unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
	return '';
	}

	if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
	&escape('Checkin - '.$token)) ne 'ok') {
	return '';
	}

	return ($symb,$tuname,$tudom,$tcrsid);
	}

	# --------------------------------------------- Set Expire Date for Spreadsheet

	sub expirespread {
	my ($uname,$udom,$stype,$usymb)=@_;
	my $cid=$ENV{'request.course.id'};
	if ($cid) {
	my $now=time;
	my $key=$uname.':'.$udom.':'.$stype.':'.$usymb;
	return &reply('put:'.$ENV{'course.'.$cid.'.domain'}.':'.
	$ENV{'course.'.$cid.'.num'}.
	':nohist_expirationdates:'.
	&escape($key).'='.$now,
	$ENV{'course.'.$cid.'.home'})
	}
	return 'ok';
	}

	# ----------------------------------------------------- Devalidate Spreadsheets

	sub devalidate {
	my $symb=shift;
	my $cid=$ENV{'request.course.id'};
	if ($cid) {
	my $key=$ENV{'user.name'}.':'.$ENV{'user.domain'}.':';
	my $status=
	&del('nohist_calculatedsheet',
	[$key.'studentcalc'],
	$ENV{'course.'.$cid.'.domain'},
	$ENV{'course.'.$cid.'.num'})
	.' '.
	&del('nohist_calculatedsheets_'.$cid,
	[$key.'assesscalc:'.$symb]);
	unless ($status eq 'ok ok') {
	&logthis('Could not devalidate spreadsheet '.
	$ENV{'user.name'}.' at '.$ENV{'user.domain'}.' for '.
	$symb.': '.$status);
	}
	}
	}

# ----------------------------------------------------------------------- Store	# ----------------------------------------------------------------------- Store

sub store {	sub store {
my %storehash=@_;	my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
my $symb;	my $home='';
unless ($symb=escape(&symbread())) { return ''; }
my $namespace;	if ($stuname) {
unless ($namespace=$ENV{'request.course.id'}) { return ''; }	$home=&homeserver($stuname,$domain);
	}

	if (!$symb) { unless ($symb=&symbread()) { return ''; } }

	&devalidate($symb);

	$symb=escape($symb);
	if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { return ''; } }
	if (!$domain) { $domain=$ENV{'user.domain'}; }
	if (!$stuname) { $stuname=$ENV{'user.name'}; }
	if (!$home) { $home=$ENV{'user.home'}; }
my $namevalue='';	my $namevalue='';
map {	map {
$namevalue.=escape($_).'='.escape($storehash{$_}).'&';	$namevalue.=escape($_).'='.escape($$storehash{$_}).'&';
} keys %storehash;	} keys %$storehash;
$namevalue=~s/\&$//;	$namevalue=~s/\&$//;
return reply(	return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
"store:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb:$namevalue",
"$ENV{'user.home'}");
}	}

# -------------------------------------------------------------- Critical Store	# -------------------------------------------------------------- Critical Store

sub cstore {	sub cstore {
my %storehash=@_;	my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
my $symb;	my $home='';
unless ($symb=escape(&symbread())) { return ''; }
my $namespace;	if ($stuname) {
unless ($namespace=$ENV{'request.course.id'}) { return ''; }	$home=&homeserver($stuname,$domain);
	}

	if (!$symb) { unless ($symb=&symbread()) { return ''; } }

	&devalidate($symb);

	$symb=escape($symb);
	if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { return ''; } }
	if (!$domain) { $domain=$ENV{'user.domain'}; }
	if (!$stuname) { $stuname=$ENV{'user.name'}; }
	if (!$home) { $home=$ENV{'user.home'}; }

my $namevalue='';	my $namevalue='';
map {	map {
$namevalue.=escape($_).'='.escape($storehash{$_}).'&';	$namevalue.=escape($_).'='.escape($$storehash{$_}).'&';
} keys %storehash;	} keys %$storehash;
$namevalue=~s/\&$//;	$namevalue=~s/\&$//;
return critical(	return critical("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
"store:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb:$namevalue",
"$ENV{'user.home'}");
}	}

# --------------------------------------------------------------------- Restore	# --------------------------------------------------------------------- Restore

sub restore {	sub restore {
my $symb;	my ($symb,$namespace,$domain,$stuname) = @_;
unless ($symb=escape(&symbread())) { return ''; }	my $home='';
my $namespace;
unless ($namespace=$ENV{'request.course.id'}) { return ''; }	if ($stuname) {
my $answer=reply(	$home=&homeserver($stuname,$domain);
"restore:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb",	}
"$ENV{'user.home'}");
	if (!$symb) {
	unless ($symb=escape(&symbread())) { return ''; }
	} else {
	$symb=&escape($symb);
	}
	if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { return ''; } }
	if (!$domain) { $domain=$ENV{'user.domain'}; }
	if (!$stuname) { $stuname=$ENV{'user.name'}; }
	if (!$home) { $home=$ENV{'user.home'}; }
	my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");

my %returnhash=();	my %returnhash=();
map {	map {
my ($name,$value)=split(/\=/,$_);	my ($name,$value)=split(/\=/,$_);
Line 655 sub coursedescription {	Line 951 sub coursedescription {
$courseid=~s/^\///;	$courseid=~s/^\///;
$courseid=~s/\_/\//g;	$courseid=~s/\_/\//g;
my ($cdomain,$cnum)=split(/\//,$courseid);	my ($cdomain,$cnum)=split(/\//,$courseid);
my $chome=homeserver($cnum,$cdomain);	my $chome=&homeserver($cnum,$cdomain);
if ($chome ne 'no_host') {	if ($chome ne 'no_host') {
my $rep=reply("dump:$cdomain:$cnum:environment",$chome);	my %returnhash=&dump('environment',$cdomain,$cnum);
if ($rep ne 'con_lost') {	if (!exists($returnhash{'con_lost'})) {
my $normalid=$courseid;	my $normalid=$cdomain.'_'.$cnum;
$normalid=~s/\//\_/g;
my %envhash=();	my %envhash=();
my %returnhash=('home' => $chome,	$returnhash{'home'}= $chome;
'domain' => $cdomain,	$returnhash{'domain'} = $cdomain;
'num' => $cnum);	$returnhash{'num'} = $cnum;
map {	while (my ($name,$value) = each %returnhash) {
my ($name,$value)=split(/\=/,$_);
$name=&unescape($name);
$value=&unescape($value);
$returnhash{$name}=$value;
$envhash{'course.'.$normalid.'.'.$name}=$value;	$envhash{'course.'.$normalid.'.'.$name}=$value;
} split(/\&/,$rep);	}
$returnhash{'url'}='/res/'.declutter($returnhash{'url'});	$returnhash{'url'}='/res/'.declutter($returnhash{'url'});
$returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.	$returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
$ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;	$ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;
Line 686 sub coursedescription {	Line 977 sub coursedescription {
return ();	return ();
}	}

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

sub rolesinit {	sub rolesinit {
my ($domain,$username,$authhost)=@_;	my ($domain,$username,$authhost)=@_;
Line 756 sub rolesinit {	Line 1047 sub rolesinit {
}	}
}	}
} split(/&/,$rolesdump);	} split(/&/,$rolesdump);
	my $adv=0;
	my $author=0;
map {	map {
%thesepriv=();	%thesepriv=();
	if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; }
	if (($_=~/^au/) \|\| ($_=~/^ca/)) { $author=1; }
map {	map {
if ($_ ne '') {	if ($_ ne '') {
my ($priviledge,$restrictions)=split(/&/,$_);	my ($privilege,$restrictions)=split(/&/,$_);
if ($restrictions eq '') {	if ($restrictions eq '') {
$thesepriv{$priviledge}='F';	$thesepriv{$privilege}='F';
} else {	} else {
if ($thesepriv{$priviledge} ne 'F') {	if ($thesepriv{$privilege} ne 'F') {
$thesepriv{$priviledge}.=$restrictions;	$thesepriv{$privilege}.=$restrictions;
}	}
}	}
}	}
Line 774 sub rolesinit {	Line 1069 sub rolesinit {
map { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } keys %thesepriv;	map { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } keys %thesepriv;
$userroles.='user.priv.'.$_.'='.$thesestr."\n";	$userroles.='user.priv.'.$_.'='.$thesestr."\n";
} keys %allroles;	} keys %allroles;
	$userroles.='user.adv='.$adv."\n".
	'user.author='.$author."\n";
	$ENV{'user.adv'}=$adv;
}	}
return $userroles;	return $userroles;
}	}
Line 781 sub rolesinit {	Line 1079 sub rolesinit {
# --------------------------------------------------------------- get interface	# --------------------------------------------------------------- get interface

sub get {	sub get {
my ($namespace,@storearr)=@_;	my ($namespace,$storearr,$udomain,$uname)=@_;
my $items='';	my $items='';
map {	map {
$items.=escape($_).'&';	$items.=escape($_).'&';
} @storearr;	} @$storearr;
$items=~s/\&$//;	$items=~s/\&$//;
my $rep=reply("get:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",	if (!$udomain) { $udomain=$ENV{'user.domain'}; }
$ENV{'user.home'});	if (!$uname) { $uname=$ENV{'user.name'}; }
	my $uhome=&homeserver($uname,$udomain);

	my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome);
my @pairs=split(/\&/,$rep);	my @pairs=split(/\&/,$rep);
my %returnhash=();	my %returnhash=();
my $i=0;	my $i=0;
map {	map {
$returnhash{$_}=unescape($pairs[$i]);	$returnhash{$_}=unescape($pairs[$i]);
$i++;	$i++;
} @storearr;	} @$storearr;
return %returnhash;	return %returnhash;
}	}

# --------------------------------------------------------------- del interface	# --------------------------------------------------------------- del interface

sub del {	sub del {
my ($namespace,@storearr)=@_;	my ($namespace,$storearr,$udomain,$uname)=@_;
my $items='';	my $items='';
map {	map {
$items.=escape($_).'&';	$items.=escape($_).'&';
} @storearr;	} @$storearr;
$items=~s/\&$//;	$items=~s/\&$//;
return reply("del:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",	if (!$udomain) { $udomain=$ENV{'user.domain'}; }
$ENV{'user.home'});	if (!$uname) { $uname=$ENV{'user.name'}; }
	my $uhome=&homeserver($uname,$udomain);

	return &reply("del:$udomain:$uname:$namespace:$items",$uhome);
}	}

# -------------------------------------------------------------- dump interface	# -------------------------------------------------------------- dump interface

sub dump {	sub dump {
my $namespace=shift;	my ($namespace,$udomain,$uname)=@_;
my $rep=reply("dump:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace",	if (!$udomain) { $udomain=$ENV{'user.domain'}; }
$ENV{'user.home'});	if (!$uname) { $uname=$ENV{'user.name'}; }
	my $uhome=&homeserver($uname,$udomain);
	my $rep=reply("dump:$udomain:$uname:$namespace",$uhome);
my @pairs=split(/\&/,$rep);	my @pairs=split(/\&/,$rep);
my %returnhash=();	my %returnhash=();
map {	map {
Line 830 sub dump {	Line 1136 sub dump {
# --------------------------------------------------------------- put interface	# --------------------------------------------------------------- put interface

sub put {	sub put {
my ($namespace,%storehash)=@_;	my ($namespace,$storehash,$udomain,$uname)=@_;
	if (!$udomain) { $udomain=$ENV{'user.domain'}; }
	if (!$uname) { $uname=$ENV{'user.name'}; }
	my $uhome=&homeserver($uname,$udomain);
my $items='';	my $items='';
map {	map {
$items.=escape($_).'='.escape($storehash{$_}).'&';	$items.=&escape($_).'='.&escape($$storehash{$_}).'&';
} keys %storehash;	} keys %$storehash;
$items=~s/\&$//;	$items=~s/\&$//;
return reply("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",	return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
$ENV{'user.home'});
}	}

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

sub cput {	sub cput {
my ($namespace,%storehash)=@_;	my ($namespace,$storehash,$udomain,$uname)=@_;
	if (!$udomain) { $udomain=$ENV{'user.domain'}; }
	if (!$uname) { $uname=$ENV{'user.name'}; }
	my $uhome=&homeserver($uname,$udomain);
my $items='';	my $items='';
map {	map {
$items.=escape($_).'='.escape($storehash{$_}).'&';	$items.=escape($_).'='.escape($$storehash{$_}).'&';
} keys %storehash;	} keys %$storehash;
$items=~s/\&$//;	$items=~s/\&$//;
return critical	return &critical("put:$udomain:$uname:$namespace:$items",$uhome);
("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
$ENV{'user.home'});
}	}

# -------------------------------------------------------------- eget interface	# -------------------------------------------------------------- eget interface

sub eget {	sub eget {
my ($namespace,@storearr)=@_;	my ($namespace,$storearr,$udomain,$uname)=@_;
my $items='';	my $items='';
map {	map {
$items.=escape($_).'&';	$items.=escape($_).'&';
} @storearr;	} @$storearr;
$items=~s/\&$//;	$items=~s/\&$//;
my $rep=reply("eget:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",	if (!$udomain) { $udomain=$ENV{'user.domain'}; }
$ENV{'user.home'});	if (!$uname) { $uname=$ENV{'user.name'}; }
	my $uhome=&homeserver($uname,$udomain);
	my $rep=&reply("eget:$udomain:$uname:$namespace:$items",$uhome);
my @pairs=split(/\&/,$rep);	my @pairs=split(/\&/,$rep);
my %returnhash=();	my %returnhash=();
my $i=0;	my $i=0;
map {	map {
$returnhash{$_}=unescape($pairs[$i]);	$returnhash{$_}=unescape($pairs[$i]);
$i++;	$i++;
} @storearr;	} @$storearr;
return %returnhash;	return %returnhash;
}	}

# ------------------------------------------------- Check for a user priviledge	# ------------------------------------------------- Check for a user privilege

sub allowed {	sub allowed {
my ($priv,$uri)=@_;	my ($priv,$uri)=@_;

	my $orguri=$uri;
$uri=&declutter($uri);	$uri=&declutter($uri);

# Free bre access to adm and meta resources	# Free bre access to adm and meta resources
Line 887 sub allowed {	Line 1200 sub allowed {
return 'F';	return 'F';
}	}

	# Free bre to public access

	if ($priv eq 'bre') {
	if (&metadata($uri,'copyright') eq 'public') { return 'F'; }
	}

my $thisallowed='';	my $thisallowed='';
my $statecond=0;	my $statecond=0;
my $courseprivid='';	my $courseprivid='';
Line 926 sub allowed {	Line 1245 sub allowed {
return $thisallowed;	return $thisallowed;
}	}
#	#
# Gathered so far: system, domain and course wide priviledges	# Gathered so far: system, domain and course wide privileges
#	#
# Course: See if uri or referer is an individual resource that is part of	# Course: See if uri or referer is an individual resource that is part of
# the course	# the course
Line 952 sub allowed {	Line 1271 sub allowed {
}	}
}	}

if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {	if ($checkreferer) {
my $refuri=$ENV{'HTTP_REFERER'};	my $refuri=$ENV{'httpref.'.$orguri};
$refuri=~s/^http\:\/\/$ENV{'request.host'}//i;
$refuri=&declutter($refuri);	unless ($refuri) {
	map {
	if ($_=~/^httpref\..\/) {
	my $pattern=$_;
	$pattern=~s/^httpref\.\/res\///;
	$pattern=~s/\*/\[\^\/\]\+/g;
	$pattern=~s/\//\\\//g;
	if ($orguri=~/$pattern/) {
	$refuri=$ENV{$_};
	}
	}
	} keys %ENV;
	}
	if ($refuri) {
	$refuri=&declutter($refuri);
my @uriparts=split(/\//,$refuri);	my @uriparts=split(/\//,$refuri);
my $filename=$uriparts[$#uriparts];	my $filename=$uriparts[$#uriparts];
my $pathname=$refuri;	my $pathname=$refuri;
$pathname=~s/\/$filename$//;	$pathname=~s/\/$filename$//;
my @filenameparts=split(/\./,$uri);
if (&fileembstyle($filenameparts[$#filenameparts]) ne 'ssi') {
if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~	if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
/\&$filename\:([\d\\|]+)\&/) {	/\&$filename\:([\d\\|]+)\&/) {
my $refstatecond=$1;	my $refstatecond=$1;
Line 971 sub allowed {	Line 1302 sub allowed {
$uri=$refuri;	$uri=$refuri;
$statecond=$refstatecond;	$statecond=$refstatecond;
}	}
}
}	}
	}
}	}
}	}

#	#
# Gathered now: all priviledges that could apply, and condition number	# Gathered now: all privileges that could apply, and condition number
#	#
#	#
# Full or no access?	# Full or no access?
Line 1009 sub allowed {	Line 1340 sub allowed {
if ($envkey=~/^user\.role\.(st\|ta)\.([^\.]*)/) {	if ($envkey=~/^user\.role\.(st\|ta)\.([^\.]*)/) {
my $courseid=$2;	my $courseid=$2;
my $roleid=$1.'.'.$2;	my $roleid=$1.'.'.$2;
	$courseid=~s/^\///;
my $expiretime=600;	my $expiretime=600;
if ($ENV{'request.role'} eq $roleid) {	if ($ENV{'request.role'} eq $roleid) {
$expiretime=120;	$expiretime=120;
Line 1146 sub definerole {	Line 1478 sub definerole {
}	}
}	}

	# ---------------- Make a metadata query against the network of library servers

	sub metadata_query {
	my ($query,$custom,$customshow)=@_;
	# need to put in a library server loop here and return a hash
	my %rhash;
	for my $server (keys %libserv) {
	unless ($custom or $customshow) {
	my $reply=&reply("querysend:".&escape($query),$server);
	$rhash{$server}=$reply;
	}
	else {
	my $reply=&reply("querysend:".&escape($query).':'.
	&escape($custom).':'.&escape($customshow),
	$server);
	$rhash{$server}=$reply;
	}
	}
	return \%rhash;
	}

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

sub plaintext {	sub plaintext {
Line 1173 sub assignrole {	Line 1526 sub assignrole {
my ($udom,$uname,$url,$role,$end,$start)=@_;	my ($udom,$uname,$url,$role,$end,$start)=@_;
my $mrole;	my $mrole;
if ($role =~ /^cr\//) {	if ($role =~ /^cr\//) {
unless (&allowed('ccr',$url)) { return 'refused'; }	unless (&allowed('ccr',$url)) {
	&logthis('Refused custom assignrole: '.
	$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
	$ENV{'user.name'}.' at '.$ENV{'user.domain'});
	return 'refused';
	}
$mrole='cr';	$mrole='cr';
} else {	} else {
my $cwosec=$url;	my $cwosec=$url;
$cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;	$cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
unless (&allowed('c'.$role,$cwosec)) { return 'refused'; }	unless (&allowed('c'.$role,$cwosec)) {
	&logthis('Refused assignrole: '.
	$udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
	$ENV{'user.name'}.' at '.$ENV{'user.domain'});
	return 'refused';
	}
$mrole=$role;	$mrole=$role;
}	}
my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".	my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
Line 1248 sub modifyuser {	Line 1611 sub modifyuser {
}	}
}	}
# -------------------------------------------------------------- Add names, etc	# -------------------------------------------------------------- Add names, etc
my $names=&reply('get:'.$udom.':'.$uname.	my %names=&get('environment',
':environment:firstname&middlename&lastname&generation',	['firstname','middlename','lastname','generation'],
$uhome);	$udom,$uname);
my ($efirst,$emiddle,$elast,$egene)=split(/\&/,$names);	if ($first) { $names{'firstname'} = $first; }
if ($first) { $efirst = &escape($first); }	if ($middle) { $names{'middlename'} = $middle; }
if ($middle) { $emiddle = &escape($middle); }	if ($last) { $names{'lastname'} = $last; }
if ($last) { $elast = &escape($last); }	if ($gene) { $names{'generation'} = $gene; }
if ($gene) { $egene = &escape($gene); }	my $reply = &put('environment', \%names, $udom,$uname);
my $reply=&reply('put:'.$udom.':'.$uname.	if ($reply ne 'ok') { return 'error: '.$reply; }
':environment:firstname='.$efirst.
'&middlename='.$emiddle.
'&lastname='.$elast.
'&generation='.$egene,$uhome);
if ($reply ne 'ok') {
return 'error: '.$reply;
}
&logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.	&logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
$umode.', '.$first.', '.$middle.', '.	$umode.', '.$first.', '.$middle.', '.
$last.', '.$gene.' by '.	$last.', '.$gene.' by '.
$ENV{'user.name'}.' at '.$ENV{'user.domain'});	$ENV{'user.name'}.' at '.$ENV{'user.domain'});
return 'ok';	return 'ok';
}	}

# -------------------------------------------------------------- Modify student	# -------------------------------------------------------------- Modify student
Line 1289 sub modifystudent {	Line 1645 sub modifystudent {
return 'error: no such user';	return 'error: no such user';
}	}
# -------------------------------------------------- Add student to course list	# -------------------------------------------------- Add student to course list
my $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'.	$reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'.
$ENV{'course.'.$cid.'.num'}.':classlist:'.	$ENV{'course.'.$cid.'.num'}.':classlist:'.
&escape($uname.':'.$udom).'='.	&escape($uname.':'.$udom).'='.
&escape($end.':'.$start),	&escape($end.':'.$start),
Line 1354 sub createcourse {	Line 1710 sub createcourse {
my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',	my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
$ENV{'user.home'});	$ENV{'user.home'});
unless ($reply eq 'ok') { return 'error: '.$reply; }	unless ($reply eq 'ok') { return 'error: '.$reply; }
my $uhome=&homeserver($uname,$udom);	$uhome=&homeserver($uname,$udom);
if (($uhome eq '') \|\| ($uhome eq 'no_host')) {	if (($uhome eq '') \|\| ($uhome eq 'no_host')) {
return 'error: no such course';	return 'error: no such course';
}	}
Line 1493 sub condval {	Line 1849 sub condval {
# --------------------------------------------------------- Value of a Variable	# --------------------------------------------------------- Value of a Variable

sub EXT {	sub EXT {
my $varname=shift;	my ($varname,$symbparm)=@_;
unless ($varname) { return ''; }	unless ($varname) { return ''; }
my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);	my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
my $rest;	my $rest;
Line 1509 sub EXT {	Line 1865 sub EXT {
if ($realm eq 'user') {	if ($realm eq 'user') {
# --------------------------------------------------------------- user.resource	# --------------------------------------------------------------- user.resource
if ($space eq 'resource') {	if ($space eq 'resource') {
my %restored=&restore;	my %restored=&restore();
return $restored{$qualifierrest};	return $restored{$qualifierrest};
# ----------------------------------------------------------------- user.access	# ----------------------------------------------------------------- user.access
} elsif ($space eq 'access') {	} elsif ($space eq 'access') {
Line 1537 sub EXT {	Line 1893 sub EXT {
# ---------------------------------------------------- Any other user namespace	# ---------------------------------------------------- Any other user namespace
} else {	} else {
my $item=($rest)?$qualifier.'.'.$rest:$qualifier;	my $item=($rest)?$qualifier.'.'.$rest:$qualifier;
my %reply=&get($space,$item);	my %reply=&get($space,[$item]);
return $reply{$item};	return $reply{$item};
}	}
} elsif ($realm eq 'request') {	} elsif ($realm eq 'request') {
Line 1550 sub EXT {	Line 1906 sub EXT {
}	}
} elsif ($realm eq 'course') {	} elsif ($realm eq 'course') {
# ---------------------------------------------------------- course.description	# ---------------------------------------------------------- course.description
my $section='';	return $ENV{'course.'.$ENV{'request.course.id'}.'.'.
if ($ENV{'request.course.sec'}) {
$section='_'.$ENV{'request.course.sec'};
}
return $ENV{'course.'.$ENV{'request.course.id'}.$section.'.'.
$spacequalifierrest};	$spacequalifierrest};
} elsif ($realm eq 'resource') {	} elsif ($realm eq 'resource') {
if ($ENV{'request.course.id'}) {	if ($ENV{'request.course.id'}) {

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


# ----------------------------------------------------- Cascading lookup scheme	# ----------------------------------------------------- Cascading lookup scheme
my $symbp=&symbread();	my $symbp;
my $mapp=(split(/\_\_\_/,$symbp))[0];	if ($symbparm) {
	$symbp=$symbparm;
	} else {
	$symbp=&symbread();
	}
	my $mapp=(split(/\_\_\_/,$symbp))[0];

my $symbparm=$symbp.'.'.$spacequalifierrest;	my $symbparm=$symbp.'.'.$spacequalifierrest;
my $mapparm=$mapp.'___(all).'.$spacequalifierrest;	my $mapparm=$mapp.'___(all).'.$spacequalifierrest;

my $seclevel=	my $seclevel=
$ENV{'request.course.id'}.'.['.	$ENV{'request.course.id'}.'.['.
$ENV{'request.course.sec'}.'].'.$spacequalifierrest;	$ENV{'request.course.sec'}.'].'.$spacequalifierrest;
my $seclevelr=	my $seclevelr=
$ENV{'request.course.id'}.'.['.	$ENV{'request.course.id'}.'.['.
$ENV{'request.course.sec'}.'].'.$symbparm;	$ENV{'request.course.sec'}.'].'.$symbparm;
my $seclevelm=	my $seclevelm=
$ENV{'request.course.id'}.'.['.	$ENV{'request.course.id'}.'.['.
$ENV{'request.course.sec'}.'].'.$mapparm;	$ENV{'request.course.sec'}.'].'.$mapparm;

my $courselevel=	my $courselevel=
$ENV{'request.course.id'}.'.'.$spacequalifierrest;	$ENV{'request.course.id'}.'.'.$spacequalifierrest;
my $courselevelr=	my $courselevelr=
$ENV{'request.course.id'}.'.'.$symbparm;	$ENV{'request.course.id'}.'.'.$symbparm;
my $courselevelm=	my $courselevelm=
$ENV{'request.course.id'}.'.'.$mapparm;	$ENV{'request.course.id'}.'.'.$mapparm;


# ----------------------------------------------------------- first, check user	# ----------------------------------------------------------- first, check user
my %resourcedata=get('resourcedata',	my %resourcedata=get('resourcedata',
($courselevelr,$courselevelm,$courselevel));	[$courselevelr,$courselevelm,$courselevel]);
if ($resourcedata{$courselevelr}!~/^error\:/) {	if (($resourcedata{$courselevelr}!~/^error\:/) &&
	($resourcedata{$courselevelr}!~/^con_lost/)) {
if ($resourcedata{$courselevelr}) {
return $resourcedata{$courselevelr}; }	if ($resourcedata{$courselevelr}) {
if ($resourcedata{$courselevelm}) {	return $resourcedata{$courselevelr}; }
return $resourcedata{$courselevelm}; }	if ($resourcedata{$courselevelm}) {
if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }	return $resourcedata{$courselevelm}; }
	if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }

	} else {
	if ($resourcedata{$courselevelr}!~/No such file/) {
	&logthis("<font color=blue>WARNING:".
	" Trying to get resource data for ".$ENV{'user.name'}." at "
	.$ENV{'user.domain'}.": ".$resourcedata{$courselevelr}.
	"</font>");
	}
}	}

# -------------------------------------------------------- second, check course	# -------------------------------------------------------- second, check course
my $section='';
if ($ENV{'request.course.sec'}) {
$section='_'.$ENV{'request.course.sec'};
}
my $reply=&reply('get:'.	my $reply=&reply('get:'.
$ENV{'course.'.$ENV{'request.course.id'}.$section.'.domain'}.':'.	$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.
$ENV{'course.'.$ENV{'request.course.id'}.$section.'.num'}.	$ENV{'course.'.$ENV{'request.course.id'}.'.num'}.
':resourcedata:'.	':resourcedata:'.
&escape($seclevelr).'&'.&escape($seclevelm).'&'.&escape($seclevel).'&'.	&escape($seclevelr).'&'.&escape($seclevelm).'&'.&escape($seclevel).'&'.
&escape($courselevelr).'&'.&escape($courselevelm).'&'.&escape($courselevel),	&escape($courselevelr).'&'.&escape($courselevelm).'&'.&escape($courselevel),
$ENV{'course.'.$ENV{'request.course.id'}.$section.'.home'});	$ENV{'course.'.$ENV{'request.course.id'}.'.home'});
if ($reply!~/^error\:/) {	if ($reply!~/^error\:/) {
map {	map {
if ($_) { return &unescape($_); }	if ($_) { return &unescape($_); }
} split(/\&/,$reply);	} split(/\&/,$reply);
}	}
	if (($reply=~/^con_lost/) \|\| ($reply=~/^error\:/)) {
	&logthis("<font color=blue>WARNING:".
	" Getting ".$reply." asking for ".$varname." for ".
	$ENV{'course.'.$ENV{'request.course.id'}.'.num'}.
	' at '.
	$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.
	' from '.
	$ENV{'course.'.$ENV{'request.course.id'}.'.home'}.
	"</font>");
	}
# ------------------------------------------------------ third, check map parms	# ------------------------------------------------------ third, check map parms
my %parmhash=();	my %parmhash=();
my $thisparm='';	my $thisparm='';
Line 1633 sub EXT {	Line 2008 sub EXT {
'parameter_'.$spacequalifierrest);	'parameter_'.$spacequalifierrest);
if ($metadata) { return $metadata; }	if ($metadata) { return $metadata; }

	# ------------------------------------------------------------------ Cascade up

	unless ($space eq '0') {
	my ($part,$id)=split(/\_/,$space);
	if ($id) {
	my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
	$symbparm);
	if ($partgeneral) { return $partgeneral; }
	} else {
	my $resourcegeneral=&EXT('resource.0.'.$qualifierrest,
	$symbparm);
	if ($resourcegeneral) { return $resourcegeneral; }
	}
	}

# ---------------------------------------------------- Any other user namespace	# ---------------------------------------------------- Any other user namespace
} elsif ($realm eq 'environment') {	} elsif ($realm eq 'environment') {
# ----------------------------------------------------------------- environment	# ----------------------------------------------------------------- environment
return $ENV{$spacequalifierrest};	return $ENV{'environment.'.$spacequalifierrest};
} elsif ($realm eq 'system') {	} elsif ($realm eq 'system') {
# ----------------------------------------------------------------- system.time	# ----------------------------------------------------------------- system.time
if ($space eq 'time') {	if ($space eq 'time') {
Line 1655 sub metadata {	Line 2045 sub metadata {
my $filename=$uri;	my $filename=$uri;
$uri=~s/\.meta$//;	$uri=~s/\.meta$//;
unless ($metacache{$uri.':keys'}) {	unless ($metacache{$uri.':keys'}) {
	my %metathesekeys=();
unless ($filename=~/\.meta$/) { $filename.='.meta'; }	unless ($filename=~/\.meta$/) { $filename.='.meta'; }
my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);	my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
my $parser=HTML::TokeParser->new(\$metastring);	my $parser=HTML::TokeParser->new(\$metastring);
my $token;	my $token;
	undef %metathesekeys;
while ($token=$parser->get_token) {	while ($token=$parser->get_token) {
if ($token->[0] eq 'S') {	if ($token->[0] eq 'S') {
	if (defined($token->[2]->{'package'})) {
	my $package=$token->[2]->{'package'};
	my $keyroot='';
	if (defined($token->[2]->{'part'})) {
	$keyroot.='_'.$token->[2]->{'part'};
	}
	if (defined($token->[2]->{'id'})) {
	$keyroot.='_'.$token->[2]->{'id'};
	}
	if ($metacache{$uri.':packages'}) {
	$metacache{$uri.':packages'}.=','.$package.$keyroot;
	} else {
	$metacache{$uri.':packages'}=$package.$keyroot;
	}
	map {
	if ($_=~/^$package\&/) {
	my ($pack,$name,$subp)=split(/\&/,$_);
	my $value=$packagetab{$_};
	my $part=$keyroot;
	$part=~s/^\_//;
	if ($subp eq 'display') {
	$value.=' [Part: '.$part.']';
	}
	my $unikey='parameter'.$keyroot.'_'.$name;
	$metathesekeys{$unikey}=1;
	$metacache{$uri.':'.$unikey.'.part'}=$part;
	unless
	(defined($metacache{$uri.':'.$unikey.'.'.$subp})) {
	$metacache{$uri.':'.$unikey.'.'.$subp}=$value;
	}
	}
	} keys %packagetab;
	} else {
my $entry=$token->[1];	my $entry=$token->[1];
my $unikey=$entry;	my $unikey=$entry;
if (defined($token->[2]->{'part'})) {	if (defined($token->[2]->{'part'})) {
$unikey.='_'.$token->[2]->{'part'};	$unikey.='_'.$token->[2]->{'part'};
}	}
	if (defined($token->[2]->{'id'})) {
	$unikey.='_'.$token->[2]->{'id'};
	}
if (defined($token->[2]->{'name'})) {	if (defined($token->[2]->{'name'})) {
$unikey.='_'.$token->[2]->{'name'};	$unikey.='_'.$token->[2]->{'name'};
}	}
if ($metacache{$uri.':keys'}) {	$metathesekeys{$unikey}=1;
$metacache{$uri.':keys'}.=','.$unikey;
} else {
$metacache{$uri.':keys'}=$unikey;
}
map {	map {
$metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};	$metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};
} @{$token->[3]};	} @{$token->[3]};
Line 1682 sub metadata {	Line 2106 sub metadata {
) { $metacache{$uri.':'.$unikey}=	) { $metacache{$uri.':'.$unikey}=
$metacache{$uri.':'.$unikey.'.default'};	$metacache{$uri.':'.$unikey.'.default'};
}	}
}	}
	}
}	}
	$metacache{$uri.':keys'}=join(',',keys %metathesekeys);
}	}
return $metacache{$uri.':'.$what};	return $metacache{$uri.':'.$what};
}	}
Line 1793 sub numval {	Line 2219 sub numval {
}	}

sub rndseed {	sub rndseed {
my $symb;	my ($symb,$courseid,$domain,$username)=@_;
unless ($symb=&symbread()) { return time; }	if (!$symb) {
my $symbchck=unpack("%32C*",$symb);	unless ($symb=&symbread()) { return time; }
my $symbseed=numval($symb)%$symbchck;	}
my $namechck=unpack("%32C*",$ENV{'user.name'});	if (!$courseid) { $courseid=$ENV{'request.course.id'};}
my $nameseed=numval($ENV{'user.name'})%$namechck;	if (!$domain) {$domain=$ENV{'user.domain'};}
return int( $symbseed	if (!$username) {$username=$ENV{'user.name'};}
.$nameseed	{
.unpack("%32C*",$ENV{'user.domain'})	use integer;
.unpack("%32C*",$ENV{'request.course.id'})	my $symbchck=unpack("%32C*",$symb) << 27;
.$namechck	my $symbseed=numval($symb) << 22;
.$symbchck);	my $namechck=unpack("%32C*",$username) << 17;
	my $nameseed=numval($username) << 12;
	my $domainseed=unpack("%32C*",$domain) << 7;
	my $courseseed=unpack("%32C*",$courseid);
	my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
	#uncommenting these lines can break things!
	#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed\|$courseseed;$namechck:$symbchck");
	#&Apache::lonxml::debug("rndseed :$num:$symb");
	return $num;
	}
}	}

sub ireceipt {	sub ireceipt {
Line 1901 sub unescape {	Line 2336 sub unescape {
# ================================================================ Main Program	# ================================================================ Main Program

sub BEGIN {	sub BEGIN {
if ($readit ne 'done') {	unless ($readit) {
# ------------------------------------------------------------ Read access.conf	# ------------------------------------------------------------ Read access.conf
{	{
my $config=Apache::File->new("/etc/httpd/conf/access.conf");	my $config=Apache::File->new("/etc/httpd/conf/access.conf");
Line 1920 if ($readit ne 'done') {	Line 2355 if ($readit ne 'done') {
my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");	my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");

while (my $configline=<$config>) {	while (my $configline=<$config>) {
	chomp($configline);
my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);	my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
$hostname{$id}=$name;	$hostname{$id}=$name;
$hostdom{$id}=$domain;	$hostdom{$id}=$domain;
	$hostip{$id}=$ip;
if ($role eq 'library') { $libserv{$id}=$name; }	if ($role eq 'library') { $libserv{$id}=$name; }
}	}
}	}
Line 1944 if ($readit ne 'done') {	Line 2381 if ($readit ne 'done') {

while (my $configline=<$config>) {	while (my $configline=<$config>) {
chomp($configline);	chomp($configline);
	if ($configline) {
my ($role,$perm)=split(/ /,$configline);	my ($role,$perm)=split(/ /,$configline);
if ($perm ne '') { $pr{$role}=$perm; }	if ($perm ne '') { $pr{$role}=$perm; }
	}
}	}
}	}

Line 1955 if ($readit ne 'done') {	Line 2394 if ($readit ne 'done') {

while (my $configline=<$config>) {	while (my $configline=<$config>) {
chomp($configline);	chomp($configline);
	if ($configline) {
my ($short,$plain)=split(/:/,$configline);	my ($short,$plain)=split(/:/,$configline);
if ($plain ne '') { $prp{$short}=$plain; }	if ($plain ne '') { $prp{$short}=$plain; }
	}
	}
	}

	# ---------------------------------------------------------- Read package table
	{
	my $config=Apache::File->new("$perlvar{'lonTabDir'}/packages.tab");

	while (my $configline=<$config>) {
	chomp($configline);
	my ($short,$plain)=split(/:/,$configline);
	my ($pack,$name)=split(/\&/,$short);
	if ($plain ne '') {
	$packagetab{$pack.'&'.$name.'&name'}=$name;
	$packagetab{$short}=$plain;
	}
}	}
}	}

Line 1977 if ($readit ne 'done') {	Line 2433 if ($readit ne 'done') {
%metacache=();	%metacache=();

$readit='done';	$readit='done';
	&logtouch();
&logthis('<font color=yellow>INFO: Read configuration</font>');	&logthis('<font color=yellow>INFO: Read configuration</font>');
}	}
}	}

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

500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.

Removed from v.1.87
changed lines
	Added in v.1.165