--- loncom/lonnet/perl/lonnet.pm 2001/03/22 15:08:49 1.112
+++ loncom/lonnet/perl/lonnet.pm 2001/10/16 21:16:01 1.166
@@ -28,15 +28,39 @@
# 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
-# 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
+# store(hashref,symb,courseid,udom,uname)
+# : stores hash permanently for this url
+# hashref needs to be given, and should be a \%hashname
+# the remaining args aren't required and if they aren't
+# passed or are '' they will be derived from the ENV
+# cstore(hashref,symb,courseid,udom,uname)
+# : same as store but uses the critical interface to
+# guarentee a store
+# restore(symb,courseid,udom,uname)
+# : returns hash for this symb, all args are optional
+# if they aren't given they will be derived from the
+# current enviroment
+#
+#
+# for the next 6 functions udom and uname are optional
+# if supplied they use udom as the domain and uname
+# as the username for the function (supply a courseid
+# for the uname if you want a course database)
+# if not supplied it uses %ENV and looks at
+# user. attribute for the values
+#
+# eget(namesp,arrayref,udom,uname)
+# : returns hash with keys from array reference filled
+# in from namesp (encrypts the return communication)
+# get(namesp,arrayref,udom,uname)
+# : returns hash with keys from array reference filled
+# in from namesp
+# dump(namesp,udom,uname) : dumps the complete namespace into a hash
+# del(namesp,array,udom,uname) : deletes keys out of array from namesp
+# put(namesp,hash,udom,uname) : stores hash in namesp
+# cput(namesp,hash,udom,uname) : critical put
+#
+#
# ssi(url,hash) : does a complete request cycle on url to localhost, posts
# hash
# coursedescription(id) : returns and caches course description for id
@@ -48,11 +72,16 @@
# 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
+# rndseed([symb,courseid,domain,uname])
+# : returns a random seed, all arguments are optional,
+# if they aren't sent it use the environment to derive
+# them
+# Note: if symb isn't sent and it can't get one from
+# &symbread it will use the current time as it's return
# receipt() : returns a receipt to be given out to users
# 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
+# filelocation(dir,file) : returns a fairly 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
@@ -89,10 +118,19 @@
# 05/01,06/01,09/01 Gerd Kortemeyer
# 09/01 Guy Albertelli
# 09/01,10/01,11/01 Gerd Kortemeyer
+# YEAR=2001
# 02/27/01 Scott Harrison
# 3/2 Gerd Kortemeyer
-# 3/15 Scott Harrison
+# 3/15,3/19 Scott Harrison
# 3/19,3/20 Gerd Kortemeyer
+# 3/22,3/27,4/2,4/16,4/17 Scott Harrison
+# 5/26,5/28 Gerd Kortemeyer
+# 5/30 H. K. Ng
+# 6/1 Gerd Kortemeyer
+# July Guy Albertelli
+# 8/4,8/7,8/8,8/9,8/11,8/16,8/17,8/18,8/20,8/23,9/20,9/21,9/26,
+# 10/2 Gerd Kortemeyer
+# 10/5,10/10 Scott Harrison
package Apache::lonnet;
@@ -101,7 +139,7 @@ use Apache::File;
use LWP::UserAgent();
use HTTP::Headers;
use vars
-qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache);
+qw(%perlvar %hostname %homecache %hostip %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache %packagetab %courselogs);
use IO::Socket;
use GDBM_File;
use Apache::Constants qw(:common :http);
@@ -110,6 +148,16 @@ use Fcntl qw(:flock);
# --------------------------------------------------------------------- Logging
+sub logtouch {
+ my $execdir=$perlvar{'lonDaemons'};
+ unless (-e "$execdir/logs/lonnet.log") {
+ my $fh=Apache::File->new(">>$execdir/logs/lonnet.log");
+ close $fh;
+ }
+ my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];
+ chown($wwwuid,$wwwgid,$execdir.'/logs/lonnet.log');
+}
+
sub logthis {
my $message=shift;
my $execdir=$perlvar{'lonDaemons'};
@@ -246,7 +294,8 @@ sub appenv {
map {
if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {
&logthis("WARNING: ".
- "Attempt to modify environment ".$_." to ".$newenv{$_});
+ "Attempt to modify environment ".$_." to ".$newenv{$_}
+ .'');
delete($newenv{$_});
} else {
$ENV{$_}=$newenv{$_};
@@ -629,6 +678,142 @@ sub log {
return critical("log:$dom:$nam:$what",$hom);
}
+# ------------------------------------------------------------------ Course Log
+
+sub flushcourselogs {
+ &logthis('Flushing course log buffers');
+ map {
+ my $crsid=$_;
+ if (&reply('log:'.$ENV{'course.'.$crsid.'.domain'}.':'.
+ $ENV{'course.'.$crsid.'.num'}.':'.
+ &escape($courselogs{$crsid}),
+ $ENV{'course.'.$crsid.'.home'}) eq 'ok') {
+ delete $courselogs{$crsid};
+ } else {
+ &logthis('Failed to flush log buffer for '.$crsid);
+ if (length($courselogs{$crsid})>40000) {
+ &logthis("WARNING: Buffer for ".$crsid.
+ " exceeded maximum size, deleting.");
+ delete $courselogs{$crsid};
+ }
+ }
+ } keys %courselogs;
+}
+
+sub courselog {
+ my $what=shift;
+ $what=time.':'.$what;
+ unless ($ENV{'request.course.id'}) { return ''; }
+ if (defined $courselogs{$ENV{'request.course.id'}}) {
+ $courselogs{$ENV{'request.course.id'}}.='&'.$what;
+ } else {
+ $courselogs{$ENV{'request.course.id'}}.=$what;
+ }
+ if (length($courselogs{$ENV{'request.course.id'}})>4048) {
+ &flushcourselogs();
+ }
+}
+
+sub courseacclog {
+ my $fnsymb=shift;
+ unless ($ENV{'request.course.id'}) { return ''; }
+ my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'};
+ if ($what=~/(problem|exam|quiz|assess|survey|form)$/) {
+ map {
+ if ($_=~/^form\.(.*)/) {
+ $what.=':'.$1.'='.$ENV{$_};
+ }
+ } keys %ENV;
+ }
+ &courselog($what);
+}
+
+# ----------------------------------------------------------- Check out an item
+
+sub checkout {
+ my ($symb,$tuname,$tudom,$tcrsid)=@_;
+ my $now=time;
+ my $lonhost=$perlvar{'lonHostID'};
+ my $infostr=&escape(
+ $tuname.'&'.
+ $tudom.'&'.
+ $tcrsid.'&'.
+ $symb.'&'.
+ $now.'&'.$ENV{'REMOTE_ADDR'});
+ my $token=&reply('tmpput:'.$infostr,$lonhost);
+ if ($token=~/^error\:/) {
+ &logthis("WARNING: ".
+ "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
+ "");
+ return '';
+ }
+
+ $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;
+ $token=~tr/a-z/A-Z/;
+
+ my %infohash=('resource.0.outtoken' => $token,
+ 'resource.0.checkouttime' => $now,
+ 'resource.0.outremote' => $ENV{'REMOTE_ADDR'});
+
+ unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
+ return '';
+ } else {
+ &logthis("WARNING: ".
+ "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
+ "");
+ }
+
+ if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
+ &escape('Checkout '.$infostr.' - '.
+ $token)) ne 'ok') {
+ return '';
+ } else {
+ &logthis("WARNING: ".
+ "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
+ "");
+ }
+ return $token;
+}
+
+# ------------------------------------------------------------ Check in an item
+
+sub checkin {
+ my $token=shift;
+ my $now=time;
+ my ($ta,$tb,$lonhost)=split(/\*/,$token);
+ $lonhost=~tr/A-Z/a-z/;
+ my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb;
+ $dtoken=~s/\W/\_/g;
+ my ($tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
+ split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
+
+ unless (($tuname) && ($tudom)) {
+ &logthis('Check in '.$token.' ('.$dtoken.') failed');
+ return '';
+ }
+
+ unless (&allowed('mgr',$tcrsid)) {
+ &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.
+ $ENV{'user.name'}.' - '.$ENV{'user.domain'});
+ return '';
+ }
+
+ my %infohash=('resource.0.intoken' => $token,
+ 'resource.0.checkintime' => $now,
+ 'resource.0.inremote' => $ENV{'REMOTE_ADDR'});
+
+ unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
+ return '';
+ }
+
+ if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
+ &escape('Checkin - '.$token)) ne 'ok') {
+ return '';
+ }
+
+ return ($symb,$tuname,$tudom,$tcrsid);
+}
+
# --------------------------------------------- Set Expire Date for Spreadsheet
sub expirespread {
@@ -654,79 +839,97 @@ sub devalidate {
if ($cid) {
my $key=$ENV{'user.name'}.':'.$ENV{'user.domain'}.':';
my $status=
- &reply('del:'.$ENV{'course.'.$cid.'.domain'}.':'.
- $ENV{'course.'.$cid.'.num'}.
- ':nohist_calculatedsheets:'.
- &escape($key.'studentcalc:'),
- $ENV{'course.'.$cid.'.home'})
- .' '.
- &reply('del:'.$ENV{'user.domain'}.':'.
- $ENV{'user.name'}.
- ':nohist_calculatedsheets_'.$cid.':'.
- &escape($key.'assesscalc:'.$symb),
- $ENV{'user.home'});
+ &del('nohist_calculatedsheet',
+ [$key.'studentcalc'],
+ $ENV{'course.'.$cid.'.domain'},
+ $ENV{'course.'.$cid.'.num'})
+ .' '.
+ &del('nohist_calculatedsheets_'.$cid,
+ [$key.'assesscalc:'.$symb]);
unless ($status eq 'ok ok') {
&logthis('Could not devalidate spreadsheet '.
$ENV{'user.name'}.' at '.$ENV{'user.domain'}.' for '.
$symb.': '.$status);
- }
+ }
}
}
# ----------------------------------------------------------------------- Store
sub store {
- my %storehash=@_;
- my $symb;
- unless ($symb=&symbread()) { return ''; }
+ my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
+ my $home='';
+
+ if ($stuname) {
+ $home=&homeserver($stuname,$domain);
+ }
+
+ if (!$symb) { unless ($symb=&symbread()) { return ''; } }
&devalidate($symb);
$symb=escape($symb);
- my $namespace;
- unless ($namespace=$ENV{'request.course.id'}) { return ''; }
+ if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { return ''; } }
+ if (!$domain) { $domain=$ENV{'user.domain'}; }
+ if (!$stuname) { $stuname=$ENV{'user.name'}; }
+ if (!$home) { $home=$ENV{'user.home'}; }
my $namevalue='';
map {
- $namevalue.=escape($_).'='.escape($storehash{$_}).'&';
- } keys %storehash;
+ $namevalue.=escape($_).'='.escape($$storehash{$_}).'&';
+ } keys %$storehash;
$namevalue=~s/\&$//;
- return reply(
- "store:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb:$namevalue",
- "$ENV{'user.home'}");
+ return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
}
# -------------------------------------------------------------- Critical Store
sub cstore {
- my %storehash=@_;
- my $symb;
- unless ($symb=&symbread()) { return ''; }
+ my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
+ my $home='';
+
+ if ($stuname) {
+ $home=&homeserver($stuname,$domain);
+ }
+
+ if (!$symb) { unless ($symb=&symbread()) { return ''; } }
&devalidate($symb);
$symb=escape($symb);
- my $namespace;
- unless ($namespace=$ENV{'request.course.id'}) { return ''; }
+ if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { return ''; } }
+ if (!$domain) { $domain=$ENV{'user.domain'}; }
+ if (!$stuname) { $stuname=$ENV{'user.name'}; }
+ if (!$home) { $home=$ENV{'user.home'}; }
+
my $namevalue='';
map {
- $namevalue.=escape($_).'='.escape($storehash{$_}).'&';
- } keys %storehash;
+ $namevalue.=escape($_).'='.escape($$storehash{$_}).'&';
+ } keys %$storehash;
$namevalue=~s/\&$//;
- return critical(
- "store:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb:$namevalue",
- "$ENV{'user.home'}");
+ return critical("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
}
# --------------------------------------------------------------------- Restore
sub restore {
- my $symb;
- unless ($symb=escape(&symbread())) { return ''; }
- my $namespace;
- unless ($namespace=$ENV{'request.course.id'}) { return ''; }
- my $answer=reply(
- "restore:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb",
- "$ENV{'user.home'}");
+ my ($symb,$namespace,$domain,$stuname) = @_;
+ my $home='';
+
+ if ($stuname) {
+ $home=&homeserver($stuname,$domain);
+ }
+
+ if (!$symb) {
+ unless ($symb=escape(&symbread())) { return ''; }
+ } else {
+ $symb=&escape($symb);
+ }
+ if (!$namespace) { unless ($namespace=$ENV{'request.course.id'}) { return ''; } }
+ if (!$domain) { $domain=$ENV{'user.domain'}; }
+ if (!$stuname) { $stuname=$ENV{'user.name'}; }
+ if (!$home) { $home=$ENV{'user.home'}; }
+ my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");
+
my %returnhash=();
map {
my ($name,$value)=split(/\=/,$_);
@@ -748,22 +951,18 @@ sub coursedescription {
$courseid=~s/^\///;
$courseid=~s/\_/\//g;
my ($cdomain,$cnum)=split(/\//,$courseid);
- my $chome=homeserver($cnum,$cdomain);
+ my $chome=&homeserver($cnum,$cdomain);
if ($chome ne 'no_host') {
- my $rep=reply("dump:$cdomain:$cnum:environment",$chome);
- if ($rep ne 'con_lost') {
+ my %returnhash=&dump('environment',$cdomain,$cnum);
+ if (!exists($returnhash{'con_lost'})) {
my $normalid=$cdomain.'_'.$cnum;
my %envhash=();
- my %returnhash=('home' => $chome,
- 'domain' => $cdomain,
- 'num' => $cnum);
- map {
- my ($name,$value)=split(/\=/,$_);
- $name=&unescape($name);
- $value=&unescape($value);
- $returnhash{$name}=$value;
+ $returnhash{'home'}= $chome;
+ $returnhash{'domain'} = $cdomain;
+ $returnhash{'num'} = $cnum;
+ while (my ($name,$value) = each %returnhash) {
$envhash{'course.'.$normalid.'.'.$name}=$value;
- } split(/\&/,$rep);
+ }
$returnhash{'url'}='/res/'.declutter($returnhash{'url'});
$returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
$ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;
@@ -848,8 +1047,12 @@ sub rolesinit {
}
}
} split(/&/,$rolesdump);
+ my $adv=0;
+ my $author=0;
map {
%thesepriv=();
+ if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; }
+ if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }
map {
if ($_ ne '') {
my ($privilege,$restrictions)=split(/&/,$_);
@@ -866,6 +1069,9 @@ sub rolesinit {
map { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } keys %thesepriv;
$userroles.='user.priv.'.$_.'='.$thesestr."\n";
} keys %allroles;
+ $userroles.='user.adv='.$adv."\n".
+ 'user.author='.$author."\n";
+ $ENV{'user.adv'}=$adv;
}
return $userroles;
}
@@ -873,43 +1079,51 @@ sub rolesinit {
# --------------------------------------------------------------- get interface
sub get {
- my ($namespace,@storearr)=@_;
+ my ($namespace,$storearr,$udomain,$uname)=@_;
my $items='';
map {
$items.=escape($_).'&';
- } @storearr;
+ } @$storearr;
$items=~s/\&$//;
- my $rep=reply("get:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
- $ENV{'user.home'});
+ if (!$udomain) { $udomain=$ENV{'user.domain'}; }
+ if (!$uname) { $uname=$ENV{'user.name'}; }
+ my $uhome=&homeserver($uname,$udomain);
+
+ my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome);
my @pairs=split(/\&/,$rep);
my %returnhash=();
my $i=0;
map {
$returnhash{$_}=unescape($pairs[$i]);
$i++;
- } @storearr;
+ } @$storearr;
return %returnhash;
}
# --------------------------------------------------------------- del interface
sub del {
- my ($namespace,@storearr)=@_;
+ my ($namespace,$storearr,$udomain,$uname)=@_;
my $items='';
map {
$items.=escape($_).'&';
- } @storearr;
+ } @$storearr;
$items=~s/\&$//;
- return reply("del:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
- $ENV{'user.home'});
+ if (!$udomain) { $udomain=$ENV{'user.domain'}; }
+ if (!$uname) { $uname=$ENV{'user.name'}; }
+ my $uhome=&homeserver($uname,$udomain);
+
+ return &reply("del:$udomain:$uname:$namespace:$items",$uhome);
}
# -------------------------------------------------------------- dump interface
sub dump {
- my $namespace=shift;
- my $rep=reply("dump:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace",
- $ENV{'user.home'});
+ my ($namespace,$udomain,$uname)=@_;
+ if (!$udomain) { $udomain=$ENV{'user.domain'}; }
+ if (!$uname) { $uname=$ENV{'user.name'}; }
+ my $uhome=&homeserver($uname,$udomain);
+ my $rep=reply("dump:$udomain:$uname:$namespace",$uhome);
my @pairs=split(/\&/,$rep);
my %returnhash=();
map {
@@ -922,48 +1136,53 @@ sub dump {
# --------------------------------------------------------------- put interface
sub put {
- my ($namespace,%storehash)=@_;
+ my ($namespace,$storehash,$udomain,$uname)=@_;
+ if (!$udomain) { $udomain=$ENV{'user.domain'}; }
+ if (!$uname) { $uname=$ENV{'user.name'}; }
+ my $uhome=&homeserver($uname,$udomain);
my $items='';
map {
- $items.=escape($_).'='.escape($storehash{$_}).'&';
- } keys %storehash;
+ $items.=&escape($_).'='.&escape($$storehash{$_}).'&';
+ } keys %$storehash;
$items=~s/\&$//;
- return reply("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
- $ENV{'user.home'});
+ return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
}
# ------------------------------------------------------ critical put interface
sub cput {
- my ($namespace,%storehash)=@_;
+ my ($namespace,$storehash,$udomain,$uname)=@_;
+ if (!$udomain) { $udomain=$ENV{'user.domain'}; }
+ if (!$uname) { $uname=$ENV{'user.name'}; }
+ my $uhome=&homeserver($uname,$udomain);
my $items='';
map {
- $items.=escape($_).'='.escape($storehash{$_}).'&';
- } keys %storehash;
+ $items.=escape($_).'='.escape($$storehash{$_}).'&';
+ } keys %$storehash;
$items=~s/\&$//;
- return critical
- ("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
- $ENV{'user.home'});
+ return &critical("put:$udomain:$uname:$namespace:$items",$uhome);
}
# -------------------------------------------------------------- eget interface
sub eget {
- my ($namespace,@storearr)=@_;
+ my ($namespace,$storearr,$udomain,$uname)=@_;
my $items='';
map {
$items.=escape($_).'&';
- } @storearr;
+ } @$storearr;
$items=~s/\&$//;
- my $rep=reply("eget:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
- $ENV{'user.home'});
+ if (!$udomain) { $udomain=$ENV{'user.domain'}; }
+ if (!$uname) { $uname=$ENV{'user.name'}; }
+ my $uhome=&homeserver($uname,$udomain);
+ my $rep=&reply("eget:$udomain:$uname:$namespace:$items",$uhome);
my @pairs=split(/\&/,$rep);
my %returnhash=();
my $i=0;
map {
$returnhash{$_}=unescape($pairs[$i]);
$i++;
- } @storearr;
+ } @$storearr;
return %returnhash;
}
@@ -971,6 +1190,8 @@ sub eget {
sub allowed {
my ($priv,$uri)=@_;
+
+ my $orguri=$uri;
$uri=&declutter($uri);
# Free bre access to adm and meta resources
@@ -979,6 +1200,12 @@ sub allowed {
return 'F';
}
+# Free bre to public access
+
+ if ($priv eq 'bre') {
+ if (&metadata($uri,'copyright') eq 'public') { return 'F'; }
+ }
+
my $thisallowed='';
my $statecond=0;
my $courseprivid='';
@@ -1014,7 +1241,7 @@ sub allowed {
# If this is generating or modifying users, exit with special codes
- if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:'=~/\:$priv\:/) {
+ if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:$priv\:/) {
return $thisallowed;
}
#
@@ -1044,16 +1271,28 @@ sub allowed {
}
}
- if (($ENV{'HTTP_REFERER'}) && ($checkreferer)) {
- my $refuri=$ENV{'HTTP_REFERER'};
- $refuri=~s/^http\:\/\/$ENV{'request.host'}//i;
- $refuri=&declutter($refuri);
+ if ($checkreferer) {
+ my $refuri=$ENV{'httpref.'.$orguri};
+
+ unless ($refuri) {
+ map {
+ if ($_=~/^httpref\..*\*/) {
+ my $pattern=$_;
+ $pattern=~s/^httpref\.\/res\///;
+ $pattern=~s/\*/\[\^\/\]\+/g;
+ $pattern=~s/\//\\\//g;
+ if ($orguri=~/$pattern/) {
+ $refuri=$ENV{$_};
+ }
+ }
+ } keys %ENV;
+ }
+ if ($refuri) {
+ $refuri=&declutter($refuri);
my @uriparts=split(/\//,$refuri);
my $filename=$uriparts[$#uriparts];
my $pathname=$refuri;
$pathname=~s/\/$filename$//;
- my @filenameparts=split(/\./,$uri);
- if (&fileembstyle($filenameparts[$#filenameparts]) ne 'ssi') {
if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
/\&$filename\:([\d\|]+)\&/) {
my $refstatecond=$1;
@@ -1063,8 +1302,8 @@ sub allowed {
$uri=$refuri;
$statecond=$refstatecond;
}
- }
}
+ }
}
}
@@ -1242,22 +1481,22 @@ sub definerole {
# ---------------- Make a metadata query against the network of library servers
sub metadata_query {
-<<<<<<< lonnet.pm
- my ($query,$custom)=@_;
- unless ($custom) {
- my $reply=&reply("querysend:".&escape($query),'msul3');
- return $reply;
- }
- else {
- my $reply=&reply("querysend:".&escape($query).':'.
- &escape($customquery),'msul3');
- return $reply;
- }
-=======
- my ($query)=@_;
- # need to put in a loop here and return list
- my $reply=&reply("querysend:".&escape($query),'msul3');
->>>>>>> 1.111
+ my ($query,$custom,$customshow)=@_;
+ # need to put in a library server loop here and return a hash
+ my %rhash;
+ for my $server (keys %libserv) {
+ unless ($custom or $customshow) {
+ my $reply=&reply("querysend:".&escape($query),$server);
+ $rhash{$server}=$reply;
+ }
+ else {
+ my $reply=&reply("querysend:".&escape($query).':'.
+ &escape($custom).':'.&escape($customshow),
+ $server);
+ $rhash{$server}=$reply;
+ }
+ }
+ return \%rhash;
}
# ------------------------------------------------------------------ Plain Text
@@ -1372,27 +1611,20 @@ sub modifyuser {
}
}
# -------------------------------------------------------------- Add names, etc
- my $names=&reply('get:'.$udom.':'.$uname.
- ':environment:firstname&middlename&lastname&generation',
- $uhome);
- my ($efirst,$emiddle,$elast,$egene)=split(/\&/,$names);
- if ($first) { $efirst = &escape($first); }
- if ($middle) { $emiddle = &escape($middle); }
- if ($last) { $elast = &escape($last); }
- if ($gene) { $egene = &escape($gene); }
- my $reply=&reply('put:'.$udom.':'.$uname.
- ':environment:firstname='.$efirst.
- '&middlename='.$emiddle.
- '&lastname='.$elast.
- '&generation='.$egene,$uhome);
- if ($reply ne 'ok') {
- return 'error: '.$reply;
- }
+ my %names=&get('environment',
+ ['firstname','middlename','lastname','generation'],
+ $udom,$uname);
+ if ($first) { $names{'firstname'} = $first; }
+ if ($middle) { $names{'middlename'} = $middle; }
+ if ($last) { $names{'lastname'} = $last; }
+ if ($gene) { $names{'generation'} = $gene; }
+ my $reply = &put('environment', \%names, $udom,$uname);
+ if ($reply ne 'ok') { return 'error: '.$reply; }
&logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
$umode.', '.$first.', '.$middle.', '.
$last.', '.$gene.' by '.
$ENV{'user.name'}.' at '.$ENV{'user.domain'});
- return 'ok';
+ return 'ok';
}
# -------------------------------------------------------------- Modify student
@@ -1413,7 +1645,7 @@ sub modifystudent {
return 'error: no such user';
}
# -------------------------------------------------- Add student to course list
- my $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'.
+ $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'.
$ENV{'course.'.$cid.'.num'}.':classlist:'.
&escape($uname.':'.$udom).'='.
&escape($end.':'.$start),
@@ -1478,7 +1710,7 @@ sub createcourse {
my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
$ENV{'user.home'});
unless ($reply eq 'ok') { return 'error: '.$reply; }
- my $uhome=&homeserver($uname,$udom);
+ $uhome=&homeserver($uname,$udom);
if (($uhome eq '') || ($uhome eq 'no_host')) {
return 'error: no such course';
}
@@ -1617,7 +1849,7 @@ sub condval {
# --------------------------------------------------------- Value of a Variable
sub EXT {
- my $varname=shift;
+ my ($varname,$symbparm)=@_;
unless ($varname) { return ''; }
my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
my $rest;
@@ -1633,7 +1865,7 @@ sub EXT {
if ($realm eq 'user') {
# --------------------------------------------------------------- user.resource
if ($space eq 'resource') {
- my %restored=&restore;
+ my %restored=&restore();
return $restored{$qualifierrest};
# ----------------------------------------------------------------- user.access
} elsif ($space eq 'access') {
@@ -1661,7 +1893,7 @@ sub EXT {
# ---------------------------------------------------- Any other user namespace
} else {
my $item=($rest)?$qualifier.'.'.$rest:$qualifier;
- my %reply=&get($space,$item);
+ my %reply=&get($space,[$item]);
return $reply{$item};
}
} elsif ($realm eq 'request') {
@@ -1674,49 +1906,54 @@ sub EXT {
}
} elsif ($realm eq 'course') {
# ---------------------------------------------------------- course.description
- my $section='';
- if ($ENV{'request.course.sec'}) {
- $section='_'.$ENV{'request.course.sec'};
- }
- return $ENV{'course.'.$ENV{'request.course.id'}.$section.'.'.
+ return $ENV{'course.'.$ENV{'request.course.id'}.'.'.
$spacequalifierrest};
} elsif ($realm eq 'resource') {
- if ($ENV{'request.course.id'}) {
+ if ($ENV{'request.course.id'}) {
+
+# print '
'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
+
+
# ----------------------------------------------------- Cascading lookup scheme
- my $symbp=&symbread();
- my $mapp=(split(/\_\_\_/,$symbp))[0];
+ my $symbp;
+ if ($symbparm) {
+ $symbp=$symbparm;
+ } else {
+ $symbp=&symbread();
+ }
+ my $mapp=(split(/\_\_\_/,$symbp))[0];
- my $symbparm=$symbp.'.'.$spacequalifierrest;
- my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
+ my $symbparm=$symbp.'.'.$spacequalifierrest;
+ my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
- my $seclevel=
+ my $seclevel=
$ENV{'request.course.id'}.'.['.
$ENV{'request.course.sec'}.'].'.$spacequalifierrest;
- my $seclevelr=
+ my $seclevelr=
$ENV{'request.course.id'}.'.['.
$ENV{'request.course.sec'}.'].'.$symbparm;
- my $seclevelm=
+ my $seclevelm=
$ENV{'request.course.id'}.'.['.
$ENV{'request.course.sec'}.'].'.$mapparm;
- my $courselevel=
+ my $courselevel=
$ENV{'request.course.id'}.'.'.$spacequalifierrest;
- my $courselevelr=
+ my $courselevelr=
$ENV{'request.course.id'}.'.'.$symbparm;
- my $courselevelm=
+ my $courselevelm=
$ENV{'request.course.id'}.'.'.$mapparm;
# ----------------------------------------------------------- first, check user
- my %resourcedata=get('resourcedata',
- ($courselevelr,$courselevelm,$courselevel));
- if (($resourcedata{$courselevelr}!~/^error\:/) &&
- ($resourcedata{$courselevelr}!~/^con_lost/)) {
-
- if ($resourcedata{$courselevelr}) {
- return $resourcedata{$courselevelr}; }
- if ($resourcedata{$courselevelm}) {
- return $resourcedata{$courselevelm}; }
- if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }
+ my %resourcedata=get('resourcedata',
+ [$courselevelr,$courselevelm,$courselevel]);
+ if (($resourcedata{$courselevelr}!~/^error\:/) &&
+ ($resourcedata{$courselevelr}!~/^con_lost/)) {
+
+ if ($resourcedata{$courselevelr}) {
+ return $resourcedata{$courselevelr}; }
+ if ($resourcedata{$courselevelm}) {
+ return $resourcedata{$courselevelm}; }
+ if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }
} else {
if ($resourcedata{$courselevelr}!~/No such file/) {
@@ -1771,10 +2008,25 @@ sub EXT {
'parameter_'.$spacequalifierrest);
if ($metadata) { return $metadata; }
+# ------------------------------------------------------------------ Cascade up
+
+ unless ($space eq '0') {
+ my ($part,$id)=split(/\_/,$space);
+ if ($id) {
+ my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
+ $symbparm);
+ if ($partgeneral) { return $partgeneral; }
+ } else {
+ my $resourcegeneral=&EXT('resource.0.'.$qualifierrest,
+ $symbparm);
+ if ($resourcegeneral) { return $resourcegeneral; }
+ }
+ }
+
# ---------------------------------------------------- Any other user namespace
} elsif ($realm eq 'environment') {
# ----------------------------------------------------------------- environment
- return $ENV{$spacequalifierrest};
+ return $ENV{'environment.'.$spacequalifierrest};
} elsif ($realm eq 'system') {
# ----------------------------------------------------------------- system.time
if ($space eq 'time') {
@@ -1793,25 +2045,59 @@ sub metadata {
my $filename=$uri;
$uri=~s/\.meta$//;
unless ($metacache{$uri.':keys'}) {
+ my %metathesekeys=();
unless ($filename=~/\.meta$/) { $filename.='.meta'; }
my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
my $parser=HTML::TokeParser->new(\$metastring);
my $token;
+ undef %metathesekeys;
while ($token=$parser->get_token) {
if ($token->[0] eq 'S') {
+ if (defined($token->[2]->{'package'})) {
+ my $package=$token->[2]->{'package'};
+ my $keyroot='';
+ if (defined($token->[2]->{'part'})) {
+ $keyroot.='_'.$token->[2]->{'part'};
+ }
+ if (defined($token->[2]->{'id'})) {
+ $keyroot.='_'.$token->[2]->{'id'};
+ }
+ if ($metacache{$uri.':packages'}) {
+ $metacache{$uri.':packages'}.=','.$package.$keyroot;
+ } else {
+ $metacache{$uri.':packages'}=$package.$keyroot;
+ }
+ map {
+ if ($_=~/^$package\&/) {
+ my ($pack,$name,$subp)=split(/\&/,$_);
+ my $value=$packagetab{$_};
+ my $part=$keyroot;
+ $part=~s/^\_//;
+ if ($subp eq 'display') {
+ $value.=' [Part: '.$part.']';
+ }
+ my $unikey='parameter'.$keyroot.'_'.$name;
+ $metathesekeys{$unikey}=1;
+ $metacache{$uri.':'.$unikey.'.part'}=$part;
+ unless
+ (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {
+ $metacache{$uri.':'.$unikey.'.'.$subp}=$value;
+ }
+ }
+ } keys %packagetab;
+ } else {
my $entry=$token->[1];
my $unikey=$entry;
if (defined($token->[2]->{'part'})) {
$unikey.='_'.$token->[2]->{'part'};
}
+ if (defined($token->[2]->{'id'})) {
+ $unikey.='_'.$token->[2]->{'id'};
+ }
if (defined($token->[2]->{'name'})) {
$unikey.='_'.$token->[2]->{'name'};
}
- if ($metacache{$uri.':keys'}) {
- $metacache{$uri.':keys'}.=','.$unikey;
- } else {
- $metacache{$uri.':keys'}=$unikey;
- }
+ $metathesekeys{$unikey}=1;
map {
$metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};
} @{$token->[3]};
@@ -1820,8 +2106,10 @@ sub metadata {
) { $metacache{$uri.':'.$unikey}=
$metacache{$uri.':'.$unikey.'.default'};
}
- }
+ }
+ }
}
+ $metacache{$uri.':keys'}=join(',',keys %metathesekeys);
}
return $metacache{$uri.':'.$what};
}
@@ -1931,16 +2219,21 @@ sub numval {
}
sub rndseed {
- my $symb;
- unless ($symb=&symbread()) { return time; }
- {
+ my ($symb,$courseid,$domain,$username)=@_;
+ if (!$symb) {
+ unless ($symb=&symbread()) { return time; }
+ }
+ if (!$courseid) { $courseid=$ENV{'request.course.id'};}
+ if (!$domain) {$domain=$ENV{'user.domain'};}
+ if (!$username) {$username=$ENV{'user.name'};}
+ {
use integer;
my $symbchck=unpack("%32C*",$symb) << 27;
my $symbseed=numval($symb) << 22;
- my $namechck=unpack("%32C*",$ENV{'user.name'}) << 17;
- my $nameseed=numval($ENV{'user.name'}) << 12;
- my $domainseed=unpack("%32C*",$ENV{'user.domain'}) << 7;
- my $courseseed=unpack("%32C*",$ENV{'request.course.id'});
+ my $namechck=unpack("%32C*",$username) << 17;
+ my $nameseed=numval($username) << 12;
+ my $domainseed=unpack("%32C*",$domain) << 7;
+ my $courseseed=unpack("%32C*",$courseid);
my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
#uncommenting these lines can break things!
#&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
@@ -2043,7 +2336,7 @@ sub unescape {
# ================================================================ Main Program
sub BEGIN {
-if ($readit ne 'done') {
+unless ($readit) {
# ------------------------------------------------------------ Read access.conf
{
my $config=Apache::File->new("/etc/httpd/conf/access.conf");
@@ -2062,9 +2355,11 @@ if ($readit ne 'done') {
my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");
while (my $configline=<$config>) {
+ chomp($configline);
my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
$hostname{$id}=$name;
$hostdom{$id}=$domain;
+ $hostip{$id}=$ip;
if ($role eq 'library') { $libserv{$id}=$name; }
}
}
@@ -2086,8 +2381,10 @@ if ($readit ne 'done') {
while (my $configline=<$config>) {
chomp($configline);
+ if ($configline) {
my ($role,$perm)=split(/ /,$configline);
if ($perm ne '') { $pr{$role}=$perm; }
+ }
}
}
@@ -2097,8 +2394,25 @@ if ($readit ne 'done') {
while (my $configline=<$config>) {
chomp($configline);
+ if ($configline) {
my ($short,$plain)=split(/:/,$configline);
if ($plain ne '') { $prp{$short}=$plain; }
+ }
+ }
+}
+
+# ---------------------------------------------------------- Read package table
+{
+ my $config=Apache::File->new("$perlvar{'lonTabDir'}/packages.tab");
+
+ while (my $configline=<$config>) {
+ chomp($configline);
+ my ($short,$plain)=split(/:/,$configline);
+ my ($pack,$name)=split(/\&/,$short);
+ if ($plain ne '') {
+ $packagetab{$pack.'&'.$name.'&name'}=$name;
+ $packagetab{$short}=$plain;
+ }
}
}
@@ -2119,6 +2433,7 @@ if ($readit ne 'done') {
%metacache=();
$readit='done';
+&logtouch();
&logthis('INFO: Read configuration');
}
}