--- loncom/lonnet/perl/lonnet.pm 2001/07/26 20:44:42 1.132
+++ loncom/lonnet/perl/lonnet.pm 2001/08/04 19:07:31 1.138
@@ -40,22 +40,27 @@
# : returns hash for this symb, all args are optional
# if they aren't given they will be derived from the
# current enviroment
-# eget(namesp,array) : returns hash with keys from array filled in from namesp
+#
+#
+# for the next 6 functions udom and uname are optional
+# if supplied they use udom as the domain and uname
+# as the username for the function (supply a courseid
+# 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
-# if supplied uses udom as the domain and uname
-# as the username for the dump (supply a courseid
-# for the uname if you want a course database)
-# if not supplied it uses %ENV to get the values
-# del(namesp,array) : deletes keys out of array from namesp
-# put(namesp,hash) : stores hash in namesp
-# cput(namesp,hash) : critical put
# dump(namesp,udom,uname) : dumps the complete namespace into a hash
-# if supplied uses udom as the domain and uname
-# as the username for the dump (supply a courseid
-# for the uname if you want a course database)
-# if not supplied it uses %ENV to get the values
+# 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
# hash
# coursedescription(id) : returns and caches course description for id
@@ -116,7 +121,8 @@
# 5/26,5/28 Gerd Kortemeyer
# 5/30 H. K. Ng
# 6/1 Gerd Kortemeyer
-#
+# July Guy Albertelli
+# 8/4 Gerd Kortemeyer
package Apache::lonnet;
@@ -125,7 +131,7 @@ use Apache::File;
use LWP::UserAgent();
use HTTP::Headers;
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 GDBM_File;
use Apache::Constants qw(:common :http);
@@ -678,22 +684,18 @@ sub devalidate {
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'});
+ &del('nohist_calculatedsheet',
+ [$key.'studentcalc'],
+ $ENV{'course.'.$cid.'.domain'},
+ $ENV{'course.'.$cid.'.num'})
+ .' '.
+ &del('nohist_calculatedsheets_'.$cid,
+ [$key.'assesscalc:'.$symb]);
unless ($status eq 'ok ok') {
&logthis('Could not devalidate spreadsheet '.
$ENV{'user.name'}.' at '.$ENV{'user.domain'}.' for '.
$symb.': '.$status);
- }
+ }
}
}
@@ -894,7 +896,7 @@ sub rolesinit {
my $author=0;
map {
%thesepriv=();
- if ($_!~/^st/) { $adv=1; }
+ if (($_!~/^st/) && ($_!~/^ta/)) { $adv=1; }
if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }
map {
if ($_ ne '') {
@@ -932,7 +934,7 @@ sub get {
if (!$uname) { $uname=$ENV{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);
- my $rep=reply("get:$udomain:$uname:$namespace:$items",$uhome);
+ my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome);
my @pairs=split(/\&/,$rep);
my %returnhash=();
my $i=0;
@@ -946,14 +948,17 @@ sub get {
# --------------------------------------------------------------- del interface
sub del {
- my ($namespace,@storearr)=@_;
+ my ($namespace,$storearr,$udomain,$uname)=@_;
my $items='';
map {
$items.=escape($_).'&';
- } @storearr;
+ } @$storearr;
$items=~s/\&$//;
- return reply("del:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
- $ENV{'user.home'});
+ if (!$udomain) { $udomain=$ENV{'user.domain'}; }
+ if (!$uname) { $uname=$ENV{'user.name'}; }
+ my $uhome=&homeserver($uname,$udomain);
+
+ return &reply("del:$udomain:$uname:$namespace:$items",$uhome);
}
# -------------------------------------------------------------- dump interface
@@ -976,48 +981,53 @@ sub dump {
# --------------------------------------------------------------- put interface
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='';
map {
- $items.=escape($_).'='.escape($storehash{$_}).'&';
- } keys %storehash;
+ $items.=&escape($_).'='.&escape($$storehash{$_}).'&';
+ } keys %$storehash;
$items=~s/\&$//;
- return reply("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
- $ENV{'user.home'});
+ return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
}
# ------------------------------------------------------ critical put interface
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='';
map {
- $items.=escape($_).'='.escape($storehash{$_}).'&';
- } keys %storehash;
+ $items.=escape($_).'='.escape($$storehash{$_}).'&';
+ } keys %$storehash;
$items=~s/\&$//;
- return critical
- ("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
- $ENV{'user.home'});
+ return &critical("put:$udomain:$uname:$namespace:$items",$uhome);
}
# -------------------------------------------------------------- eget interface
sub eget {
- my ($namespace,@storearr)=@_;
+ my ($namespace,$storearr,$udomain,$uname)=@_;
my $items='';
map {
$items.=escape($_).'&';
- } @storearr;
+ } @$storearr;
$items=~s/\&$//;
- my $rep=reply("eget:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
- $ENV{'user.home'});
+ if (!$udomain) { $udomain=$ENV{'user.domain'}; }
+ 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 %returnhash=();
my $i=0;
map {
$returnhash{$_}=unescape($pairs[$i]);
$i++;
- } @storearr;
+ } @$storearr;
return %returnhash;
}
@@ -1426,27 +1436,20 @@ sub modifyuser {
}
}
# -------------------------------------------------------------- Add names, etc
- my $names=&reply('get:'.$udom.':'.$uname.
- ':environment:firstname&middlename&lastname&generation',
- $uhome);
- my ($efirst,$emiddle,$elast,$egene)=split(/\&/,$names);
- if ($first) { $efirst = &escape($first); }
- if ($middle) { $emiddle = &escape($middle); }
- if ($last) { $elast = &escape($last); }
- if ($gene) { $egene = &escape($gene); }
- my $reply=&reply('put:'.$udom.':'.$uname.
- ':environment:firstname='.$efirst.
- '&middlename='.$emiddle.
- '&lastname='.$elast.
- '&generation='.$egene,$uhome);
- if ($reply ne 'ok') {
- return 'error: '.$reply;
- }
+ my %names=&get('environment',
+ ['firstname','middlename','lastname','generation'],
+ $udom,$uname);
+ if ($first) { $names{'firstname'} = $first; }
+ if ($middle) { $names{'middlename'} = $middle; }
+ if ($last) { $names{'lastname'} = $last; }
+ if ($gene) { $names{'generation'} = $gene; }
+ my $reply = &put('environment', \%names, $udom,$uname);
+ if ($reply ne 'ok') { return 'error: '.$reply; }
&logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
$umode.', '.$first.', '.$middle.', '.
$last.', '.$gene.' by '.
$ENV{'user.name'}.' at '.$ENV{'user.domain'});
- return 'ok';
+ return 'ok';
}
# -------------------------------------------------------------- Modify student
@@ -1849,11 +1852,45 @@ sub metadata {
my $token;
while ($token=$parser->get_token) {
if ($token->[0] eq 'S') {
+ if (defined($token->[2]->{'package'})) {
+ my $package=$token->[2]->{'package'};
+ my %thispackagekeys=();
+ 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;
+ }
+ undef %thispackagekeys;
+ map {
+ if ($_=~/^$package\&/) {
+ my ($pack,$name,$subp)=split(/\&/,$_);
+ my $unikey='parameter_'.$keyroot.'_'.$name;
+ $thispackagekeys{$unikey}=1;
+ $metacache{$uri.':'.$unikey.'.'.$subp}=$packagetab{$_};
+ }
+ } keys %packagetab;
+ my $addpackagekeys=join(',',keys %thispackagekeys);
+ if ($metacache{$uri.':keys'}) {
+ $metacache{$uri.':keys'}.=','.$addpackagekeys;
+ } else {
+ $metacache{$uri.':keys'}=$addpackagekeys;
+ }
+ } else {
my $entry=$token->[1];
my $unikey=$entry;
if (defined($token->[2]->{'part'})) {
$unikey.='_'.$token->[2]->{'part'};
}
+ if (defined($token->[2]->{'id'})) {
+ $unikey.='_'.$token->[2]->{'id'};
+ }
if (defined($token->[2]->{'name'})) {
$unikey.='_'.$token->[2]->{'name'};
}
@@ -1870,7 +1907,8 @@ sub metadata {
) { $metacache{$uri.':'.$unikey}=
$metacache{$uri.':'.$unikey.'.default'};
}
- }
+ }
+ }
}
}
return $metacache{$uri.':'.$what};
@@ -2152,6 +2190,17 @@ 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);
+ if ($plain ne '') { $packagetab{$short}=$plain; }
+ }
+}
+
# ------------------------------------------------------------- Read file types
{
my $config=Apache::File->new("$perlvar{'lonTabDir'}/filetypes.tab");