--- loncom/lonnet/perl/lonnet.pm 2000/10/30 22:45:21 1.55
+++ loncom/lonnet/perl/lonnet.pm 2000/11/07 17:20:10 1.59
@@ -24,6 +24,7 @@
# revokerole (udom,uname,url,role) : Revoke a role for url
# revokecustomrole (udom,uname,url,rdom,rnam,rolename) : Revoke a custom role
# appenv(hash) : adds hash to session environment
+# delenv(varname) : deletes all environment entries starting with varname
# store(hash) : stores hash permanently for this url
# cstore(hash) : critical store
# restore : returns hash for this url
@@ -41,7 +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
+# 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)
@@ -67,7 +68,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 Gerd Kortemeyer
+# 10/30,10/31,11/2 Gerd Kortemeyer
package Apache::lonnet;
@@ -250,6 +251,35 @@ sub appenv {
}
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
@@ -855,7 +885,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 '';
@@ -864,7 +896,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 '';
@@ -893,7 +927,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 '';
}
@@ -912,7 +947,8 @@ sub allowed {
}
if (join('',@content)=~
/\<roledeny[^\>]*\>[^\<]*$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 '';
}
@@ -1156,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;
@@ -1165,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))};
@@ -1201,33 +1243,42 @@ 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') {
+# ----------------------------------------------------------- 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
# ---------------------------------------------------- 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') {
@@ -1367,12 +1418,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/..