--- loncom/lonnet/perl/lonnet.pm 2001/05/30 21:53:17 1.127 +++ loncom/lonnet/perl/lonnet.pm 2001/08/09 19:28:47 1.147 @@ -40,12 +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 -# get(namesp,array) : returns hash with keys from array filled in from namesp -# del(namesp,array) : deletes keys out of array from namesp -# put(namesp,hash) : stores hash in namesp -# cput(namesp,hash) : critical put -# dump(namesp) : dumps the complete namespace into a hash +# +# +# 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 +# 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 # hash # coursedescription(id) : returns and caches course description for id @@ -105,7 +120,10 @@ # 3/22,3/27,4/2,4/16,4/17 Scott Harrison # 5/26,5/28 Gerd Kortemeyer # 5/30 H. K. Ng -# +# 6/1 Gerd Kortemeyer +# July Guy Albertelli +# 8/4,8/7,8/8,8/9 Gerd Kortemeyer + package Apache::lonnet; use strict; @@ -113,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); @@ -666,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); - } + } } } @@ -782,22 +796,18 @@ sub coursedescription { $courseid=~s/^\///; $courseid=~s/\_/\//g; my ($cdomain,$cnum)=split(/\//,$courseid); - my $chome=homeserver($cnum,$cdomain); + my $chome=&homeserver($cnum,$cdomain); if ($chome ne 'no_host') { - my $rep=reply("dump:$cdomain:$cnum:environment",$chome); - if ($rep ne 'con_lost') { + my %returnhash=&dump('environment',$cdomain,$cnum); + if (!exists($returnhash{'con_lost'})) { my $normalid=$cdomain.'_'.$cnum; my %envhash=(); - my %returnhash=('home' => $chome, - 'domain' => $cdomain, - 'num' => $cnum); - map { - my ($name,$value)=split(/\=/,$_); - $name=&unescape($name); - $value=&unescape($value); - $returnhash{$name}=$value; + $returnhash{'home'}= $chome; + $returnhash{'domain'} = $cdomain; + $returnhash{'num'} = $cnum; + while (my ($name,$value) = each %returnhash) { $envhash{'course.'.$normalid.'.'.$name}=$value; - } split(/\&/,$rep); + } $returnhash{'url'}='/res/'.declutter($returnhash{'url'}); $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'. $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum; @@ -883,9 +893,11 @@ sub rolesinit { } } split(/&/,$rolesdump); my $adv=0; + my $author=0; map { %thesepriv=(); - if ($_ ne 'st') { $adv=1; } + if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; } + if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; } map { if ($_ ne '') { my ($privilege,$restrictions)=split(/&/,$_); @@ -902,7 +914,8 @@ sub rolesinit { map { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } keys %thesepriv; $userroles.='user.priv.'.$_.'='.$thesestr."\n"; } keys %allroles; - $userroles.='user.adv='.$adv."\n"; + $userroles.='user.adv='.$adv."\n". + 'user.author='.$author."\n"; $ENV{'user.adv'}=$adv; } return $userroles; @@ -911,43 +924,51 @@ sub rolesinit { # --------------------------------------------------------------- get interface sub get { - my ($namespace,@storearr)=@_; + my ($namespace,$storearr,$udomain,$uname)=@_; my $items=''; map { $items.=escape($_).'&'; - } @storearr; + } @$storearr; $items=~s/\&$//; - my $rep=reply("get:$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("get:$udomain:$uname:$namespace:$items",$uhome); my @pairs=split(/\&/,$rep); my %returnhash=(); my $i=0; map { $returnhash{$_}=unescape($pairs[$i]); $i++; - } @storearr; + } @$storearr; return %returnhash; } # --------------------------------------------------------------- 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 sub dump { - my $namespace=shift; - my $rep=reply("dump:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace", - $ENV{'user.home'}); + my ($namespace,$udomain,$uname)=@_; + if (!$udomain) { $udomain=$ENV{'user.domain'}; } + if (!$uname) { $uname=$ENV{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + my $rep=reply("dump:$udomain:$uname:$namespace",$uhome); my @pairs=split(/\&/,$rep); my %returnhash=(); map { @@ -960,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; } @@ -1410,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 @@ -1655,7 +1674,7 @@ sub condval { # --------------------------------------------------------- Value of a Variable sub EXT { - my $varname=shift; + my ($varname,$symbparm)=@_; unless ($varname) { return ''; } my ($realm,$space,$qualifier,@therest)=split(/\./,$varname); my $rest; @@ -1699,7 +1718,7 @@ sub EXT { # ---------------------------------------------------- Any other user namespace } else { my $item=($rest)?$qualifier.'.'.$rest:$qualifier; - my %reply=&get($space,$item); + my %reply=&get($space,[$item]); return $reply{$item}; } } elsif ($realm eq 'request') { @@ -1716,8 +1735,17 @@ sub EXT { $spacequalifierrest}; } elsif ($realm eq 'resource') { if ($ENV{'request.course.id'}) { + +# print '
'.$space.' - '.$qualifier.' - '.$spacequalifierrest; + + # ----------------------------------------------------- Cascading lookup scheme - my $symbp=&symbread(); + my $symbp; + if ($symbparm) { + $symbp=$symbparm; + } else { + $symbp=&symbread(); + } my $mapp=(split(/\_\_\_/,$symbp))[0]; my $symbparm=$symbp.'.'.$spacequalifierrest; @@ -1742,7 +1770,7 @@ sub EXT { # ----------------------------------------------------------- first, check user my %resourcedata=get('resourcedata', - ($courselevelr,$courselevelm,$courselevel)); + [$courselevelr,$courselevelm,$courselevel]); if (($resourcedata{$courselevelr}!~/^error\:/) && ($resourcedata{$courselevelr}!~/^con_lost/)) { @@ -1805,6 +1833,21 @@ sub EXT { 'parameter_'.$spacequalifierrest); if ($metadata) { return $metadata; } +# ------------------------------------------------------------------ Cascade up + + unless ($space eq '0') { + my ($part,$id)=split(/\_/,$space); + if ($id) { + my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest, + $symbparm); + if ($partgeneral) { return $partgeneral; } + } else { + my $resourcegeneral=&EXT('resource.0.'.$qualifierrest, + $symbparm); + if ($resourcegeneral) { return $resourcegeneral; } + } + } + # ---------------------------------------------------- Any other user namespace } elsif ($realm eq 'environment') { # ----------------------------------------------------------------- environment @@ -1827,25 +1870,59 @@ sub metadata { my $filename=$uri; $uri=~s/\.meta$//; unless ($metacache{$uri.':keys'}) { + my %metathesekeys=(); unless ($filename=~/\.meta$/) { $filename.='.meta'; } my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename); my $parser=HTML::TokeParser->new(\$metastring); my $token; + undef %metathesekeys; while ($token=$parser->get_token) { 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{$_}; + my $part=$keyroot; + $part=~s/^\_//; + if ($subp eq 'display') { + $value.=' [Part: '.$part.']'; + } + my $unikey='parameter'.$keyroot.'_'.$name; + $metathesekeys{$unikey}=1; + $metacache{$uri.':'.$unikey.'.part'}=$part; + unless + (defined($metacache{$uri.':'.$unikey.'.'.$subp})) { + $metacache{$uri.':'.$unikey.'.'.$subp}=$value; + } + } + } keys %packagetab; + } 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'}; } - if ($metacache{$uri.':keys'}) { - $metacache{$uri.':keys'}.=','.$unikey; - } else { - $metacache{$uri.':keys'}=$unikey; - } + $metathesekeys{$unikey}=1; map { $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_}; } @{$token->[3]}; @@ -1854,8 +1931,10 @@ sub metadata { ) { $metacache{$uri.':'.$unikey}= $metacache{$uri.':'.$unikey.'.default'}; } - } + } + } } + $metacache{$uri.':keys'}=join(',',keys %metathesekeys); } return $metacache{$uri.':'.$what}; } @@ -2136,6 +2215,21 @@ 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 { my $config=Apache::File->new("$perlvar{'lonTabDir'}/filetypes.tab");