--- loncom/lonnet/perl/lonnet.pm 2000/11/07 17:20:10 1.59
+++ loncom/lonnet/perl/lonnet.pm 2000/11/29 12:27:49 1.74
@@ -43,7 +43,6 @@
# state string
# condval(index) : value of condition index based on state
# EXT(name) : value of a variable
-# refreshstate() : refresh the state information string
# symblist(map,hash) : Updates symbolic storage links
# symbread([filename]) : returns the data handle (filename optional)
# rndseed() : returns a random seed
@@ -53,6 +52,17 @@
# from the directory dir
# hreflocation(dir,file) : same as filelocation, but for hrefs
# log(domain,user,home,msg) : write to permanent log for user
+# usection(domain,user,courseid) : output of section name/number or '' for
+# "not in course" and '-1' for "no section"
+# userenvironment(domain,user,what) : puts out any environment parameter
+# for a user
+# idput(domain,hash) : writes IDs for users from hash (name=>id,name=>id)
+# idget(domain,array): returns hash with usernames (id=>name,id=>name) for
+# an array of IDs
+# idrget(domain,array): returns hash with IDs for usernames (name=>id,...) for
+# an array of names
+# metadata(file,entry): returns the metadata entry for a file. entry='keys'
+# returns a comma separated list of keys
#
# 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30,
# 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19,
@@ -68,7 +78,8 @@
# 10/04 Gerd Kortemeyer
# 10/04 Guy Albertelli
# 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,11/2 Gerd Kortemeyer
+# 10/30,10/31,
+# 11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25,11/27 Gerd Kortemeyer
package Apache::lonnet;
@@ -77,10 +88,11 @@ use Apache::File;
use LWP::UserAgent();
use HTTP::Headers;
use vars
-qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp %fe %fd $readit);
+qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache);
use IO::Socket;
use GDBM_File;
use Apache::Constants qw(:common :http);
+use HTML::TokeParser;
# --------------------------------------------------------------------- Logging
@@ -123,8 +135,7 @@ sub reply {
my ($cmd,$server)=@_;
my $answer=subreply($cmd,$server);
if ($answer eq 'con_lost') { $answer=subreply($cmd,$server); }
- if (($answer=~/^error:/) || ($answer=~/^refused/) ||
- ($answer=~/^rejected/)) {
+ if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
&logthis("<font color=blue>WARNING:".
" $cmd to $server returned $answer</font>");
}
@@ -358,6 +369,111 @@ sub homeserver {
return 'no_host';
}
+# ------------------------------------- Find the usernames behind a list of IDs
+
+sub idget {
+ my ($udom,@ids)=@_;
+ my %returnhash=();
+
+ my $tryserver;
+ foreach $tryserver (keys %libserv) {
+ if ($hostdom{$tryserver} eq $udom) {
+ my $idlist=join('&',@ids);
+ $idlist=~tr/A-Z/a-z/;
+ my $reply=&reply("idget:$udom:".$idlist,$tryserver);
+ my @answer=();
+ if ($reply ne 'con_lost') {
+ @answer=split(/\&/,$reply);
+ } ;
+ my $i;
+ for ($i=0;$i<=$#ids;$i++) {
+ if ($answer[$i]) {
+ $returnhash{$ids[$i]}=$answer[$i];
+ }
+ }
+ }
+ }
+ return %returnhash;
+}
+
+# ------------------------------------- Find the IDs behind a list of usernames
+
+sub idrget {
+ my ($udom,@unames)=@_;
+ my %returnhash=();
+ map {
+ $returnhash{$_}=(&userenvironment($udom,$_,'id'))[1];
+ } @unames;
+ return %returnhash;
+}
+
+# ------------------------------- Store away a list of names and associated IDs
+
+sub idput {
+ my ($udom,%ids)=@_;
+ my %servers=();
+ map {
+ my $uhom=&homeserver($_,$udom);
+ if ($uhom ne 'no_host') {
+ my $id=&escape($ids{$_});
+ $id=~tr/A-Z/a-z/;
+ my $unam=&escape($_);
+ if ($servers{$uhom}) {
+ $servers{$uhom}.='&'.$id.'='.$unam;
+ } else {
+ $servers{$uhom}=$id.'='.$unam;
+ }
+ &critical('put:'.$udom.':'.$unam.':environment:id='.$id,$uhom);
+ }
+ } keys %ids;
+ map {
+ &critical('idput:'.$udom.':'.$servers{$_},$_);
+ } keys %servers;
+}
+
+# ------------------------------------- Find the section of student in a course
+
+sub usection {
+ my ($udom,$unam,$courseid)=@_;
+ $courseid=~s/\_/\//g;
+ $courseid=~s/^(\w)/\/$1/;
+ map {
+ my ($key,$value)=split(/\=/,$_);
+ $key=&unescape($key);
+ if ($key=~/^$courseid(?:\/)*(\w+)*\_st$/) {
+ my $section=$1;
+ if ($key eq $courseid.'_st') { $section=''; }
+ my ($dummy,$end,$start)=split(/\_/,&unescape($value));
+ my $now=time;
+ my $notactive=0;
+ if ($start) {
+ if ($now<$start) { $notactive=1; }
+ }
+ if ($end) {
+ if ($now>$end) { $notactive=1; }
+ }
+ unless ($notactive) { return $section; }
+ }
+ } split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
+ &homeserver($unam,$udom)));
+ return '-1';
+}
+
+# ------------------------------------- Read an entry from a user's environment
+
+sub userenvironment {
+ my ($udom,$unam,@what)=@_;
+ my %returnhash=();
+ my @answer=split(/\&/,
+ &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what),
+ &homeserver($unam,$udom)));
+ my $i;
+ for ($i=0;$i<=$#what;$i++) {
+ $returnhash{$what[$i]}=&unescape($answer[$i]);
+ }
+ return %returnhash;
+}
+
# ----------------------------- Subscribe to a resource, return URL if possible
sub subscribe {
@@ -370,6 +486,9 @@ sub subscribe {
return 'not_found';
}
my $answer=reply("sub:$fname",$home);
+ if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
+ $answer.=' by '.$home;
+ }
return $answer;
}
@@ -381,14 +500,14 @@ sub repcopy {
my $transname="$filename.in.transfer";
if ((-e $filename) || (-e $transname)) { return OK; }
my $remoteurl=subscribe($filename);
- if ($remoteurl eq 'con_lost') {
- &logthis("Subscribe returned con_lost: $filename");
+ if ($remoteurl =~ /^con_lost by/) {
+ &logthis("Subscribe returned $remoteurl: $filename");
return HTTP_SERVICE_UNAVAILABLE;
} elsif ($remoteurl eq 'not_found') {
&logthis("Subscribe returned not_found: $filename");
return HTTP_NOT_FOUND;
- } elsif ($remoteurl eq 'rejected') {
- &logthis("Subscribe returned rejected: $filename");
+ } elsif ($remoteurl =~ /^rejected by/) {
+ &logthis("Subscribe returned $remoteurl: $filename");
return FORBIDDEN;
} elsif ($remoteurl eq 'directory') {
return OK;
@@ -546,6 +665,9 @@ sub coursedescription {
$returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
$ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;
$envhash{'course.'.$normalid.'.last_cache'}=time;
+ $envhash{'course.'.$normalid.'.home'}=$chome;
+ $envhash{'course.'.$normalid.'.domain'}=$cdomain;
+ $envhash{'course.'.$normalid.'.num'}=$cnum;
&appenv(%envhash);
return %returnhash;
}
@@ -772,8 +894,9 @@ sub allowed {
}
# Course: uri itself is a course
-
- if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$uri}
+ my $courseuri=$uri;
+ $courseuri=~s/\_(\d)/\/$1/;
+ if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseuri}
=~/$priv\&([^\:]*)/) {
$thisallowed.=$1;
}
@@ -968,11 +1091,6 @@ sub allowed {
return 'F';
}
-# ---------------------------------------------------------- Refresh State Info
-
-sub refreshstate {
-}
-
# ----------------------------------------------------------------- Define Role
sub definerole {
@@ -1031,7 +1149,7 @@ sub fileembstyle {
# ------------------------------------------------------------ Description Text
-sub filedecription {
+sub filedescription {
my $ending=shift;
return $fd{$ending};
}
@@ -1194,6 +1312,7 @@ sub condval {
sub EXT {
my $varname=shift;
+ unless ($varname) { return ''; }
my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
my $rest;
if ($therest[0]) {
@@ -1256,25 +1375,90 @@ sub EXT {
return $ENV{'course.'.$ENV{'request.course.id'}.$section.'.'.
$spacequalifierrest};
} elsif ($realm eq 'resource') {
-# ----------------------------------------------------------- resource metadata
- my $uri=&declutter($ENV{'request.filename'});
- my $filename=$perlvar{'lonDocRoot'}.'/res/'.$ENV.'.meta';
- if (-e $filename) {
- my @content;
- {
- my $fh=Apache::File->new($filename);
- @content=<$fh>;
- }
- if (join('',@content)=~
- /\<$space[^\>]*\>([^\<]*)\<\/$space\>/) {
- return $1;
- } else {
- return '';
- }
- }
- } elsif ($realm eq 'userdata') {
- my $uhome=&homeserver($qualifier,$space);
-# ----------------------------------------------- userdata.domain.name.resource
+ if ($ENV{'request.course.id'}) {
+# ----------------------------------------------------- Cascading lookup scheme
+ my $symbp=&symbread();
+ my $mapp=(split(/\_\_\_/,$symbp))[0];
+
+ my $symbparm=$symbp.'.'.$spacequalifierrest;
+ my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
+
+ my $seclevel=
+ $ENV{'request.course.id'}.'.['.
+ $ENV{'request.course.sec'}.'].'.$spacequalifierrest;
+ my $seclevelr=
+ $ENV{'request.course.id'}.'.['.
+ $ENV{'request.course.sec'}.'].'.$symbparm;
+ my $seclevelm=
+ $ENV{'request.course.id'}.'.['.
+ $ENV{'request.course.sec'}.'].'.$mapparm;
+
+ my $courselevel=
+ $ENV{'request.course.id'}.'.'.$spacequalifierrest;
+ my $courselevelr=
+ $ENV{'request.course.id'}.'.'.$symbparm;
+ my $courselevelm=
+ $ENV{'request.course.id'}.'.'.$mapparm;
+
+
+# ----------------------------------------------------------- first, check user
+ my %resourcedata=get('resourcedata',
+ ($courselevelr,$courselevelm,$courselevel));
+ if ($resourcedata{$courselevelr}!~/^error\:/) {
+
+ if ($resourcedata{$courselevelr}) {
+ return $resourcedata{$courselevelr}; }
+ if ($resourcedata{$courselevelm}) {
+ return $resourcedata{$courselevelm}; }
+ if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }
+
+ }
+# -------------------------------------------------------- second, check course
+ my $section='';
+ if ($ENV{'request.course.sec'}) {
+ $section='_'.$ENV{'request.course.sec'};
+ }
+ my $reply=&reply('get:'.
+ $ENV{'course.'.$ENV{'request.course.id'}.$section.'.domain'}.':'.
+ $ENV{'course.'.$ENV{'request.course.id'}.$section.'.num'}.
+ ':resourcedata:'.
+ escape($seclevelr).':'.escape($seclevelm).':'.escape($seclevel).':'.
+ escape($courselevelr).':'.escape($courselevelm).':'.escape($courselevel),
+ $ENV{'course.'.$ENV{'request.course.id'}.$section.'.home'});
+ if ($reply!~/^error\:/) {
+ map {
+ my ($name,$value)=split(/\=/,$_);
+ $resourcedata{unescape($name)}=unescape($value);
+ } split(/\&/,$reply);
+
+ if ($resourcedata{$seclevelr}) { return $resourcedata{$seclevelr}; }
+ if ($resourcedata{$seclevelm}) { return $resourcedata{$seclevelm}; }
+ if ($resourcedata{$seclevel}) { return $resourcedata{$seclevel}; }
+
+ if ($resourcedata{$courselevelr}) {
+ return $resourcedata{$courselevelr}; }
+ if ($resourcedata{$courselevelm}) {
+ return $resourcedata{$courselevelm}; }
+ if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }
+
+ }
+
+# ------------------------------------------------------ third, check map parms
+ my %parmhash=();
+ my $thisparm='';
+ if (tie(%parmhash,'GDBM_File',
+ $ENV{'request.course.fn'}.'_parms.db',&GDBM_READER,0640)) {
+ $thisparm=$parmhash{$symbparm};
+ untie(%parmhash);
+ }
+ if ($thisparm) { return $thisparm; }
+ }
+
+# --------------------------------------------- last, look in resource metadata
+
+ my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest);
+ if ($metadata) { return $metadata; }
+
# ---------------------------------------------------- Any other user namespace
} elsif ($realm eq 'environment') {
# ----------------------------------------------------------------- environment
@@ -1288,6 +1472,43 @@ sub EXT {
return '';
}
+# ---------------------------------------------------------------- Get metadata
+
+sub metadata {
+ my ($uri,$what)=@_;
+ $uri=&declutter($uri);
+ my $filename=$uri;
+ $uri=~s/\.meta$//;
+ unless ($metacache{$uri.':keys'}) {
+ unless ($filename=~/\.meta$/) { $filename.='.meta'; }
+ my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
+ my $parser=HTML::TokeParser->new(\$metastring);
+ my $token;
+ while ($token=$parser->get_token) {
+ if ($token->[0] eq 'S') {
+ my $entry=$token->[1];
+ my $unikey=$entry;
+ if (defined($token->[2]->{'part'})) {
+ $unikey.='_'.$token->[2]->{'part'};
+ }
+ if (defined($token->[2]->{'name'})) {
+ $unikey.='_'.$token->[2]->{'name'};
+ }
+ if ($metacache{$uri.':keys'}) {
+ $metacache{$uri.':keys'}.=','.$unikey;
+ } else {
+ $metacache{$uri.':keys'}=$unikey;
+ }
+ map {
+ $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};
+ } @{$token->[3]};
+ $metacache{$uri.':'.$unikey}=$parser->get_text('/'.$entry);
+ }
+ }
+ }
+ return $metacache{$uri.':'.$what};
+}
+
# ------------------------------------------------- Update symbolic store links
sub symblist {
@@ -1340,6 +1561,9 @@ sub symbread {
&GDBM_READER,0640)) {
# ---------------------------------------------- Get ID(s) for current resource
my $ids=$bighash{'ids_/res/'.$thisfn};
+ unless ($ids) {
+ $ids=$bighash{'ids_/'.$thisfn};
+ }
if ($ids) {
# ------------------------------------------------------------------- Has ID(s)
my @possibilities=split(/\,/,$ids);
@@ -1367,7 +1591,9 @@ sub symbread {
untie(%bighash)
}
}
- if ($syval) { return $syval.'___'.$thisfn; }
+ if ($syval) {
+ return $syval.'___'.$thisfn;
+ }
}
&appenv('request.ambiguous' => $thisfn);
return '';
@@ -1548,6 +1774,7 @@ if ($readit ne 'done') {
}
}
+%metacache=();
$readit='done';
&logthis('<font color=yellow>INFO: Read configuration</font>');