version 1.58, 2000/11/02 17:42:09
|
version 1.68, 2000/11/22 12:14:56
|
Line 43
|
Line 43
|
# state string |
# state string |
# condval(index) : value of condition index based on state |
# condval(index) : value of condition index based on state |
# EXT(name) : value of a variable |
# EXT(name) : value of a variable |
# refreshstate() : refresh the state information string |
|
# symblist(map,hash) : Updates symbolic storage links |
# symblist(map,hash) : Updates symbolic storage links |
# symbread([filename]) : returns the data handle (filename optional) |
# symbread([filename]) : returns the data handle (filename optional) |
# rndseed() : returns a random seed |
# rndseed() : returns a random seed |
Line 68
|
Line 67
|
# 10/04 Gerd Kortemeyer |
# 10/04 Gerd Kortemeyer |
# 10/04 Guy Albertelli |
# 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/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 Gerd Kortemeyer |
|
|
package Apache::lonnet; |
package Apache::lonnet; |
|
|
Line 123 sub reply {
|
Line 122 sub reply {
|
my ($cmd,$server)=@_; |
my ($cmd,$server)=@_; |
my $answer=subreply($cmd,$server); |
my $answer=subreply($cmd,$server); |
if ($answer eq 'con_lost') { $answer=subreply($cmd,$server); } |
if ($answer eq 'con_lost') { $answer=subreply($cmd,$server); } |
if (($answer=~/^error:/) || ($answer=~/^refused/) || |
if (($answer=~/^refused/) || ($answer=~/^rejected/)) { |
($answer=~/^rejected/)) { |
|
&logthis("<font color=blue>WARNING:". |
&logthis("<font color=blue>WARNING:". |
" $cmd to $server returned $answer</font>"); |
" $cmd to $server returned $answer</font>"); |
} |
} |
Line 370 sub subscribe {
|
Line 368 sub subscribe {
|
return 'not_found'; |
return 'not_found'; |
} |
} |
my $answer=reply("sub:$fname",$home); |
my $answer=reply("sub:$fname",$home); |
|
if (($answer eq 'con_lost') || ($answer eq 'rejected')) { |
|
$answer.=' by '.$home; |
|
} |
return $answer; |
return $answer; |
} |
} |
|
|
Line 381 sub repcopy {
|
Line 382 sub repcopy {
|
my $transname="$filename.in.transfer"; |
my $transname="$filename.in.transfer"; |
if ((-e $filename) || (-e $transname)) { return OK; } |
if ((-e $filename) || (-e $transname)) { return OK; } |
my $remoteurl=subscribe($filename); |
my $remoteurl=subscribe($filename); |
if ($remoteurl eq 'con_lost') { |
if ($remoteurl =~ /^con_lost by/) { |
&logthis("Subscribe returned con_lost: $filename"); |
&logthis("Subscribe returned $remoteurl: $filename"); |
return HTTP_SERVICE_UNAVAILABLE; |
return HTTP_SERVICE_UNAVAILABLE; |
} elsif ($remoteurl eq 'not_found') { |
} elsif ($remoteurl eq 'not_found') { |
&logthis("Subscribe returned not_found: $filename"); |
&logthis("Subscribe returned not_found: $filename"); |
return HTTP_NOT_FOUND; |
return HTTP_NOT_FOUND; |
} elsif ($remoteurl eq 'rejected') { |
} elsif ($remoteurl =~ /^rejected by/) { |
&logthis("Subscribe returned rejected: $filename"); |
&logthis("Subscribe returned $remoteurl: $filename"); |
return FORBIDDEN; |
return FORBIDDEN; |
} elsif ($remoteurl eq 'directory') { |
} elsif ($remoteurl eq 'directory') { |
return OK; |
return OK; |
Line 546 sub coursedescription {
|
Line 547 sub coursedescription {
|
$returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'. |
$returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'. |
$ENV{'user.name'}.'_'.$cdomain.'_'.$cnum; |
$ENV{'user.name'}.'_'.$cdomain.'_'.$cnum; |
$envhash{'course.'.$normalid.'.last_cache'}=time; |
$envhash{'course.'.$normalid.'.last_cache'}=time; |
|
$envhash{'course.'.$normalid.'.home'}=$chome; |
|
$envhash{'course.'.$normalid.'.domain'}=$cdomain; |
|
$envhash{'course.'.$normalid.'.num'}=$cnum; |
&appenv(%envhash); |
&appenv(%envhash); |
return %returnhash; |
return %returnhash; |
} |
} |
Line 772 sub allowed {
|
Line 776 sub allowed {
|
} |
} |
|
|
# Course: uri itself is a course |
# Course: uri itself is a course |
|
my $courseuri=$uri; |
if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$uri} |
$courseuri=~s/\_(\d)/\/$1/; |
|
if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseuri} |
=~/$priv\&([^\:]*)/) { |
=~/$priv\&([^\:]*)/) { |
$thisallowed.=$1; |
$thisallowed.=$1; |
} |
} |
Line 968 sub allowed {
|
Line 973 sub allowed {
|
return 'F'; |
return 'F'; |
} |
} |
|
|
# ---------------------------------------------------------- Refresh State Info |
|
|
|
sub refreshstate { |
|
} |
|
|
|
# ----------------------------------------------------------------- Define Role |
# ----------------------------------------------------------------- Define Role |
|
|
sub definerole { |
sub definerole { |
Line 1194 sub condval {
|
Line 1194 sub condval {
|
|
|
sub EXT { |
sub EXT { |
my $varname=shift; |
my $varname=shift; |
|
unless ($varname) { return ''; } |
my ($realm,$space,$qualifier,@therest)=split(/\./,$varname); |
my ($realm,$space,$qualifier,@therest)=split(/\./,$varname); |
my $rest; |
my $rest; |
if ($therest[0]) { |
if ($therest[0]) { |
Line 1256 sub EXT {
|
Line 1257 sub EXT {
|
return $ENV{'course.'.$ENV{'request.course.id'}.$section.'.'. |
return $ENV{'course.'.$ENV{'request.course.id'}.$section.'.'. |
$spacequalifierrest}; |
$spacequalifierrest}; |
} elsif ($realm eq 'resource') { |
} elsif ($realm eq 'resource') { |
# ----------------------------------------------------------- resource metadata |
if ($ENV{'request.course.id'}) { |
|
# ----------------------------------------------------- Cascading lookup scheme |
|
my $symbparm=&symbread().'.'.$spacequalifierrest; |
|
my $reslevel= |
|
$ENV{'request.course.id'}.'.'.$symbparm; |
|
my $seclevel= |
|
$ENV{'request.course.id'}.'.'. |
|
$ENV{'request.course.sec'}.'.'.$spacequalifierrest; |
|
my $courselevel= |
|
$ENV{'request.course.id'}.'.'.$spacequalifierrest; |
|
|
|
# ----------------------------------------------------------- first, check user |
|
my %resourcedata=get('resourcedata',($reslevel,$seclevel,$courselevel)); |
|
if ($resourcedata{$reslevel}!~/^error\:/) { |
|
if ($resourcedata{$reslevel}) { return $resourcedata{$reslevel}; } |
|
if ($resourcedata{$seclevel}) { return $resourcedata{$seclevel}; } |
|
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($reslevel).':'.escape($seclevel).':'.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{$reslevel}) { return $resourcedata{$reslevel}; } |
|
if ($resourcedata{$seclevel}) { return $resourcedata{$seclevel}; } |
|
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 $uri=&declutter($ENV{'request.filename'}); |
my $filename=$perlvar{'lonDocRoot'}.'/res/'.$ENV.'.meta'; |
my $filename=$perlvar{'lonDocRoot'}.'/res/'.$uri.'.meta'; |
if (-e $filename) { |
if (-e $filename) { |
my @content; |
my @content; |
{ |
{ |
Line 1268 sub EXT {
|
Line 1319 sub EXT {
|
if (join('',@content)=~ |
if (join('',@content)=~ |
/\<$space[^\>]*\>([^\<]*)\<\/$space\>/) { |
/\<$space[^\>]*\>([^\<]*)\<\/$space\>/) { |
return $1; |
return $1; |
} else { |
} |
return ''; |
} |
} |
|
} |
|
} elsif ($realm eq 'userdata') { |
|
my $uhome=&homeserver($qualifier,$space); |
|
# ----------------------------------------------- userdata.domain.name.resource |
|
# ---------------------------------------------------- Any other user namespace |
# ---------------------------------------------------- Any other user namespace |
} elsif ($realm eq 'environment') { |
} elsif ($realm eq 'environment') { |
# ----------------------------------------------------------------- environment |
# ----------------------------------------------------------------- environment |
Line 1340 sub symbread {
|
Line 1386 sub symbread {
|
&GDBM_READER,0640)) { |
&GDBM_READER,0640)) { |
# ---------------------------------------------- Get ID(s) for current resource |
# ---------------------------------------------- Get ID(s) for current resource |
my $ids=$bighash{'ids_/res/'.$thisfn}; |
my $ids=$bighash{'ids_/res/'.$thisfn}; |
|
unless ($ids) { |
|
$ids=$bighash{'ids_/'.$thisfn}; |
|
} |
if ($ids) { |
if ($ids) { |
# ------------------------------------------------------------------- Has ID(s) |
# ------------------------------------------------------------------- Has ID(s) |
my @possibilities=split(/\,/,$ids); |
my @possibilities=split(/\,/,$ids); |
Line 1367 sub symbread {
|
Line 1416 sub symbread {
|
untie(%bighash) |
untie(%bighash) |
} |
} |
} |
} |
if ($syval) { return $syval.'___'.$thisfn; } |
if ($syval) { |
|
return $syval.'___'.$thisfn; |
|
} |
} |
} |
&appenv('request.ambiguous' => $thisfn); |
&appenv('request.ambiguous' => $thisfn); |
return ''; |
return ''; |
Line 1418 sub filelocation {
|
Line 1469 sub filelocation {
|
my ($dir,$file) = @_; |
my ($dir,$file) = @_; |
my $location; |
my $location; |
$file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces |
$file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces |
$file=~s/^$perlvar{'lonDocRoot'}//; |
if ($file=~m:^/~:) { # is a contruction space reference |
$file=~s:^/*res::; |
$location = $file; |
if ( !( $file =~ m:^/:) ) { |
$location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; |
$location = $dir. '/'.$file; |
|
} else { |
} 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 / |
$location=~s://+:/:g; # remove duplicate / |
while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/.. |
while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/.. |