--- loncom/lonnet/perl/lonnet.pm 2000/10/31 19:28:11 1.56 +++ loncom/lonnet/perl/lonnet.pm 2000/11/15 23:25:59 1.64 @@ -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 Gerd Kortemeyer package Apache::lonnet; @@ -370,6 +369,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 +383,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 +548,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; } @@ -885,7 +890,9 @@ sub allowed { if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,$csec\,/) || ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) { if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) { - &log('Locked by res: '.$priv.' for '.$uri.' due to '. + &log($ENV{'user.domain'},$ENV{'user.name'}, + $ENV{'user.host'}, + 'Locked by res: '.$priv.' for '.$uri.' due to '. $cdom.'/'.$cnum.'/'.$csec.' expire '. $ENV{$prefix.'priv.'.$priv.'.lock.expire'}); return ''; @@ -894,7 +901,9 @@ sub allowed { if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,$csec\,/) || ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) { if ($ENV{'priv.'.$priv.'.lock.expire'}>time) { - &log('Locked by priv: '.$priv.' for '.$uri.' due to '. + &log($ENV{'user.domain'},$ENV{'user.name'}, + $ENV{'user.host'}, + 'Locked by priv: '.$priv.' for '.$uri.' due to '. $cdom.'/'.$cnum.'/'.$csec.' expire '. $ENV{$prefix.'priv.'.$priv.'.lock.expire'}); return ''; @@ -923,7 +932,8 @@ sub allowed { my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'} =~/\,$rolecode\,/) { - &log('Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. + &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, + 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. $ENV{'request.course.id'}); return ''; } @@ -942,7 +952,8 @@ sub allowed { } if (join('',@content)=~ /\]*\>[^\<]*$rolecode[^\<]*\<\/roledeny\>/) { - &log('Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); + &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, + 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); return ''; } @@ -962,11 +973,6 @@ sub allowed { return 'F'; } -# ---------------------------------------------------------- Refresh State Info - -sub refreshstate { -} - # ----------------------------------------------------------------- Define Role sub definerole { @@ -1186,7 +1192,7 @@ sub condval { # --------------------------------------------------------- Value of a Variable -sub varval { +sub EXT { my $varname=shift; my ($realm,$space,$qualifier,@therest)=split(/\./,$varname); my $rest; @@ -1195,15 +1201,21 @@ sub varval { } else { $rest=''; } + my $qualifierrest=$qualifier; + if ($rest) { $qualifierrest.='.'.$rest; } + my $spacequalifierrest=$space; + if ($qualifierrest) { $spacequalifierrest.='.'.$qualifierrest; } if ($realm eq 'user') { # --------------------------------------------------------------- user.resource if ($space eq 'resource') { + my %restored=&restore; + return $restored{$qualifierrest}; # ----------------------------------------------------------------- user.access } elsif ($space eq 'access') { return &allowed($qualifier,$rest); # ------------------------------------------ user.preferences, user.environment } elsif (($space eq 'preferences') || ($space eq 'environment')) { - return $ENV{join('.',('environment',$qualifier,$rest))}; + return $ENV{join('.',('environment',$qualifierrest))}; # ----------------------------------------------------------------- user.course } elsif ($space eq 'course') { return $ENV{join('.',('request.course',$qualifier))}; @@ -1231,33 +1243,82 @@ sub varval { # ------------------------------------------------------------- request.browser if ($space eq 'browser') { return $ENV{'browser.'.$qualifier}; - } elsif ($space eq 'filename') { - return $ENV{'request.filename'}; +# ------------------------------------------------------------ request.filename + } else { + return $ENV{'request.'.$spacequalifierrest}; } } elsif ($realm eq 'course') { # ---------------------------------------------------------- course.description - if ($space eq 'description') { - my %reply=&coursedescription($ENV{'request.course.id'}); - return $reply{'description'}; -# ------------------------------------------------------------------- course.id - } elsif ($space eq 'id') { - return $ENV{'request.course.id'}; -# -------------------------------------------------- Any other course namespace - } else { - my ($cdom,$cnam)=split(/\_/,$ENV{'request.course.id'}); - my $chome=&homeserver($cnam,$cdom); - my $item=join('.',($qualifier,$rest)); - return &unescape - (&reply('get:'.$cdom.':'.$cnam.':'.&escape($space).':'. - &escape($item),$chome)); + my $section=''; + if ($ENV{'request.course.sec'}) { + $section='_'.$ENV{'request.course.sec'}; + } + return $ENV{'course.'.$ENV{'request.course.id'}.$section.'.'. + $spacequalifierrest}; + } elsif ($realm eq 'resource') { + if ($ENV{'request.course.id'}) { +# ----------------------------------------------------- Cascading lookup scheme + my $reslevel= + $ENV{'request.course.id'}.'.'.&symbread().'.'.$spacequalifierrest; + 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 + + if ($ENV{'resource.parms.'.$reslevel}) { + return $ENV{'resource.parms.'.$reslevel}; + } + } + +# --------------------------------------------- last, look in 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; + } } - } elsif ($realm eq 'userdata') { - my $uhome=&homeserver($qualifier,$space); -# ----------------------------------------------- userdata.domain.name.resource # ---------------------------------------------------- Any other user namespace } elsif ($realm eq 'environment') { # ----------------------------------------------------------------- environment - return $ENV{join('.',($space,$qualifier,$rest))}; + return $ENV{$spacequalifierrest}; } elsif ($realm eq 'system') { # ----------------------------------------------------------------- system.time if ($space eq 'time') { @@ -1267,6 +1328,21 @@ sub varval { return ''; } +# ---------------------------------------- Append resource parms to environment + +sub appendparms { + my ($symb,$parms)=@_; + my %storehash=(); + my $prefix='resource.parms.'.$ENV{'request.course.id'}.'.'.$symb; + map { + my ($typename,$value)=split(/\=/,$_); + my ($type,$name)=split(/\:/,$typename); + $storehash{$prefix.'.'.unescape($name)}=unescape($value); + $storehash{$prefix.'.'.unescape($name).'.type'}=unescape($type); + } split(/\&/,$parms); + &appenv(%storehash); +} + # ------------------------------------------------- Update symbolic store links sub symblist { @@ -1298,6 +1374,7 @@ sub symbread { my %hash; my %bighash; my $syval=''; + my $parms=''; if (($ENV{'request.course.fn'}) && ($thisfn)) { if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db', &GDBM_READER,0640)) { @@ -1325,6 +1402,7 @@ sub symbread { if ($#possibilities==0) { # ----------------------------------------------- There is only one possibility my ($mapid,$resid)=split(/\./,$ids); + $parms=$bighash{'param_'.$ids}; $syval=declutter($bighash{'map_id_'.$mapid}).'___'.$resid; } else { # ------------------------------------------ There is more than one possibility @@ -1335,6 +1413,7 @@ sub symbread { my ($mapid,$resid)=split(/\./,$_); if ($bighash{'map_type_'.$mapid} ne 'page') { $realpossible++; + $parms=$bighash{'param_'.$_}; $syval=declutter($bighash{'map_id_'.$mapid}). '___'.$resid; } @@ -1346,7 +1425,12 @@ sub symbread { untie(%bighash) } } - if ($syval) { return $syval.'___'.$thisfn; } + if ($syval) { + if ($parms) { + &appendparms($syval.'___'.$thisfn,$parms); + } + return $syval.'___'.$thisfn; + } } &appenv('request.ambiguous' => $thisfn); return ''; @@ -1397,12 +1481,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/..