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

version 1.137, 2001/08/04 14:45:28	version 1.162, 2001/10/06 20:57:45
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 122	Line 128
# 5/30 H. K. Ng	# 5/30 H. K. Ng
# 6/1 Gerd Kortemeyer	# 6/1 Gerd Kortemeyer
# July Guy Albertelli	# July Guy Albertelli
# 8/4 Gerd Kortemeyer	# 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 131 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 %packagetab);	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 276 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 659 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 896 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 1035 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 1043 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 1108 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 1127 sub allowed {	Line 1292 sub allowed {
$uri=$refuri;	$uri=$refuri;
$statecond=$refstatecond;	$statecond=$refstatecond;
}	}
}
}	}
	}
}	}
}	}

Line 1470 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 1535 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 1674 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 1735 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 1824 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 1846 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'})) {	if (defined($token->[2]->{'package'})) {
my $package=$token->[2]->{'package'};	my $package=$token->[2]->{'package'};
my %thispackagekeys=();
my $keyroot='';	my $keyroot='';
if (defined($token->[2]->{'part'})) {	if (defined($token->[2]->{'part'})) {
$keyroot.='_'.$token->[2]->{'part'};	$keyroot.='_'.$token->[2]->{'part'};
Line 1867 sub metadata {	Line 2057 sub metadata {
} else {	} else {
$metacache{$uri.':packages'}=$package.$keyroot;	$metacache{$uri.':packages'}=$package.$keyroot;
}	}
undef %thispackagekeys;
map {	map {
if ($_=~/^$package\&/) {	if ($_=~/^$package\&/) {
my ($pack,$name,$subp)=split(/\&/,$_);	my ($pack,$name,$subp)=split(/\&/,$_);
my $unikey='parameter_'.$keyroot.'_'.$name;	my $value=$packagetab{$_};
$thispackagekeys{$unikey}=1;	my $part=$keyroot;
$metacache{$uri.':'.$unikey.'.'.$subp}=$packagetab{$_};	$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;	} keys %packagetab;
my $addpackagekeys=join(',',keys %thispackagekeys);
if ($metacache{$uri.':keys'}) {
$metacache{$uri.':keys'}.=','.$addpackagekeys;
} else {
$metacache{$uri.':keys'}=$addpackagekeys;
}
} else {	} else {
my $entry=$token->[1];	my $entry=$token->[1];
my $unikey=$entry;	my $unikey=$entry;
Line 1894 sub metadata {	Line 2087 sub metadata {
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 1908 sub metadata {	Line 2097 sub metadata {
$metacache{$uri.':'.$unikey.'.default'};	$metacache{$uri.':'.$unikey.'.default'};
}	}
}	}
}	}
}	}
	$metacache{$uri.':keys'}=join(',',keys %metathesekeys);
}	}
return $metacache{$uri.':'.$what};	return $metacache{$uri.':'.$what};
}	}
Line 2019 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 2131 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 2150 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 2174 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 2185 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; }
	}
}	}
}	}

Line 2197 if ($readit ne 'done') {	Line 2398 if ($readit ne 'done') {
while (my $configline=<$config>) {	while (my $configline=<$config>) {
chomp($configline);	chomp($configline);
my ($short,$plain)=split(/:/,$configline);	my ($short,$plain)=split(/:/,$configline);
if ($plain ne '') { $packagetab{$short}=$plain; }	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.137
changed lines
	Added in v.1.162