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.306 and 1.331

version 1.306, 2002/12/05 22:59:37	version 1.331, 2003/02/20 22:04:18
Line 47	Line 47
# 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	# YEAR=2001
# 02/27/01 Scott Harrison
# 3/2 Gerd Kortemeyer	# 3/2 Gerd Kortemeyer
# 3/15,3/19 Scott Harrison
# 3/19,3/20 Gerd Kortemeyer	# 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/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	# 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,	# 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/2 Gerd Kortemeyer
# 10/5,10/10,11/13,11/15 Scott Harrison
# 11/17,11/20,11/22,11/29 Gerd Kortemeyer	# 11/17,11/20,11/22,11/29 Gerd Kortemeyer
# 12/5 Matthew Hall	# 12/5 Matthew Hall
# 12/5 Guy Albertelli	# 12/5 Guy Albertelli
# 12/6,12/7,12/12 Gerd Kortemeyer	# 12/6,12/7,12/12 Gerd Kortemeyer
# 12/18 Scott Harrison
# 12/21,12/22,12/27,12/28 Gerd Kortemeyer	# 12/21,12/22,12/27,12/28 Gerd Kortemeyer
# YEAR=2002	# YEAR=2002
# 1/4,2/4,2/7 Gerd Kortemeyer	# 1/4,2/4,2/7 Gerd Kortemeyer
Line 80 use vars	Line 75 use vars
qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom	qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom
%libserv %pr %prp %metacache %packagetab %titlecache	%libserv %pr %prp %metacache %packagetab %titlecache
%courselogs %accesshash $processmarker $dumpcount	%courselogs %accesshash $processmarker $dumpcount
%coursedombuf %coursehombuf %courseresdatacache %domaindescription);	%coursedombuf %coursehombuf %courseresdatacache
	%domaindescription %domain_auth_def %domain_auth_arg_def $tmpdir);
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 142 sub reply {	Line 138 sub reply {
unless (defined($hostname{$server})) { return 'no_such_host'; }	unless (defined($hostname{$server})) { return 'no_such_host'; }
my $answer=subreply($cmd,$server);	my $answer=subreply($cmd,$server);
if ($answer eq 'con_lost') {	if ($answer eq 'con_lost') {
#sleep 5;	#sleep 5;
#$answer=subreply($cmd,$server);	#$answer=subreply($cmd,$server);
#if ($answer eq 'con_lost') {	#if ($answer eq 'con_lost') {
# &logthis("Second attempt con_lost on $server");	# &logthis("Second attempt con_lost on $server");
# my $peerfile="$perlvar{'lonSockDir'}/$server";	# my $peerfile="$perlvar{'lonSockDir'}/$server";
# my $client=IO::Socket::UNIX->new(Peer =>"$peerfile",	# my $client=IO::Socket::UNIX->new(Peer =>"$peerfile",
Line 202 sub critical {	Line 198 sub critical {
" Critical message to unknown server ($server)</font>");	" Critical message to unknown server ($server)</font>");
return 'no_such_host';	return 'no_such_host';
}	}
sleep 2;
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 729 sub currentversion {	Line 724 sub currentversion {

sub subscribe {	sub subscribe {
my $fname=shift;	my $fname=shift;
	if ($fname=~/\/(aboutme\|syllabus\|bulletinboard\|smppg)$/) { return ''; }
my $author=$fname;	my $author=$fname;
$author=~s/\/home\/httpd\/html\/res\/([^\/])\/([^\/]).*/$1\/$2/;	$author=~s/\/home\/httpd\/html\/res\/([^\/])\/([^\/]).*/$1\/$2/;
my ($udom,$uname)=split(/\//,$author);	my ($udom,$uname)=split(/\//,$author);
Line 808 sub repcopy {	Line 804 sub repcopy {
}	}
}	}

	# ------------------------------------------------ Get server side include body
	sub ssi_body {
	my $filelink=shift;
	my $output=($filelink=~/^http\:/?&externalssi($filelink):
	&ssi($filelink));
	$output=~s/^.\<body[^\>]\>//si;
	$output=~s/\<\/body\s\>.$//si;
	$output=~
	s/\/\/ BEGIN LON\-CAPA Internal.+\/\/ END LON\-CAPA Internal\s//gs;
	return $output;
	}

# --------------------------------------------------------- Server Side Include	# --------------------------------------------------------- Server Side Include

sub ssi {	sub ssi {
Line 831 sub ssi {	Line 839 sub ssi {
return $response->content;	return $response->content;
}	}

	sub externalssi {
	my ($url)=@_;
	my $ua=new LWP::UserAgent;
	my $request=new HTTP::Request('GET',$url);
	my $response=$ua->request($request);
	return $response->content;
	}

# ------- Add a token to a remote URI's query string to vouch for access rights	# ------- Add a token to a remote URI's query string to vouch for access rights

sub tokenwrapper {	sub tokenwrapper {
Line 856 sub tokenwrapper {	Line 872 sub tokenwrapper {
sub userfileupload {	sub userfileupload {
my ($formname,$coursedoc)=@_;	my ($formname,$coursedoc)=@_;
my $fname=$ENV{'form.'.$formname.'.filename'};	my $fname=$ENV{'form.'.$formname.'.filename'};
	# Replace Windows backslashes by forward slashes
$fname=~s/\\/\//g;	$fname=~s/\\/\//g;
	# Get rid of everything but the actual filename
$fname=~s/^.*\/([^\/]+)$/$1/;	$fname=~s/^.*\/([^\/]+)$/$1/;
	# Replace spaces by underscores
	$fname=~s/\s+/\_/g;
	# Replace all other weird characters by nothing
	$fname=~s/[^\w\.\-]//g;
	# See if there is anything left
unless ($fname) { return 'error: no uploaded file'; }	unless ($fname) { return 'error: no uploaded file'; }
chop($ENV{'form.'.$formname});	chop($ENV{'form.'.$formname});
# Create the directory if not present	# Create the directory if not present
Line 1101 sub expirespread {	Line 1124 sub expirespread {
# ----------------------------------------------------- Devalidate Spreadsheets	# ----------------------------------------------------- Devalidate Spreadsheets

sub devalidate {	sub devalidate {
my $symb=shift;	my ($symb,$uname,$udom)=@_;
my $cid=$ENV{'request.course.id'};	my $cid=$ENV{'request.course.id'};
if ($cid) {	if ($cid) {
my $key=$ENV{'user.name'}.':'.$ENV{'user.domain'}.':';	# delete the stored spreadsheets for
	# - the student level sheet of this user in course's homespace
	# - the assessment level sheet for this resource
	# for this user in user's homespace
	my $key=$uname.':'.$udom.':';
my $status=	my $status=
&del('nohist_calculatedsheets',	&del('nohist_calculatedsheets',
[$key.'studentcalc'],	[$key.'studentcalc'],
Line 1115 sub devalidate {	Line 1142 sub devalidate {
[$key.'assesscalc:'.$symb]);	[$key.'assesscalc:'.$symb]);
unless ($status eq 'ok ok') {	unless ($status eq 'ok ok') {
&logthis('Could not devalidate spreadsheet '.	&logthis('Could not devalidate spreadsheet '.
$ENV{'user.name'}.' at '.$ENV{'user.domain'}.' for '.	$uname.' at '.$udom.' for '.
$symb.': '.$status);	$symb.': '.$status);
}	}
}	}
Line 1447 sub store {	Line 1474 sub store {
$symb=&symbclean($symb);	$symb=&symbclean($symb);
if (!$symb) { unless ($symb=&symbread()) { return ''; } }	if (!$symb) { unless ($symb=&symbread()) { return ''; } }

&devalidate($symb);	if (!$domain) { $domain=$ENV{'user.domain'}; }
	if (!$stuname) { $stuname=$ENV{'user.name'}; }

	&devalidate($symb,$stuname,$domain);

$symb=escape($symb);	$symb=escape($symb);
if (!$namespace) {	if (!$namespace) {
Line 1455 sub store {	Line 1485 sub store {
return '';	return '';
}	}
}	}
if (!$domain) { $domain=$ENV{'user.domain'}; }
if (!$stuname) { $stuname=$ENV{'user.name'}; }
if (!$home) { $home=$ENV{'user.home'}; }	if (!$home) { $home=$ENV{'user.home'}; }
my $namevalue='';	my $namevalue='';
foreach (keys %$storehash) {	foreach (keys %$storehash) {
Line 1478 sub cstore {	Line 1506 sub cstore {
$symb=&symbclean($symb);	$symb=&symbclean($symb);
if (!$symb) { unless ($symb=&symbread()) { return ''; } }	if (!$symb) { unless ($symb=&symbread()) { return ''; } }

&devalidate($symb);	if (!$domain) { $domain=$ENV{'user.domain'}; }
	if (!$stuname) { $stuname=$ENV{'user.name'}; }

	&devalidate($symb,$stuname,$domain);

$symb=escape($symb);	$symb=escape($symb);
if (!$namespace) {	if (!$namespace) {
Line 1486 sub cstore {	Line 1517 sub cstore {
return '';	return '';
}	}
}	}
if (!$domain) { $domain=$ENV{'user.domain'}; }
if (!$stuname) { $stuname=$ENV{'user.name'}; }
if (!$home) { $home=$ENV{'user.home'}; }	if (!$home) { $home=$ENV{'user.home'}; }

my $namevalue='';	my $namevalue='';
Line 1736 sub dump {	Line 1765 sub dump {
return %returnhash;	return %returnhash;
}	}

	# --------------------------------------------------------------- currentdump
	sub currentdump {
	my ($courseid,$sdom,$sname)=@_;
	$courseid = $ENV{'request.course.id'} if (! defined($courseid));
	$sdom = $ENV{'user.domain'} if (! defined($sdom));
	$sname = $ENV{'user.name'} if (! defined($sname));
	my $uhome = &homeserver($sname,$sdom);
	my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);
	return if ($rep =~ /^(error:\|no_such_host)/);
	#
	my %returnhash=();
	#
	if ($rep eq "unknown_cmd") {
	# an old lond will not know currentdump
	# Do a dump and make it look like a currentdump
	my @tmp = &dump($courseid,$sdom,$sname,'.');
	return if ($tmp[0] =~ /^(error:\|no_such_host)/);
	my %hash = @tmp;
	@tmp=();
	# Code ripped from lond, essentially. The only difference
	# here is the unescaping done by lonnet::dump(). Conceivably
	# we might run in to problems with parameter names =~ /^v\./
	while (my ($key,$value) = each(%hash)) {
	my ($v,$symb,$param) = split(/:/,$key);
	next if ($v eq 'version' \|\| $symb eq 'keys');
	next if (exists($returnhash{$symb}) &&
	exists($returnhash{$symb}->{$param}) &&
	$returnhash{$symb}->{'v.'.$param} > $v);
	$returnhash{$symb}->{$param}=$value;
	$returnhash{$symb}->{'v.'.$param}=$v;
	}
	#
	# Remove all of the keys in the hashes which keep track of
	# the version of the parameter.
	while (my ($symb,$param_hash) = each(%returnhash)) {
	# use a foreach because we are going to delete from the hash.
	foreach my $key (keys(%$param_hash)) {
	delete($param_hash->{$key}) if ($key =~ /^v\./);
	}
	}
	} else {
	my @pairs=split(/\&/,$rep);
	foreach (@pairs) {
	my ($key,$value)=split(/=/,$_);
	my ($symb,$param) = split(/:/,$key);
	$returnhash{&unescape($symb)}->{&unescape($param)} =
	&unescape($value);
	}
	}
	return %returnhash;
	}

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

sub put {	sub put {
Line 1863 sub allowed {	Line 1944 sub allowed {
$thisallowed.=$1;	$thisallowed.=$1;
}	}

	# URI is an uploaded document for this course

	if (($priv eq 'bre') &&
	($uri=~/^uploaded\/$ENV{'course.'.$ENV{'request.course.id'}.'.domain'}\/$ENV{'course.'.$ENV{'request.course.id'}.'.num'}/)) {
	return 'F';
	}
# Full access at system, domain or course-wide level? Exit.	# Full access at system, domain or course-wide level? Exit.

if ($thisallowed=~/F/) {	if ($thisallowed=~/F/) {
Line 2349 sub modifyuser {	Line 2436 sub modifyuser {
}	}
}	}
# -------------------------------------------------------------- Add names, etc	# -------------------------------------------------------------- Add names, etc
my %names=&get('environment',	my @tmp=&get('environment',
['firstname','middlename','lastname','generation'],	['firstname','middlename','lastname','generation'],
$udom,$uname);	$udom,$uname);
if ($names{'firstname'} =~ m/^error:.*/) { %names=(); }	my %names;
	if ($tmp[0] =~ m/^error:.*/) {
	%names=();
	} else {
	%names = @tmp;
	}
if ($first) { $names{'firstname'} = $first; }	if ($first) { $names{'firstname'} = $first; }
if ($middle) { $names{'middlename'} = $middle; }	if ($middle) { $names{'middlename'} = $middle; }
if ($last) { $names{'lastname'} = $last; }	if ($last) { $names{'lastname'} = $last; }
Line 2747 sub EXT {	Line 2839 sub EXT {
} else {	} else {
$courseid=$ENV{'request.course.id'};	$courseid=$ENV{'request.course.id'};
}	}

my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);	my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
my $rest;	my $rest;
if ($therest[0]) {	if (defined($therest[0])) {
$rest=join('.',@therest);	$rest=join('.',@therest);
} else {	} else {
$rest='';	$rest='';
}	}

my $qualifierrest=$qualifier;	my $qualifierrest=$qualifier;
if ($rest) { $qualifierrest.='.'.$rest; }	if ($rest) { $qualifierrest.='.'.$rest; }
my $spacequalifierrest=$space;	my $spacequalifierrest=$space;
Line 2848 sub EXT {	Line 2940 sub EXT {
my $courselevelm=$courseid.'.'.$mapparm;	my $courselevelm=$courseid.'.'.$mapparm;

# ----------------------------------------------------------- first, check user	# ----------------------------------------------------------- first, check user
my %resourcedata=&get('resourcedata',	#most student don't have any data set, check if there is some data
[$courselevelr,$courselevelm,$courselevel],	#every thirty minutes
$udom,$uname);	if (!
my ($tmp)=keys(%resourcedata);	(exists($ENV{'cache.studentresdata'})
&Apache::lonnet::logthis("Returned $tmp: ".join(':',keys(%resourcedata)));	&& (($ENV{'cache.studentresdata'}+1800) > time))) {
if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {	my %resourcedata=&get('resourcedata',
	[$courselevelr,$courselevelm,$courselevel],
if ($resourcedata{$courselevelr}) {	$udom,$uname);
return $resourcedata{$courselevelr}; }	my ($tmp)=keys(%resourcedata);
if ($resourcedata{$courselevelm}) {	if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) {
return $resourcedata{$courselevelm}; }	if ($resourcedata{$courselevelr}) {
if ($resourcedata{$courselevel}) {	return $resourcedata{$courselevelr}; }
return $resourcedata{$courselevel}; }	if ($resourcedata{$courselevelm}) {
} else {	return $resourcedata{$courselevelm}; }
if ($tmp!~/No such file/) {	if ($resourcedata{$courselevel}) {
&logthis("<font color=blue>WARNING:".	return $resourcedata{$courselevel}; }
" Trying to get resource data for ".	} else {
$uname." at ".$udom.": ".	if ($tmp!~/No such file/) {
$tmp."</font>");	&logthis("<font color=blue>WARNING:".
} elsif ($tmp =~ /^(con_lost\|no_such_host)/) {	" Trying to get resource data for ".
return $tmp;	$uname." at ".$udom.": ".
	$tmp."</font>");
	} elsif ($tmp=~/error:No such file/) {
	$ENV{'cache.studentresdata'}=time;
	&appenv(('cache.studentresdata'=>
	$ENV{'cache.studentresdata'}));
	} elsif ($tmp =~ /^(con_lost\|no_such_host)/) {
	return $tmp;
	}
}	}
}	}

Line 3007 sub metadata {	Line 3107 sub metadata {
my $unikey='parameter'.$keyroot.'_'.$name;	my $unikey='parameter'.$keyroot.'_'.$name;
$metathesekeys{$unikey}=1;	$metathesekeys{$unikey}=1;
$metacache{$uri.':'.$unikey.'.part'}=$part;	$metacache{$uri.':'.$unikey.'.part'}=$part;
unless	unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {
(defined($metacache{$uri.':'.$unikey.'.'.$subp})) {	$metacache{$uri.':'.$unikey.'.'.$subp}=$value;
$metacache{$uri.':'.$unikey.'.'.$subp}=$value;	}
	if (defined($metacache{$uri.':'.$unikey.'.default'})) {
	$metacache{$uri.':'.$unikey}=
	$metacache{$uri.':'.$unikey.'.default'}
}	}
}	}
}	}
Line 3059 sub metadata {	Line 3162 sub metadata {
foreach (@{$token->[3]}) {	foreach (@{$token->[3]}) {
$metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};	$metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};
}	}
unless (	my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
$metacache{$uri.':'.$unikey}=&HTML::Entities::decode($parser->get_text('/'.$entry))	my $default=$metacache{$uri.':'.$unikey.'.default'};
) { $metacache{$uri.':'.$unikey}=	if ( $internaltext =~ /^\s$/ && $default !~ /^\s$/) {
$metacache{$uri.':'.$unikey.'.default'};	# only ws inside the tag, and not in default, so use default
}	# as value
	$metacache{$uri.':'.$unikey}=$default;
	} else {
	# either something interesting inside the tag or default
	# uninteresting
	$metacache{$uri.':'.$unikey}=$internaltext;
	}
# end of not-a-package not-a-library import	# end of not-a-package not-a-library import
}	}
# end of not-a-package start tag	# end of not-a-package start tag
Line 3476 BEGIN {	Line 3585 BEGIN {
}	}
}	}

	# ------------------------------------------------------------ Read domain file
	{
	my $fh=Apache::File->new($Apache::lonnet::perlvar{'lonTabDir'}.
	'/domain.tab');
	%domaindescription = ();
	%domain_auth_def = ();
	%domain_auth_arg_def = ();
	if ($fh) {
	while (<$fh>) {
	next if /^\#/;
	chomp;
	my ($domain, $domain_description, $def_auth, $def_auth_arg)
	= split(/:/,$_,4);
	$domain_auth_def{$domain}=$def_auth;
	$domain_auth_arg_def{$domain}=$def_auth_arg;
	$domaindescription{$domain}=$domain_description;
	# &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");
	# &logthis("Domain.tab: $domain ".$domaindescription{$domain} );
	}
	}
	}


# ------------------------------------------------------------- Read hosts file	# ------------------------------------------------------------- Read hosts file
{	{
my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");	my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");
Line 3489 BEGIN {	Line 3621 BEGIN {
$hostdom{$id}=$domain;	$hostdom{$id}=$domain;
$hostip{$id}=$ip;	$hostip{$id}=$ip;
$iphost{$ip}=$id;	$iphost{$ip}=$id;
if ($domdescr) { $domaindescription{$domain}=$domdescr; }
if ($role eq 'library') { $libserv{$id}=$name; }	if ($role eq 'library') { $libserv{$id}=$name; }
} else {	} else {
if ($configline) {	if ($configline) {
Line 3551 BEGIN {	Line 3682 BEGIN {
}	}
}	}

	# ------------- set up temporary directory
	{
	$tmpdir = $perlvar{'lonDaemons'}.'/tmp/';

	}

%metacache=();	%metacache=();

$processmarker='_'.time.'_'.$perlvar{'lonHostID'};	$processmarker='_'.time.'_'.$perlvar{'lonHostID'};

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

Removed from v.1.306
changed lines
	Added in v.1.331