--- loncom/lonnet/perl/lonnet.pm 2000/10/11 18:15:16 1.43
+++ loncom/lonnet/perl/lonnet.pm 2000/10/25 10:55:46 1.48
@@ -25,11 +25,13 @@
# revokecustomrole (udom,uname,url,rdom,rnam,rolename) : Revoke a custom role
# appenv(hash) : adds hash to session environment
# store(hash) : stores hash permanently for this url
+# cstore(hash) : critical store
# restore : returns hash for this url
# eget(namesp,array) : returns hash with keys from array filled in from namesp
# get(namesp,array) : returns hash with keys from array filled in from namesp
# del(namesp,array) : deletes keys out of array from namesp
# put(namesp,hash) : stores hash in namesp
+# cput(namesp,hash) : critical put
# dump(namesp) : dumps the complete namespace into a hash
# ssi(url,hash) : does a complete request cycle on url to localhost, posts
# hash
@@ -42,12 +44,14 @@
# varval(name) : value of a variable
# refreshstate() : refresh the state information string
# symblist(map,hash) : Updates symbolic storage links
-# symbread(filename) : returns the data handle
+# symbread([filename]) : returns the data handle (filename optional)
# rndseed() : returns a random seed
# getfile(filename) : returns the contents of filename, or a -1 if it can't
# be found, replicates and subscribes to the file
# filelocation(dir,file) : returns a farily clean absolute reference to file
# from the directory dir
+# hreflocation(dir,file) : same as filelocation, but for hrefs
+# log(domain,user,home,msg) : write to permanent log for user
#
# 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30,
# 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19,
@@ -62,7 +66,7 @@
# 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 Guy Albertelli
-# 10/06,10/09,10/10,10/11 Gerd Kortemeyer
+# 10/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25 Gerd Kortemeyer
package Apache::lonnet;
@@ -423,7 +427,7 @@ sub ssi {
sub log {
my ($dom,$nam,$hom,$what)=@_;
- return reply("log:$dom:$nam:$what",$hom);
+ return critical("log:$dom:$nam:$what",$hom);
}
# ----------------------------------------------------------------------- Store
@@ -431,7 +435,7 @@ sub log {
sub store {
my %storehash=@_;
my $symb;
- unless ($symb=escape(&symbread($ENV{'request.filename'}))) { return ''; }
+ unless ($symb=escape(&symbread())) { return ''; }
my $namespace;
unless ($namespace=$ENV{'request.course.id'}) { return ''; }
my $namevalue='';
@@ -444,11 +448,29 @@ sub store {
"$ENV{'user.home'}");
}
+# -------------------------------------------------------------- Critical Store
+
+sub cstore {
+ my %storehash=@_;
+ my $symb;
+ unless ($symb=escape(&symbread())) { return ''; }
+ my $namespace;
+ unless ($namespace=$ENV{'request.course.id'}) { return ''; }
+ my $namevalue='';
+ map {
+ $namevalue.=escape($_).'='.escape($storehash{$_}).'&';
+ } keys %storehash;
+ $namevalue=~s/\&$//;
+ return critical(
+ "store:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb:$namevalue",
+ "$ENV{'user.home'}");
+}
+
# --------------------------------------------------------------------- Restore
sub restore {
my $symb;
- unless ($symb=escape(&symbread($ENV{'request.filename'}))) { return ''; }
+ unless ($symb=escape(&symbread())) { return ''; }
my $namespace;
unless ($namespace=$ENV{'request.course.id'}) { return ''; }
my $answer=reply(
@@ -645,6 +667,20 @@ sub put {
$ENV{'user.home'});
}
+# ------------------------------------------------------ critical put interface
+
+sub cput {
+ my ($namespace,%storehash)=@_;
+ my $items='';
+ map {
+ $items.=escape($_).'='.escape($storehash{$_}).'&';
+ } keys %storehash;
+ $items=~s/\&$//;
+ return critical
+ ("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
+ $ENV{'user.home'});
+}
+
# -------------------------------------------------------------- eget interface
sub eget {
@@ -990,20 +1026,83 @@ sub condval {
# --------------------------------------------------------- Value of a Variable
sub varval {
- my ($realm,$space,@components)=split(/\./,shift);
- my $value='';
+ my $varname=shift;
+ my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
+ my $rest;
+ if ($therest[0]) {
+ $rest=join('.',@therest);
+ } else {
+ $rest='';
+ }
if ($realm eq 'user') {
- if ($space=~/^resource/) {
- $space=~s/^resource\[//;
- $space=~s/\]$//;
-
+# --------------------------------------------------------------- user.resource
+ if ($space eq 'resource') {
+# ----------------------------------------------------------------- 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))};
+# ----------------------------------------------------------------- user.course
+ } elsif ($space eq 'course') {
+ return $ENV{join('.',('request.course',$qualifier))};
+# ------------------------------------------------------------------- user.role
+ } elsif ($space eq 'role') {
+ my ($role,$where)=split(/\./,$ENV{'request.role'});
+ if ($qualifier eq 'value') {
+ return $role;
+ } elsif ($qualifier eq 'extent') {
+ return $where;
+ }
+# ----------------------------------------------------------------- user.domain
+ } elsif ($space eq 'domain') {
+ return $ENV{'user.domain'};
+# ------------------------------------------------------------------- user.name
+ } elsif ($space eq 'name') {
+ return $ENV{'user.name'};
+# ---------------------------------------------------- Any other user namespace
} else {
+ my $item=($rest)?$qualifier.'.'.$rest:$qualifier;
+ my %reply=&get($space,$item);
+ return $reply{$item};
+ }
+ } elsif ($realm eq 'request') {
+# ------------------------------------------------------------- request.browser
+ if ($space eq 'browser') {
+ return $ENV{'browser.'.$qualifier};
+ } elsif ($space eq 'filename') {
+ return $ENV{'request.filename'};
}
} elsif ($realm eq 'course') {
- } elsif ($realm eq 'session') {
+# ---------------------------------------------------------- course.description
+ if ($space eq 'description') {
+ return &coursedescription($ENV{'request.course.id'});
+# ------------------------------------------------------------------- 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));
+ }
+ } 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))};
} elsif ($realm eq 'system') {
+# ----------------------------------------------------------------- system.time
+ if ($space eq 'time') {
+ return time;
+ }
}
- return $value;
+ return '';
}
# ------------------------------------------------- Update symbolic store links
@@ -1029,11 +1128,15 @@ sub symblist {
# ------------------------------------------------------ Return symb list entry
sub symbread {
- my $thisfn=declutter(shift);
+ my $thisfn=shift;
+ unless ($thisfn) {
+ $thisfn=$ENV{'request.filename'};
+ }
+ $thisfn=declutter($thisfn);
my %hash;
my %bighash;
my $syval='';
- if (($ENV{'request.course.fn'}) && ($ENV{'request.filename'})) {
+ if (($ENV{'request.course.fn'}) && ($thisfn)) {
if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
&GDBM_READER,0640)) {
$syval=$hash{$thisfn};
@@ -1043,6 +1146,7 @@ sub symbread {
if ($syval) {
unless ($syval=~/\_\d+$/) {
unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {
+ &appenv('request.ambiguous' => $thisfn);
return '';
}
$syval.=$1;
@@ -1082,6 +1186,7 @@ sub symbread {
}
if ($syval) { return $syval.'___'.$thisfn; }
}
+ &appenv('request.ambiguous' => $thisfn);
return '';
}
@@ -1101,7 +1206,7 @@ sub numval {
sub rndseed {
my $symb;
- unless ($symb=&symbread($ENV{'request.filename'})) { return time; }
+ unless ($symb=&symbread()) { return time; }
my $symbchck=unpack("%32C*",$symb);
my $symbseed=numval($symb)%$symbchck;
my $namechck=unpack("%32C*",$ENV{'user.name'});
@@ -1138,11 +1243,21 @@ sub filelocation {
$location = '/home/httpd/html/res'.$file;
}
$location=~s://+:/:g; # remove duplicate /
- while ($location=~m:/../:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
-
+ while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
return $location;
}
+sub hreflocation {
+ my ($dir,$file)=@_;
+ unless (($_=~/^http:\/\//i) || ($_=~/^\//)) {
+ my $finalpath=filelocation($dir,$file);
+ $finalpath=~s/^\/home\/httpd\/html//;
+ return $finalpath;
+ } else {
+ return $file;
+ }
+}
+
# ------------------------------------------------------------- Declutters URLs
sub declutter {