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.81 and 1.110

version 1.81, 2000/12/14 21:44:06	version 1.110, 2001/03/20 21:33:37
Line 3	Line 3
#	#
# Functions for use by content handlers:	# Functions for use by content handlers:
#	#
	# metadata_query(sql-query-string) : returns file handle of where sql
	# 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 15
# 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 81	Line 83
# 10/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29,	# 10/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29,
# 10/30,10/31,	# 10/30,10/31,
# 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 Gerd Kortemeyer	# 12/02,12/12,12/13,12/14,12/28,12/29 Gerd Kortemeyer
	# 05/01/01 Guy Albertelli
	# 05/01,06/01,09/01 Gerd Kortemeyer
	# 09/01 Guy Albertelli
	# 09/01,10/01,11/01 Gerd Kortemeyer
	# 02/27/01 Scott Harrison
	# 3/2 Gerd Kortemeyer
	# 3/15 Scott Harrison
	# 3/19,3/20 Gerd Kortemeyer

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

Line 95 use IO::Socket;	Line 105 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

Line 177 sub reconlonc {	Line 188 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 235 sub appenv {	Line 251 sub appenv {
$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 261 sub appenv {	Line 290 sub appenv {
foreach $newname (keys %newenv) {	foreach $newname (keys %newenv) {
print $fh "$newname=$newenv{$newname}\n";	print $fh "$newname=$newenv{$newname}\n";
}	}
	$fh->close();
}	}

	$lockfh->close();
return 'ok';	return 'ok';
}	}
# ----------------------------------------------------- Delete from Environment	# ----------------------------------------------------- Delete from Environment
Line 280 sub delenv {	Line 312 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';
}	}
	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;
	$fh->close();
}	}
return 'ok';	return 'ok';
}	}
Line 582 sub log {	Line 628 sub log {
return critical("log:$dom:$nam:$what",$hom);	return critical("log:$dom:$nam:$what",$hom);
}	}

	# --------------------------------------------- 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=
	&reply('del:'.$ENV{'course.'.$cid.'.domain'}.':'.
	$ENV{'course.'.$cid.'.num'}.
	':nohist_calculatedsheets:'.
	&escape($key.'studentcalc:'),
	$ENV{'course.'.$cid.'.home'})
	.' '.
	&reply('del:'.$ENV{'user.domain'}.':'.
	$ENV{'user.name'}.
	':nohist_calculatedsheets_'.$cid.':'.
	&escape($key.'assesscalc:'.$symb),
	$ENV{'user.home'});
	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=@_;
my $symb;	my $symb;
unless ($symb=escape(&symbread())) { return ''; }	unless ($symb=&symbread()) { return ''; }

	&devalidate($symb);

	$symb=escape($symb);
my $namespace;	my $namespace;
unless ($namespace=$ENV{'request.course.id'}) { return ''; }	unless ($namespace=$ENV{'request.course.id'}) { return ''; }
my $namevalue='';	my $namevalue='';
Line 605 sub store {	Line 699 sub store {
sub cstore {	sub cstore {
my %storehash=@_;	my %storehash=@_;
my $symb;	my $symb;
unless ($symb=escape(&symbread())) { return ''; }	unless ($symb=&symbread()) { return ''; }

	&devalidate($symb);

	$symb=escape($symb);
my $namespace;	my $namespace;
unless ($namespace=$ENV{'request.course.id'}) { return ''; }	unless ($namespace=$ENV{'request.course.id'}) { return ''; }
my $namevalue='';	my $namevalue='';
Line 653 sub coursedescription {	Line 751 sub coursedescription {
if ($chome ne 'no_host') {	if ($chome ne 'no_host') {
my $rep=reply("dump:$cdomain:$cnum:environment",$chome);	my $rep=reply("dump:$cdomain:$cnum:environment",$chome);
if ($rep ne 'con_lost') {	if ($rep ne 'con_lost') {
my $normalid=$courseid;	my $normalid=$cdomain.'_'.$cnum;
$normalid=~s/\//\_/g;
my %envhash=();	my %envhash=();
my %returnhash=('home' => $chome,	my %returnhash=('home' => $chome,
'domain' => $cdomain,	'domain' => $cdomain,
Line 680 sub coursedescription {	Line 777 sub coursedescription {
return ();	return ();
}	}

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

sub rolesinit {	sub rolesinit {
my ($domain,$username,$authhost)=@_;	my ($domain,$username,$authhost)=@_;
Line 754 sub rolesinit {	Line 851 sub rolesinit {
%thesepriv=();	%thesepriv=();
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 869 sub eget {	Line 966 sub eget {
return %returnhash;	return %returnhash;
}	}

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

sub allowed {	sub allowed {
my ($priv,$uri)=@_;	my ($priv,$uri)=@_;
Line 901 sub allowed {	Line 998 sub allowed {
# Course: uri itself is a course	# Course: uri itself is a course
my $courseuri=$uri;	my $courseuri=$uri;
$courseuri=~s/\_(\d)/\/$1/;	$courseuri=~s/\_(\d)/\/$1/;
	$courseuri=~s/^([^\/])/\/$1/;

if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseuri}	if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri}
=~/$priv\&([^\:]*)/) {	=~/$priv\&([^\:]*)/) {
$thisallowed.=$1;	$thisallowed.=$1;
}	}
Line 919 sub allowed {	Line 1017 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 944 sub allowed {	Line 1042 sub allowed {
$checkreferer=0;	$checkreferer=0;
}	}
}	}

if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {	if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {
my $refuri=$ENV{'HTTP_REFERER'};	my $refuri=$ENV{'HTTP_REFERER'};
$refuri=~s/^http\:\/\/$ENV{'request.host'}//i;	$refuri=~s/^http\:\/\/$ENV{'request.host'}//i;
Line 970 sub allowed {	Line 1068 sub allowed {
}	}

#	#
# 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 1002 sub allowed {	Line 1100 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 1139 sub definerole {	Line 1238 sub definerole {
}	}
}	}

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

	sub metadata_query {
	my ($query)=@_;
	my $reply=&reply("querysend:".&escape($query),'msul3');
	}

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

sub plaintext {	sub plaintext {
Line 1165 sub filedescription {	Line 1271 sub filedescription {
sub assignrole {	sub assignrole {
my ($udom,$uname,$url,$role,$end,$start)=@_;	my ($udom,$uname,$url,$role,$end,$start)=@_;
my $mrole;	my $mrole;
$url=declutter($url);
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 {
unless (&allowed('c'.$role,$url)) { return 'refused'; }	my $cwosec=$url;
	$cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
	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 1290 sub modifystudent {	Line 1407 sub modifystudent {
return 'error: '.$reply;	return 'error: '.$reply;
}	}
# ---------------------------------------------------- Add student role to user	# ---------------------------------------------------- Add student role to user
my $uurl=$cid;	my $uurl='/'.$cid;
$uurl=~s/\_/\//g;	$uurl=~s/\_/\//g;
if ($usec) {	if ($usec) {
$uurl.='/'.$usec;	$uurl.='/'.$usec;
Line 1298 sub modifystudent {	Line 1415 sub modifystudent {
return &assignrole($udom,$uname,$uurl,'st',$end,$start);	return &assignrole($udom,$uname,$uurl,'st',$end,$start);
}	}

	# ------------------------------------------------- Write to course preferences

	sub writecoursepref {
	my ($courseid,%prefs)=@_;
	$courseid=~s/^\///;
	$courseid=~s/\_/\//g;
	my ($cdomain,$cnum)=split(/\//,$courseid);
	my $chome=homeserver($cnum,$cdomain);
	if (($chome eq '') \|\| ($chome eq 'no_host')) {
	return 'error: no such course';
	}
	my $cstring='';
	map {
	$cstring.=escape($_).'='.escape($prefs{$_}).'&';
	} keys %prefs;
	$cstring=~s/\&$//;
	return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome);
	}

	# ---------------------------------------------------------- Make/modify course

	sub createcourse {
	my ($udom,$description,$url)=@_;
	$url=&declutter($url);
	my $cid='';
	unless (&allowed('ccc',$ENV{'user.domain'})) {
	return 'refused';
	}
	unless ($udom eq $ENV{'user.domain'}) {
	return 'refused';
	}
	# ------------------------------------------------------------------- Create ID
	my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
	unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
	# ----------------------------------------------- Make sure that does not exist
	my $uhome=&homeserver($uname,$udom);
	unless (($uhome eq '') \|\| ($uhome eq 'no_host')) {
	$uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
	unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
	$uhome=&homeserver($uname,$udom);
	unless (($uhome eq '') \|\| ($uhome eq 'no_host')) {
	return 'error: unable to generate unique course-ID';
	}
	}
	# ------------------------------------------------------------- Make the course
	my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
	$ENV{'user.home'});
	unless ($reply eq 'ok') { return 'error: '.$reply; }
	my $uhome=&homeserver($uname,$udom);
	if (($uhome eq '') \|\| ($uhome eq 'no_host')) {
	return 'error: no such course';
	}
	&writecoursepref($udom.'_'.$uname,
	('description' => $description,
	'url' => $url));
	return '/'.$udom.'/'.$uname;
	}

# ---------------------------------------------------------- Assign Custom Role	# ---------------------------------------------------------- Assign Custom Role

sub assigncustomrole {	sub assigncustomrole {
Line 1516 sub EXT {	Line 1691 sub EXT {
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}) {	if ($resourcedata{$courselevelr}) {
return $resourcedata{$courselevelr}; }	return $resourcedata{$courselevelr}; }
Line 1528 sub EXT {	Line 1703 sub EXT {
return $resourcedata{$courselevelm}; }	return $resourcedata{$courselevelm}; }
if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }	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 1729 sub numval {	Line 1918 sub numval {
sub rndseed {	sub rndseed {
my $symb;	my $symb;
unless ($symb=&symbread()) { return time; }	unless ($symb=&symbread()) { return time; }
my $symbchck=unpack("%32C*",$symb);	{
my $symbseed=numval($symb)%$symbchck;	use integer;
my $namechck=unpack("%32C*",$ENV{'user.name'});	my $symbchck=unpack("%32C*",$symb) << 27;
my $nameseed=numval($ENV{'user.name'})%$namechck;	my $symbseed=numval($symb) << 22;
return int( $symbseed	my $namechck=unpack("%32C*",$ENV{'user.name'}) << 17;
.$nameseed	my $nameseed=numval($ENV{'user.name'}) << 12;
.unpack("%32C*",$ENV{'user.domain'})	my $domainseed=unpack("%32C*",$ENV{'user.domain'}) << 7;
.unpack("%32C*",$ENV{'request.course.id'})	my $courseseed=unpack("%32C*",$ENV{'request.course.id'});
.$namechck	my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
.$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 {

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

Removed from v.1.81
changed lines
	Added in v.1.110