--- loncom/lonnet/perl/lonnet.pm 2000/10/31 22:32:32 1.57
+++ loncom/lonnet/perl/lonnet.pm 2000/11/24 19:59:31 1.69
@@ -42,8 +42,7 @@
# directcondval(index) : reading condition value of single condition from
# state string
# condval(index) : value of condition index based on state
-# varval(name) : value of a variable
-# refreshstate() : refresh the state information string
+# EXT(name) : value of a variable
# symblist(map,hash) : Updates symbolic storage links
# symbread([filename]) : returns the data handle (filename optional)
# rndseed() : returns a random seed
@@ -68,7 +67,7 @@
# 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 Gerd Kortemeyer
+# 10/30,10/31,11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25 Gerd Kortemeyer
package Apache::lonnet;
@@ -123,8 +122,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>");
}
@@ -370,6 +368,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 +382,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 +547,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 +776,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 +973,6 @@ sub allowed {
return 'F';
}
-# ---------------------------------------------------------- Refresh State Info
-
-sub refreshstate {
-}
-
# ----------------------------------------------------------------- Define Role
sub definerole {
@@ -1192,8 +1192,9 @@ sub condval {
# --------------------------------------------------------- Value of a Variable
-sub varval {
+sub EXT {
my $varname=shift;
+ unless ($varname) { return ''; }
my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
my $rest;
if ($therest[0]) {
@@ -1256,9 +1257,88 @@ sub varval {
return $ENV{'course.'.$ENV{'request.course.id'}.$section.'.'.
$spacequalifierrest};
} elsif ($realm eq 'resource') {
-# ----------------------------------------------------------- resource metadata
+ 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 $uri=&declutter($ENV{'request.filename'});
- my $filename=$perlvar{'lonDocRoot'}.'/res/'.$ENV.'.meta';
+ my $filename=$perlvar{'lonDocRoot'}.'/res/'.$uri.'.meta';
if (-e $filename) {
my @content;
{
@@ -1268,13 +1348,8 @@ sub varval {
if (join('',@content)=~
/\<$space[^\>]*\>([^\<]*)\<\/$space\>/) {
return $1;
- } else {
- return '';
- }
- }
- } elsif ($realm eq 'userdata') {
- my $uhome=&homeserver($qualifier,$space);
-# ----------------------------------------------- userdata.domain.name.resource
+ }
+ }
# ---------------------------------------------------- Any other user namespace
} elsif ($realm eq 'environment') {
# ----------------------------------------------------------------- environment
@@ -1340,6 +1415,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 +1445,9 @@ sub symbread {
untie(%bighash)
}
}
- if ($syval) { return $syval.'___'.$thisfn; }
+ if ($syval) {
+ return $syval.'___'.$thisfn;
+ }
}
&appenv('request.ambiguous' => $thisfn);
return '';
@@ -1418,12 +1498,17 @@ sub filelocation {
my ($dir,$file) = @_;
my $location;
$file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces
- $file=~s/^$perlvar{'lonDocRoot'}//;
- $file=~s:^/*res::;
- if ( !( $file =~ m:^/:) ) {
- $location = $dir. '/'.$file;
+ if ($file=~m:^/~:) { # is a contruction space reference
+ $location = $file;
+ $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
} else {
- $location = '/home/httpd/html/res'.$file;
+ $file=~s/^$perlvar{'lonDocRoot'}//;
+ $file=~s:^/*res::;
+ if ( !( $file =~ m:^/:) ) {
+ $location = $dir. '/'.$file;
+ } else {
+ $location = '/home/httpd/html/res'.$file;
+ }
}
$location=~s://+:/:g; # remove duplicate /
while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..