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.127 and 1.143

version 1.127, 2001/05/30 21:53:17	version 1.143, 2001/08/07 22:56:06
Line 40	Line 40
# : returns hash for this symb, all args are optional	# : returns hash for this symb, all args are optional
# if they aren't given they will be derived from the	# if they aren't given they will be derived from the
# current enviroment	# current enviroment
# eget(namesp,array) : returns hash with keys from array filled in from namesp	#
# get(namesp,array) : returns hash with keys from array filled in from namesp	#
# del(namesp,array) : deletes keys out of array from namesp	# for the next 6 functions udom and uname are optional
# put(namesp,hash) : stores hash in namesp	# if supplied they use udom as the domain and uname
# cput(namesp,hash) : critical put	# as the username for the function (supply a courseid
# dump(namesp) : dumps the complete namespace into a hash	# for the uname if you want a course database)
	# if not supplied it uses %ENV and looks at
	# user. attribute for the values
	#
	# eget(namesp,arrayref,udom,uname)
	# : returns hash with keys from array reference filled
	# in from namesp (encrypts the return communication)
	# get(namesp,arrayref,udom,uname)
	# : returns hash with keys from array reference filled
	# in from namesp
	# dump(namesp,udom,uname) : dumps the complete namespace into a hash
	# 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
	#
	#
# 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 105	Line 120
# 3/22,3/27,4/2,4/16,4/17 Scott Harrison	# 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
	# July Guy Albertelli
	# 8/4,8/7 Gerd Kortemeyer

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

use strict;	use strict;
Line 113 use Apache::File;	Line 131 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 %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache %packagetab);
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 666 sub devalidate {	Line 684 sub devalidate {
if ($cid) {	if ($cid) {
my $key=$ENV{'user.name'}.':'.$ENV{'user.domain'}.':';	my $key=$ENV{'user.name'}.':'.$ENV{'user.domain'}.':';
my $status=	my $status=
&reply('del:'.$ENV{'course.'.$cid.'.domain'}.':'.	&del('nohist_calculatedsheet',
$ENV{'course.'.$cid.'.num'}.	[$key.'studentcalc'],
':nohist_calculatedsheets:'.	$ENV{'course.'.$cid.'.domain'},
&escape($key.'studentcalc:'),	$ENV{'course.'.$cid.'.num'})
$ENV{'course.'.$cid.'.home'})	.' '.
.' '.	&del('nohist_calculatedsheets_'.$cid,
&reply('del:'.$ENV{'user.domain'}.':'.	[$key.'assesscalc:'.$symb]);
$ENV{'user.name'}.
':nohist_calculatedsheets_'.$cid.':'.
&escape($key.'assesscalc:'.$symb),
$ENV{'user.home'});
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 '.	$ENV{'user.name'}.' at '.$ENV{'user.domain'}.' for '.
$symb.': '.$status);	$symb.': '.$status);
}	}
}	}
}	}

Line 782 sub coursedescription {	Line 796 sub coursedescription {
$courseid=~s/^\///;	$courseid=~s/^\///;
$courseid=~s/\_/\//g;	$courseid=~s/\_/\//g;
my ($cdomain,$cnum)=split(/\//,$courseid);	my ($cdomain,$cnum)=split(/\//,$courseid);
my $chome=homeserver($cnum,$cdomain);	my $chome=&homeserver($cnum,$cdomain);
if ($chome ne 'no_host') {	if ($chome ne 'no_host') {
my $rep=reply("dump:$cdomain:$cnum:environment",$chome);	my %returnhash=&dump('environment',$cdomain,$cnum);
if ($rep ne 'con_lost') {	if (!exists($returnhash{'con_lost'})) {
my $normalid=$cdomain.'_'.$cnum;	my $normalid=$cdomain.'_'.$cnum;
my %envhash=();	my %envhash=();
my %returnhash=('home' => $chome,	$returnhash{'home'}= $chome;
'domain' => $cdomain,	$returnhash{'domain'} = $cdomain;
'num' => $cnum);	$returnhash{'num'} = $cnum;
map {	while (my ($name,$value) = each %returnhash) {
my ($name,$value)=split(/\=/,$_);
$name=&unescape($name);
$value=&unescape($value);
$returnhash{$name}=$value;
$envhash{'course.'.$normalid.'.'.$name}=$value;	$envhash{'course.'.$normalid.'.'.$name}=$value;
} split(/\&/,$rep);	}
$returnhash{'url'}='/res/'.declutter($returnhash{'url'});	$returnhash{'url'}='/res/'.declutter($returnhash{'url'});
$returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.	$returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
$ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;	$ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;
Line 883 sub rolesinit {	Line 893 sub rolesinit {
}	}
} split(/&/,$rolesdump);	} split(/&/,$rolesdump);
my $adv=0;	my $adv=0;
	my $author=0;
map {	map {
%thesepriv=();	%thesepriv=();
if ($_ ne 'st') { $adv=1; }	if (($_!~/^st/) && ($_!~/^ta/)) { $adv=1; }
	if (($_=~/^au/) \|\| ($_=~/^ca/)) { $author=1; }
map {	map {
if ($_ ne '') {	if ($_ ne '') {
my ($privilege,$restrictions)=split(/&/,$_);	my ($privilege,$restrictions)=split(/&/,$_);
Line 902 sub rolesinit {	Line 914 sub rolesinit {
map { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } keys %thesepriv;	map { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } keys %thesepriv;
$userroles.='user.priv.'.$_.'='.$thesestr."\n";	$userroles.='user.priv.'.$_.'='.$thesestr."\n";
} keys %allroles;	} keys %allroles;
$userroles.='user.adv='.$adv."\n";	$userroles.='user.adv='.$adv."\n".
	'user.author='.$author."\n";
$ENV{'user.adv'}=$adv;	$ENV{'user.adv'}=$adv;
}	}
return $userroles;	return $userroles;
Line 911 sub rolesinit {	Line 924 sub rolesinit {
# --------------------------------------------------------------- get interface	# --------------------------------------------------------------- get interface

sub get {	sub get {
my ($namespace,@storearr)=@_;	my ($namespace,$storearr,$udomain,$uname)=@_;
my $items='';	my $items='';
map {	map {
$items.=escape($_).'&';	$items.=escape($_).'&';
} @storearr;	} @$storearr;
$items=~s/\&$//;	$items=~s/\&$//;
my $rep=reply("get:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",	if (!$udomain) { $udomain=$ENV{'user.domain'}; }
$ENV{'user.home'});	if (!$uname) { $uname=$ENV{'user.name'}; }
	my $uhome=&homeserver($uname,$udomain);

	my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome);
my @pairs=split(/\&/,$rep);	my @pairs=split(/\&/,$rep);
my %returnhash=();	my %returnhash=();
my $i=0;	my $i=0;
map {	map {
$returnhash{$_}=unescape($pairs[$i]);	$returnhash{$_}=unescape($pairs[$i]);
$i++;	$i++;
} @storearr;	} @$storearr;
return %returnhash;	return %returnhash;
}	}

# --------------------------------------------------------------- del interface	# --------------------------------------------------------------- del interface

sub del {	sub del {
my ($namespace,@storearr)=@_;	my ($namespace,$storearr,$udomain,$uname)=@_;
my $items='';	my $items='';
map {	map {
$items.=escape($_).'&';	$items.=escape($_).'&';
} @storearr;	} @$storearr;
$items=~s/\&$//;	$items=~s/\&$//;
return reply("del:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",	if (!$udomain) { $udomain=$ENV{'user.domain'}; }
$ENV{'user.home'});	if (!$uname) { $uname=$ENV{'user.name'}; }
	my $uhome=&homeserver($uname,$udomain);

	return &reply("del:$udomain:$uname:$namespace:$items",$uhome);
}	}

# -------------------------------------------------------------- dump interface	# -------------------------------------------------------------- dump interface

sub dump {	sub dump {
my $namespace=shift;	my ($namespace,$udomain,$uname)=@_;
my $rep=reply("dump:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace",	if (!$udomain) { $udomain=$ENV{'user.domain'}; }
$ENV{'user.home'});	if (!$uname) { $uname=$ENV{'user.name'}; }
	my $uhome=&homeserver($uname,$udomain);
	my $rep=reply("dump:$udomain:$uname:$namespace",$uhome);
my @pairs=split(/\&/,$rep);	my @pairs=split(/\&/,$rep);
my %returnhash=();	my %returnhash=();
map {	map {
Line 960 sub dump {	Line 981 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

sub eget {	sub eget {
my ($namespace,@storearr)=@_;	my ($namespace,$storearr,$udomain,$uname)=@_;
my $items='';	my $items='';
map {	map {
$items.=escape($_).'&';	$items.=escape($_).'&';
} @storearr;	} @$storearr;
$items=~s/\&$//;	$items=~s/\&$//;
my $rep=reply("eget:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",	if (!$udomain) { $udomain=$ENV{'user.domain'}; }
$ENV{'user.home'});	if (!$uname) { $uname=$ENV{'user.name'}; }
	my $uhome=&homeserver($uname,$udomain);
	my $rep=&reply("eget:$udomain:$uname:$namespace:$items",$uhome);
my @pairs=split(/\&/,$rep);	my @pairs=split(/\&/,$rep);
my %returnhash=();	my %returnhash=();
my $i=0;	my $i=0;
map {	map {
$returnhash{$_}=unescape($pairs[$i]);	$returnhash{$_}=unescape($pairs[$i]);
$i++;	$i++;
} @storearr;	} @$storearr;
return %returnhash;	return %returnhash;
}	}

Line 1410 sub modifyuser {	Line 1436 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 1699 sub EXT {	Line 1718 sub EXT {
# ---------------------------------------------------- Any other user namespace	# ---------------------------------------------------- Any other user namespace
} else {	} else {
my $item=($rest)?$qualifier.'.'.$rest:$qualifier;	my $item=($rest)?$qualifier.'.'.$rest:$qualifier;
my %reply=&get($space,$item);	my %reply=&get($space,[$item]);
return $reply{$item};	return $reply{$item};
}	}
} elsif ($realm eq 'request') {	} elsif ($realm eq 'request') {
Line 1742 sub EXT {	Line 1761 sub EXT {

# ----------------------------------------------------------- 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/)) {	($resourcedata{$courselevelr}!~/^con_lost/)) {

Line 1804 sub EXT {	Line 1823 sub EXT {
$metadata=&metadata($ENV{'request.filename'},	$metadata=&metadata($ENV{'request.filename'},
'parameter_'.$spacequalifierrest);	'parameter_'.$spacequalifierrest);
if ($metadata) { return $metadata; }	if ($metadata) { return $metadata; }

	$spacequalifierrest=~/[^\_]+$/;

	$metadata=&metadata($ENV{'request.filename'},'parameter_0'.$1);

	if ($metadata) { return $metadata; }

# ---------------------------------------------------- Any other user namespace	# ---------------------------------------------------- Any other user namespace
} elsif ($realm eq 'environment') {	} elsif ($realm eq 'environment') {
Line 1827 sub metadata {	Line 1852 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{$_};
	if ($subp eq 'display') {
	my $part=$keyroot;
	$part=~s/^\_//;
	$value.=' [Part: '.$part.']';
	}
	my $unikey='parameter'.$keyroot.'_'.$name;
	$metathesekeys{$unikey}=1;
	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 1854 sub metadata {	Line 1912 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 2136 if ($readit ne 'done') {	Line 2196 if ($readit ne 'done') {
}	}
}	}

	# ---------------------------------------------------------- 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;
	}
	}
	}

# ------------------------------------------------------------- Read file types	# ------------------------------------------------------------- Read file types
{	{
my $config=Apache::File->new("$perlvar{'lonTabDir'}/filetypes.tab");	my $config=Apache::File->new("$perlvar{'lonTabDir'}/filetypes.tab");

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

Removed from v.1.127
changed lines
	Added in v.1.143