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.145 and 1.164

version 1.145, 2001/08/09 14:03:42	version 1.164, 2001/10/16 08:53:19
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,8/7,8/8,8/9 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,10/10 Scott Harrison
	# 10/15 Gerd Kortemeyer

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

Line 131 use Apache::File;	Line 140 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 140 use Fcntl qw(:flock);	Line 149 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 276 sub appenv {	Line 295 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 679 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 1052 sub rolesinit {
my $author=0;	my $author=0;
map {	map {
%thesepriv=();	%thesepriv=();
if (($_!~/^st/) && ($_!~/^ta/)) { $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 1191 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 1201 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 1272 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 1303 sub allowed {
$uri=$refuri;	$uri=$refuri;
$statecond=$refstatecond;	$statecond=$refstatecond;
}	}
}
}	}
	}
}	}
}	}

Line 1470 sub modifystudent {	Line 1646 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 1711 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 1850 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 1911 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 1831 sub EXT {	Line 2008 sub EXT {
# ------------------------------------------------------------------ Cascade up	# ------------------------------------------------------------------ Cascade up

unless ($space eq '0') {	unless ($space eq '0') {
my ($part,$id)=split(/\_/,$space);	my ($part,$id)=split(/(\.\|\_)/,$space);
if ($id) {	if ($id) {
my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest);	my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
	$symbparm);
if ($partgeneral) { return $partgeneral; }	if ($partgeneral) { return $partgeneral; }
} else {	} else {
my $resourcegeneral=&EXT('resource.0.'.$qualifierrest);	my $resourcegeneral=&EXT('resource.0.'.$qualifierrest,
	$symbparm);
if ($resourcegeneral) { return $resourcegeneral; }	if ($resourcegeneral) { return $resourcegeneral; }
}	}
}	}
Line 1878 sub metadata {	Line 2057 sub metadata {
$keyroot.='_'.$token->[2]->{'part'};	$keyroot.='_'.$token->[2]->{'part'};
}	}
if (defined($token->[2]->{'id'})) {	if (defined($token->[2]->{'id'})) {
$keyroot.='_'.$token->[2]->{'id'};	$keyroot.='.'.$token->[2]->{'id'};
}	}
if ($metacache{$uri.':packages'}) {	if ($metacache{$uri.':packages'}) {
$metacache{$uri.':packages'}.=','.$package.$keyroot;	$metacache{$uri.':packages'}.=','.$package.$keyroot;
Line 1891 sub metadata {	Line 2070 sub metadata {
my $value=$packagetab{$_};	my $value=$packagetab{$_};
my $part=$keyroot;	my $part=$keyroot;
$part=~s/^\_//;	$part=~s/^\_//;
	$part=~s/\./\_/g;
if ($subp eq 'display') {	if ($subp eq 'display') {
$value.=' [Part: '.$part.']';	$value.=' [Part: '.$part.']';
}	}
Line 1910 sub metadata {	Line 2090 sub metadata {
$unikey.='_'.$token->[2]->{'part'};	$unikey.='_'.$token->[2]->{'part'};
}	}
if (defined($token->[2]->{'id'})) {	if (defined($token->[2]->{'id'})) {
$unikey.='_'.$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'};
Line 2037 sub numval {	Line 2217 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 2149 sub unescape {	Line 2334 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 2168 if ($readit ne 'done') {	Line 2353 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 2192 if ($readit ne 'done') {	Line 2379 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 2203 if ($readit ne 'done') {	Line 2392 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 2240 if ($readit ne 'done') {	Line 2431 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>

Removed from v.1.145
changed lines
	Added in v.1.164