version 1.52, 2000/10/28 17:26:35
|
version 1.68, 2000/11/22 12:14:56
|
Line 24
|
Line 24
|
# revokerole (udom,uname,url,role) : Revoke a role for url |
# revokerole (udom,uname,url,role) : Revoke a role for url |
# revokecustomrole (udom,uname,url,rdom,rnam,rolename) : Revoke a custom role |
# revokecustomrole (udom,uname,url,rdom,rnam,rolename) : Revoke a custom role |
# appenv(hash) : adds hash to session environment |
# appenv(hash) : adds hash to session environment |
|
# delenv(varname) : deletes all environment entries starting with varname |
# store(hash) : stores hash permanently for this url |
# store(hash) : stores hash permanently for this url |
# cstore(hash) : critical store |
# cstore(hash) : critical store |
# restore : returns hash for this url |
# restore : returns hash for this url |
Line 41
|
Line 42
|
# directcondval(index) : reading condition value of single condition from |
# directcondval(index) : reading condition value of single condition from |
# state string |
# state string |
# condval(index) : value of condition index based on state |
# condval(index) : value of condition index based on state |
# varval(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 66
|
Line 66
|
# 08/22,08/28,08/31,09/01,09/02,09/04,09/05,09/25,09/28,09/30 Gerd Kortemeyer |
# 08/22,08/28,08/31,09/01,09/02,09/04,09/05,09/25,09/28,09/30 Gerd Kortemeyer |
# 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/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29, |
# 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 122 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 250 sub appenv {
|
Line 249 sub appenv {
|
} |
} |
return 'ok'; |
return 'ok'; |
} |
} |
|
# ----------------------------------------------------- Delete from Environment |
|
|
|
sub delenv { |
|
my $delthis=shift; |
|
my %newenv=(); |
|
if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { |
|
&logthis("<font color=blue>WARNING: ". |
|
"Attempt to delete from environment ".$delthis); |
|
return 'error'; |
|
} |
|
my @oldenv; |
|
{ |
|
my $fh; |
|
unless ($fh=Apache::File->new("$ENV{'user.environment'}")) { |
|
return 'error'; |
|
} |
|
@oldenv=<$fh>; |
|
} |
|
{ |
|
my $fh; |
|
unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) { |
|
return 'error'; |
|
} |
|
map { |
|
unless ($_=~/^$delthis/) { print $fh $_; } |
|
} @oldenv; |
|
} |
|
return 'ok'; |
|
} |
|
|
# ------------------------------ Find server with least workload from spare.tab |
# ------------------------------ Find server with least workload from spare.tab |
|
|
Line 340 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 351 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 499 sub coursedescription {
|
Line 530 sub coursedescription {
|
if ($chome ne 'no_host') { |
if ($chome ne 'no_host') { |
my $rep=reply("dump:$cdomain:$cnum:environment",$chome); |
my $rep=reply("dump:$cdomain:$cnum:environment",$chome); |
if ($rep ne 'con_lost') { |
if ($rep ne 'con_lost') { |
my %cachehash=(); |
my $normalid=$courseid; |
|
$normalid=~s/\//\_/g; |
|
my %envhash=(); |
my %returnhash=('home' => $chome, |
my %returnhash=('home' => $chome, |
'domain' => $cdomain, |
'domain' => $cdomain, |
'num' => $cnum); |
'num' => $cnum); |
Line 508 sub coursedescription {
|
Line 541 sub coursedescription {
|
$name=&unescape($name); |
$name=&unescape($name); |
$value=&unescape($value); |
$value=&unescape($value); |
$returnhash{$name}=$value; |
$returnhash{$name}=$value; |
if ($name eq 'description') { |
$envhash{'course.'.$normalid.'.'.$name}=$value; |
$cachehash{$courseid}=$value; |
|
} |
|
} split(/\&/,$rep); |
} split(/\&/,$rep); |
$returnhash{'url'}='/res/'.declutter($returnhash{'url'}); |
$returnhash{'url'}='/res/'.declutter($returnhash{'url'}); |
$returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'. |
$returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'. |
$ENV{'user.name'}.'_'.$cdomain.'_'.$cnum; |
$ENV{'user.name'}.'_'.$cdomain.'_'.$cnum; |
put ('nohist_coursedescriptions',%cachehash); |
$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; |
return %returnhash; |
} |
} |
} |
} |
Line 717 sub allowed {
|
Line 752 sub allowed {
|
my ($priv,$uri)=@_; |
my ($priv,$uri)=@_; |
$uri=&declutter($uri); |
$uri=&declutter($uri); |
|
|
# Free bre access to adm resources |
# Free bre access to adm and meta resources |
|
|
if (($uri=~/^adm\//) && ($priv eq 'bre')) { |
if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) { |
return 'F'; |
return 'F'; |
} |
} |
|
|
Line 741 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 776 sub allowed {
|
Line 812 sub allowed {
|
my $pathname=$uri; |
my $pathname=$uri; |
$pathname=~s/\/$filename$//; |
$pathname=~s/\/$filename$//; |
if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ |
if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ |
/\&$filename\:(\d+)\&/) { |
/\&$filename\:([\d\|]+)\&/) { |
$statecond=$1; |
$statecond=$1; |
if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} |
if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} |
=~/$priv\&([^\:]*)/) { |
=~/$priv\&([^\:]*)/) { |
Line 784 sub allowed {
|
Line 820 sub allowed {
|
$checkreferer=0; |
$checkreferer=0; |
} |
} |
} |
} |
|
|
if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) { |
if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) { |
my @uriparts=split(/\//,&declutter($ENV{'HTTP_REFERER'})); |
my $refuri=$ENV{'HTTP_REFERER'}; |
|
$refuri=~s/^http\:\/\/$ENV{'request.host'}//i; |
|
$refuri=&declutter($refuri); |
|
my @uriparts=split(/\//,$refuri); |
my $filename=$uriparts[$#uriparts]; |
my $filename=$uriparts[$#uriparts]; |
my $pathname=$uri; |
my $pathname=$refuri; |
$pathname=~s/\/$filename$//; |
$pathname=~s/\/$filename$//; |
if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ |
my @filenameparts=split(/\./,$uri); |
/\&$filename\:(\d+)\&/) { |
if (&fileembstyle($filenameparts[$#filenameparts]) ne 'ssi') { |
$statecond=$1; |
if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~ |
|
/\&$filename\:([\d\|]+)\&/) { |
|
my $refstatecond=$1; |
if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} |
if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid} |
=~/$priv\&([^\:]*)/) { |
=~/$priv\&([^\:]*)/) { |
$thisallowed.=$1; |
$thisallowed.=$1; |
|
$uri=$refuri; |
|
$statecond=$refstatecond; |
} |
} |
|
} |
} |
} |
} |
} |
} |
} |
Line 824 sub allowed {
|
Line 869 sub allowed {
|
# |
# |
|
|
# Possibly locked functionality, check all courses |
# Possibly locked functionality, check all courses |
|
# Locks might take effect only after 10 minutes cache expiration for other |
|
# courses, and 2 minutes for current course |
|
|
my $envkey; |
my $envkey; |
if ($thisallowed=~/L/) { |
if ($thisallowed=~/L/) { |
foreach $envkey (keys %ENV) { |
foreach $envkey (keys %ENV) { |
if ($envkey=~/^user\.role\.st\.([^\.]*)/) { |
if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) { |
my ($cdom,$cnum,$csec)=split(/\//,$1); |
my $courseid=$2; |
my %locks=(); |
my $roleid=$1.'.'.$2; |
map { |
my $expiretime=600; |
my ($name,$value)=split(/\=/,$_); |
if ($ENV{'request.role'} eq $roleid) { |
$locks{&unescape($name)}=&unescape($value); |
$expiretime=120; |
} split(/\&/,&reply('get:'.$cdom.':'.$cnum. |
} |
':environment:'.&escape('priv.'.$priv.'.lock.sections'). |
my ($cdom,$cnum,$csec)=split(/\//,$courseid); |
':'.&escape('priv.'.$priv.'.lock.expire'). |
my $prefix='course.'.$cdom.'_'.$cnum.'.'; |
':'.&escape('res.'.$uri.'.lock.sections'). |
if ((time-$ENV{$prefix.'last_cache'})>$expiretime) { |
':'.&escape('res.'.$uri.'.lock.expire'), |
&coursedescription($courseid); |
&homeserver($cnum,$cdom))); |
} |
if (($locks{'res.'.$uri.'.lock.sections'}=~/\,$csec\,/) || |
if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,$csec\,/) |
($locks{'res.'.$uri.'.lock.sections'} eq 'all')) { |
|| ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) { |
if ($locks{'res.'.$uri.'.lock.expire'}>time) { |
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 '. |
$cdom.'/'.$cnum.'/'.$csec.' expire '. |
$locks{'priv.'.$priv.'.lock.expire'}); |
$ENV{$prefix.'priv.'.$priv.'.lock.expire'}); |
return ''; |
return ''; |
} |
} |
} |
} |
if (($locks{'priv.'.$priv.'.lock.sections'}=~/\,$csec\,/) || |
if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,$csec\,/) |
($locks{'priv.'.$priv.'.lock.sections'} eq 'all')) { |
|| ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) { |
if ($locks{'priv.'.$priv.'.lock.expire'}>time) { |
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 '. |
$cdom.'/'.$cnum.'/'.$csec.' expire '. |
$locks{'priv.'.$priv.'.lock.expire'}); |
$ENV{$prefix.'priv.'.$priv.'.lock.expire'}); |
return ''; |
return ''; |
} |
} |
} |
} |
Line 874 sub allowed {
|
Line 925 sub allowed {
|
# Now user is definitely in a course |
# Now user is definitely in a course |
# |
# |
|
|
|
|
|
# Course preferences |
|
|
|
if ($thisallowed=~/C/) { |
|
my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; |
|
if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'} |
|
=~/\,$rolecode\,/) { |
|
&log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, |
|
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. |
|
$ENV{'request.course.id'}); |
|
return ''; |
|
} |
|
} |
|
|
|
# Resource preferences |
|
|
|
if ($thisallowed=~/R/) { |
|
my $rolecode=(split(/\./,$ENV{'request.role'}))[0]; |
|
my $filename=$perlvar{'lonDocRoot'}.'/res/'.$uri.'.meta'; |
|
if (-e $filename) { |
|
my @content; |
|
{ |
|
my $fh=Apache::File->new($filename); |
|
@content=<$fh>; |
|
} |
|
if (join('',@content)=~ |
|
/\<roledeny[^\>]*\>[^\<]*$rolecode[^\<]*\<\/roledeny\>/) { |
|
&log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'}, |
|
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); |
|
return ''; |
|
|
|
} |
|
} |
|
} |
|
|
# Restricted by state? |
# Restricted by state? |
|
|
if ($thisallowed=~/X/) { |
if ($thisallowed=~/X/) { |
Line 887 sub allowed {
|
Line 973 sub allowed {
|
return 'F'; |
return 'F'; |
} |
} |
|
|
# ---------------------------------------------------------- Refresh State Info |
|
|
|
sub refreshstate { |
|
} |
|
|
|
# ----------------------------------------------------------------- Define Role |
# ----------------------------------------------------------------- Define Role |
|
|
sub definerole { |
sub definerole { |
Line 1071 sub directcondval {
|
Line 1152 sub directcondval {
|
sub condval { |
sub condval { |
my $condidx=shift; |
my $condidx=shift; |
my $result=0; |
my $result=0; |
|
my $allpathcond=''; |
|
map { |
|
if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_})) { |
|
$allpathcond.= |
|
'('.$ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_}.')|'; |
|
} |
|
} split(/\|/,$condidx); |
|
$allpathcond=~s/\|$//; |
if ($ENV{'request.course.id'}) { |
if ($ENV{'request.course.id'}) { |
if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$condidx})) { |
if ($allpathcond) { |
my $operand='|'; |
my $operand='|'; |
my @stack; |
my @stack; |
map { |
map { |
Line 1095 sub condval {
|
Line 1184 sub condval {
|
$result=$result>$new?$result:$new; |
$result=$result>$new?$result:$new; |
} |
} |
} |
} |
} ($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$condidx}=~ |
} ($allpathcond=~/(\d+|\(|\)|\&|\|)/g); |
/(\d+|\(|\)|\&|\|)/g); |
|
} |
} |
} |
} |
return $result; |
return $result; |
Line 1104 sub condval {
|
Line 1192 sub condval {
|
|
|
# --------------------------------------------------------- Value of a Variable |
# --------------------------------------------------------- Value of a Variable |
|
|
sub varval { |
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 1113 sub varval {
|
Line 1202 sub varval {
|
} else { |
} else { |
$rest=''; |
$rest=''; |
} |
} |
|
my $qualifierrest=$qualifier; |
|
if ($rest) { $qualifierrest.='.'.$rest; } |
|
my $spacequalifierrest=$space; |
|
if ($qualifierrest) { $spacequalifierrest.='.'.$qualifierrest; } |
if ($realm eq 'user') { |
if ($realm eq 'user') { |
# --------------------------------------------------------------- user.resource |
# --------------------------------------------------------------- user.resource |
if ($space eq 'resource') { |
if ($space eq 'resource') { |
|
my %restored=&restore; |
|
return $restored{$qualifierrest}; |
# ----------------------------------------------------------------- user.access |
# ----------------------------------------------------------------- user.access |
} elsif ($space eq 'access') { |
} elsif ($space eq 'access') { |
return &allowed($qualifier,$rest); |
return &allowed($qualifier,$rest); |
# ------------------------------------------ user.preferences, user.environment |
# ------------------------------------------ user.preferences, user.environment |
} elsif (($space eq 'preferences') || ($space eq 'environment')) { |
} elsif (($space eq 'preferences') || ($space eq 'environment')) { |
return $ENV{join('.',('environment',$qualifier,$rest))}; |
return $ENV{join('.',('environment',$qualifierrest))}; |
# ----------------------------------------------------------------- user.course |
# ----------------------------------------------------------------- user.course |
} elsif ($space eq 'course') { |
} elsif ($space eq 'course') { |
return $ENV{join('.',('request.course',$qualifier))}; |
return $ENV{join('.',('request.course',$qualifier))}; |
Line 1149 sub varval {
|
Line 1244 sub varval {
|
# ------------------------------------------------------------- request.browser |
# ------------------------------------------------------------- request.browser |
if ($space eq 'browser') { |
if ($space eq 'browser') { |
return $ENV{'browser.'.$qualifier}; |
return $ENV{'browser.'.$qualifier}; |
} elsif ($space eq 'filename') { |
# ------------------------------------------------------------ request.filename |
return $ENV{'request.filename'}; |
} else { |
|
return $ENV{'request.'.$spacequalifierrest}; |
} |
} |
} elsif ($realm eq 'course') { |
} elsif ($realm eq 'course') { |
# ---------------------------------------------------------- course.description |
# ---------------------------------------------------------- course.description |
if ($space eq 'description') { |
my $section=''; |
my %reply=&coursedescription($ENV{'request.course.id'}); |
if ($ENV{'request.course.sec'}) { |
return $reply{'description'}; |
$section='_'.$ENV{'request.course.sec'}; |
# ------------------------------------------------------------------- course.id |
} |
} elsif ($space eq 'id') { |
return $ENV{'course.'.$ENV{'request.course.id'}.$section.'.'. |
return $ENV{'request.course.id'}; |
$spacequalifierrest}; |
# -------------------------------------------------- Any other course namespace |
} elsif ($realm eq 'resource') { |
} else { |
if ($ENV{'request.course.id'}) { |
my ($cdom,$cnam)=split(/\_/,$ENV{'request.course.id'}); |
# ----------------------------------------------------- Cascading lookup scheme |
my $chome=&homeserver($cnam,$cdom); |
my $symbparm=&symbread().'.'.$spacequalifierrest; |
my $item=join('.',($qualifier,$rest)); |
my $reslevel= |
return &unescape |
$ENV{'request.course.id'}.'.'.$symbparm; |
(&reply('get:'.$cdom.':'.$cnam.':'.&escape($space).':'. |
my $seclevel= |
&escape($item),$chome)); |
$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 $filename=$perlvar{'lonDocRoot'}.'/res/'.$uri.'.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 |
# ---------------------------------------------------- Any other user namespace |
} elsif ($realm eq 'environment') { |
} elsif ($realm eq 'environment') { |
# ----------------------------------------------------------------- environment |
# ----------------------------------------------------------------- environment |
return $ENV{join('.',($space,$qualifier,$rest))}; |
return $ENV{$spacequalifierrest}; |
} elsif ($realm eq 'system') { |
} elsif ($realm eq 'system') { |
# ----------------------------------------------------------------- system.time |
# ----------------------------------------------------------------- system.time |
if ($space eq 'time') { |
if ($space eq 'time') { |
Line 1237 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 1264 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 1315 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/.. |