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.133 and 1.162

version 1.133, 2001/07/26 21:40:27	version 1.162, 2001/10/06 20:57:45
Line 42	Line 42
# current enviroment	# current enviroment
#	#
#	#
# for the next 4 functions udom and uname are optional	# for the next 6 functions udom and uname are optional
# if supplied they use udom as the domain and uname	# if supplied they use udom as the domain and uname
# as the username for the function (supply a courseid	# as the username for the function (supply a courseid
# for the uname if you want a course database)	# for the uname if you want a course database)
Line 57	Line 57
# in from namesp	# in from namesp
# dump(namesp,udom,uname) : dumps the complete namespace into a hash	# dump(namesp,udom,uname) : dumps the complete namespace into a hash
# del(namesp,array,udom,uname) : deletes keys out of array from namesp	# 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
#	#
#	#
# put(namesp,hash) : stores hash in namesp
# cput(namesp,hash) : 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 72	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
Line 113	Line 118
# 05/01,06/01,09/01 Gerd Kortemeyer	# 05/01,06/01,09/01 Gerd Kortemeyer
# 09/01 Guy Albertelli	# 09/01 Guy Albertelli
# 09/01,10/01,11/01 Gerd Kortemeyer	# 09/01,10/01,11/01 Gerd Kortemeyer
	# YEAR=2001
# 02/27/01 Scott Harrison	# 02/27/01 Scott Harrison
# 3/2 Gerd Kortemeyer	# 3/2 Gerd Kortemeyer
# 3/15,3/19 Scott Harrison	# 3/15,3/19 Scott Harrison
Line 121	Line 127
# 5/26,5/28 Gerd Kortemeyer	# 5/26,5/28 Gerd Kortemeyer
# 5/30 H. K. Ng	# 5/30 H. K. Ng
# 6/1 Gerd Kortemeyer	# 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 Scott Harrison

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

Line 130 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);
Line 275 sub appenv {	Line 284 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{$_};
Line 658 sub log {	Line 668 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	# --------------------------------------------- Set Expire Date for Spreadsheet

sub expirespread {	sub expirespread {
Line 895 sub rolesinit {	Line 1041 sub rolesinit {
my $author=0;	my $author=0;
map {	map {
%thesepriv=();	%thesepriv=();
if ($_!~/^st/) { $adv=1; }	if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; }
if (($_=~/^au/) \|\| ($_=~/^ca/)) { $author=1; }	if (($_=~/^au/) \|\| ($_=~/^ca/)) { $author=1; }
map {	map {
if ($_ ne '') {	if ($_ ne '') {
Line 980 sub dump {	Line 1126 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
Line 1031 sub eget {	Line 1180 sub eget {

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 1039 sub allowed {	Line 1190 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 1104 sub allowed {	Line 1261 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 1123 sub allowed {	Line 1292 sub allowed {
$uri=$refuri;	$uri=$refuri;
$statecond=$refstatecond;	$statecond=$refstatecond;
}	}
}
}	}
	}
}	}
}	}

Line 1432 sub modifyuser {	Line 1601 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 1473 sub modifystudent {	Line 1635 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 1538 sub createcourse {	Line 1700 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 1677 sub condval {	Line 1839 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 1738 sub EXT {	Line 1900 sub EXT {
$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;
	if ($symbparm) {
	$symbp=$symbparm;
	} else {
	$symbp=&symbread();
	}
my $mapp=(split(/\_\_\_/,$symbp))[0];	my $mapp=(split(/\_\_\_/,$symbp))[0];

my $symbparm=$symbp.'.'.$spacequalifierrest;	my $symbparm=$symbp.'.'.$spacequalifierrest;
Line 1827 sub EXT {	Line 1998 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
Line 1849 sub metadata {	Line 2035 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 1876 sub metadata {	Line 2096 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 1987 sub numval {	Line 2209 sub numval {
}	}

sub rndseed {	sub rndseed {
my $symb;	my ($symb,$courseid,$domain,$username)=@_;
unless ($symb=&symbread()) { return time; }	if (!$symb) {
{	unless ($symb=&symbread()) { return time; }
	}
	if (!$courseid) { $courseid=$ENV{'request.course.id'};}
	if (!$domain) {$domain=$ENV{'user.domain'};}
	if (!$username) {$username=$ENV{'user.name'};}
	{
use integer;	use integer;
my $symbchck=unpack("%32C*",$symb) << 27;	my $symbchck=unpack("%32C*",$symb) << 27;
my $symbseed=numval($symb) << 22;	my $symbseed=numval($symb) << 22;
my $namechck=unpack("%32C*",$ENV{'user.name'}) << 17;	my $namechck=unpack("%32C*",$username) << 17;
my $nameseed=numval($ENV{'user.name'}) << 12;	my $nameseed=numval($username) << 12;
my $domainseed=unpack("%32C*",$ENV{'user.domain'}) << 7;	my $domainseed=unpack("%32C*",$domain) << 7;
my $courseseed=unpack("%32C*",$ENV{'request.course.id'});	my $courseseed=unpack("%32C*",$courseid);
my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;	my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
#uncommenting these lines can break things!	#uncommenting these lines can break things!
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed\|$courseseed;$namechck:$symbchck");	#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed\|$courseseed;$namechck:$symbchck");
Line 2099 sub unescape {	Line 2326 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 2118 if ($readit ne 'done') {	Line 2345 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 2142 if ($readit ne 'done') {	Line 2371 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 2153 if ($readit ne 'done') {	Line 2384 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;
	}
}	}
}	}

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

Removed from v.1.133
changed lines
	Added in v.1.162