--- loncom/lonnet/perl/lonnet.pm 2001/08/12 01:18:37 1.148
+++ loncom/lonnet/perl/lonnet.pm 2001/11/22 19:02:07 1.176
@@ -1,6 +1,46 @@
# The LearningOnline Network
# TCP networking package
#
+# 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,
+# 11/8,11/16,11/18,11/22,11/23,12/22,
+# 01/06,01/13,02/24,02/28,02/29,
+# 03/01,03/02,03/06,03/07,03/13,
+# 04/05,05/29,05/31,06/01,
+# 06/05,06/26 Gerd Kortemeyer
+# 06/26 Ben Tyszka
+# 06/30,07/15,07/17,07/18,07/20,07/21,07/22,07/25 Gerd Kortemeyer
+# 08/14 Ben Tyszka
+# 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,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29,
+# 10/30,10/31,
+# 11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25,11/27,
+# 12/02,12/12,12/13,12/14,12/28,12/29 Gerd Kortemeyer
+# 05/01/01 Guy Albertelli
+# 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,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,11/13,11/15 Scott Harrison
+# 11/17,11/20,11/22 Gerd Kortemeyer
+#
+# $Id: lonnet.pm,v 1.176 2001/11/22 19:02:07 www Exp $
+#
+###
+
# Functions for use by content handlers:
#
# metadata_query(sql-query-string,custom-metadata-regex) :
@@ -72,7 +112,12 @@
# 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
@@ -92,37 +137,6 @@
# metadata(file,entry): returns the metadata entry for a file. entry='keys'
# returns a comma separated list of keys
#
-# 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,
-# 11/8,11/16,11/18,11/22,11/23,12/22,
-# 01/06,01/13,02/24,02/28,02/29,
-# 03/01,03/02,03/06,03/07,03/13,
-# 04/05,05/29,05/31,06/01,
-# 06/05,06/26 Gerd Kortemeyer
-# 06/26 Ben Tyszka
-# 06/30,07/15,07/17,07/18,07/20,07/21,07/22,07/25 Gerd Kortemeyer
-# 08/14 Ben Tyszka
-# 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,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29,
-# 10/30,10/31,
-# 11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25,11/27,
-# 12/02,12/12,12/13,12/14,12/28,12/29 Gerd Kortemeyer
-# 05/01/01 Guy Albertelli
-# 05/01,06/01,09/01 Gerd Kortemeyer
-# 09/01 Guy Albertelli
-# 09/01,10/01,11/01 Gerd Kortemeyer
-# 02/27/01 Scott Harrison
-# 3/2 Gerd Kortemeyer
-# 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 Gerd Kortemeyer
package Apache::lonnet;
@@ -131,7 +145,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 %packagetab);
+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);
@@ -140,6 +154,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'};
@@ -276,7 +300,8 @@ sub appenv {
map {
if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {
&logthis("<font color=blue>WARNING: ".
- "Attempt to modify environment ".$_." to ".$newenv{$_});
+ "Attempt to modify environment ".$_." to ".$newenv{$_}
+ .'</font>');
delete($newenv{$_});
} else {
$ENV{$_}=$newenv{$_};
@@ -387,6 +412,44 @@ sub spareserver {
return $spareserver;
}
+# ----------------------- Try to determine user's current authentication scheme
+
+sub queryauthenticate {
+ my ($uname,$udom)=@_;
+ if (($perlvar{'lonRole'} eq 'library') &&
+ ($udom eq $perlvar{'lonDefDomain'})) {
+ my $answer=reply("encrypt:currentauth:$udom:$uname",
+ $perlvar{'lonHostID'});
+ unless ($answer eq 'unknown_user' or $answer eq 'refused') {
+ if (length($answer)) {
+ return $answer;
+ }
+ else {
+ &logthis("User $uname at $udom lacks an authentication mechanism");
+ return 'no_host';
+ }
+ }
+ }
+
+ my $tryserver;
+ foreach $tryserver (keys %libserv) {
+ if ($hostdom{$tryserver} eq $udom) {
+ my $answer=reply("encrypt:currentauth:$udom:$uname",$tryserver);
+ unless ($answer eq 'unknown_user' or $answer eq 'refused') {
+ if (length($answer)) {
+ return $answer;
+ }
+ else {
+ &logthis("User $uname at $udom lacks an authentication mechanism");
+ return 'no_host';
+ }
+ }
+ }
+ }
+ &logthis("User $uname at $udom lacks an authentication mechanism");
+ return 'no_host';
+}
+
# --------- Try to authenticate user from domain's lib servers (first this one)
sub authenticate {
@@ -659,6 +722,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("<font color=blue>WARNING: Buffer for ".$crsid.
+ " exceeded maximum size, deleting.</font>");
+ 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("<font color=blue>WARNING: ".
+ "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
+ "</font>");
+ 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("<font color=blue>WARNING: ".
+ "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
+ "</font>");
+ }
+
+ if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
+ &escape('Checkout '.$infostr.' - '.
+ $token)) ne 'ok') {
+ return '';
+ } else {
+ &logthis("<font color=blue>WARNING: ".
+ "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
+ "</font>");
+ }
+ 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 {
@@ -699,15 +898,155 @@ sub devalidate {
}
}
+sub hash2str {
+ my (%hash)=@_;
+ my $result='';
+ map { $result.=escape($_).'='.escape($hash{$_}).'&'; } keys %hash;
+ $result=~s/\&$//;
+ return $result;
+}
+
+sub str2hash {
+ my ($string) = @_;
+ my %returnhash;
+ map {
+ my ($name,$value)=split(/\=/,$_);
+ $returnhash{&unescape($name)}=&unescape($value);
+ } split(/\&/,$string);
+ return %returnhash;
+}
+
+# -------------------------------------------------------------------Temp Store
+
+sub tmpreset {
+ my ($symb,$namespace,$domain,$stuname) = @_;
+ if (!$symb) {
+ $symb=&symbread();
+ if (!$symb) { $symb= $ENV{'REQUEST_URI'}; }
+ }
+ $symb=escape($symb);
+
+ if (!$namespace) { $namespace=$ENV{'request.state'}; }
+ $namespace=~s/\//\_/g;
+ $namespace=~s/\W//g;
+
+ #FIXME needs to do something for /pub resources
+ if (!$domain) { $domain=$ENV{'user.domain'}; }
+ if (!$stuname) { $stuname=$ENV{'user.name'}; }
+ my $path=$perlvar{'lonDaemons'}.'/tmp';
+ my %hash;
+ if (tie(%hash,'GDBM_File',
+ $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
+ &GDBM_WRCREAT,0640)) {
+ foreach my $key (keys %hash) {
+ if ($key=~ /:$symb:/) {
+ delete($hash{$key});
+ }
+ }
+ }
+}
+
+sub tmpstore {
+ my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
+
+ if (!$symb) {
+ $symb=&symbread();
+ if (!$symb) { $symb= $ENV{'request.url'}; }
+ }
+ $symb=escape($symb);
+
+ if (!$namespace) {
+ # I don't think we would ever want to store this for a course.
+ # it seems this will only be used if we don't have a course.
+ #$namespace=$ENV{'request.course.id'};
+ #if (!$namespace) {
+ $namespace=$ENV{'request.state'};
+ #}
+ }
+ $namespace=~s/\//\_/g;
+ $namespace=~s/\W//g;
+#FIXME needs to do something for /pub resources
+ if (!$domain) { $domain=$ENV{'user.domain'}; }
+ if (!$stuname) { $stuname=$ENV{'user.name'}; }
+ my $now=time;
+ my %hash;
+ my $path=$perlvar{'lonDaemons'}.'/tmp';
+ if (tie(%hash,'GDBM_File',
+ $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
+ &GDBM_WRCREAT,0640)) {
+ $hash{"version:$symb"}++;
+ my $version=$hash{"version:$symb"};
+ my $allkeys='';
+ foreach my $key (keys(%$storehash)) {
+ $allkeys.=$key.':';
+ $hash{"$version:$symb:$key"}=$$storehash{$key};
+ }
+ $hash{"$version:$symb:timestamp"}=$now;
+ $allkeys.='timestamp';
+ $hash{"$version:keys:$symb"}=$allkeys;
+ if (untie(%hash)) {
+ return 'ok';
+ } else {
+ return "error:$!";
+ }
+ } else {
+ return "error:$!";
+ }
+}
+
+# -----------------------------------------------------------------Temp Restore
+
+sub tmprestore {
+ my ($symb,$namespace,$domain,$stuname) = @_;
+
+ if (!$symb) {
+ $symb=&symbread();
+ if (!$symb) { $symb= $ENV{'request.url'}; }
+ }
+ $symb=escape($symb);
+
+ if (!$namespace) { $namespace=$ENV{'request.state'}; }
+ #FIXME needs to do something for /pub resources
+ if (!$domain) { $domain=$ENV{'user.domain'}; }
+ if (!$stuname) { $stuname=$ENV{'user.name'}; }
+
+ my %returnhash;
+ $namespace=~s/\//\_/g;
+ $namespace=~s/\W//g;
+ my %hash;
+ my $path=$perlvar{'lonDaemons'}.'/tmp';
+ if (tie(%hash,'GDBM_File',
+ $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
+ &GDBM_READER,0640)) {
+ my $version=$hash{"version:$symb"};
+ $returnhash{'version'}=$version;
+ my $scope;
+ for ($scope=1;$scope<=$version;$scope++) {
+ my $vkeys=$hash{"$scope:keys:$symb"};
+ my @keys=split(/:/,$vkeys);
+ my $key;
+ $returnhash{"$scope:keys"}=$vkeys;
+ foreach $key (@keys) {
+ $returnhash{"$scope:$key"}=$hash{"$scope:$symb:$key"};
+ $returnhash{"$key"}=$hash{"$scope:$symb:$key"};
+ }
+ }
+ if (!(untie(%hash))) {
+ return "error:$!";
+ }
+ } else {
+ return "error:$!";
+ }
+ return %returnhash;
+}
+
# ----------------------------------------------------------------------- Store
sub store {
my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
my $home='';
- if ($stuname) {
- $home=&homeserver($stuname,$domain);
- }
+ if ($stuname) { $home=&homeserver($stuname,$domain); }
if (!$symb) { unless ($symb=&symbread()) { return ''; } }
@@ -732,9 +1071,7 @@ sub cstore {
my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
my $home='';
- if ($stuname) {
- $home=&homeserver($stuname,$domain);
- }
+ if ($stuname) { $home=&homeserver($stuname,$domain); }
if (!$symb) { unless ($symb=&symbread()) { return ''; } }
@@ -760,9 +1097,7 @@ sub restore {
my ($symb,$namespace,$domain,$stuname) = @_;
my $home='';
- if ($stuname) {
- $home=&homeserver($stuname,$domain);
- }
+ if ($stuname) { $home=&homeserver($stuname,$domain); }
if (!$symb) {
unless ($symb=escape(&symbread())) { return ''; }
@@ -1035,6 +1370,8 @@ sub eget {
sub allowed {
my ($priv,$uri)=@_;
+
+ my $orguri=$uri;
$uri=&declutter($uri);
# Free bre access to adm and meta resources
@@ -1043,6 +1380,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='';
@@ -1078,7 +1421,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;
}
#
@@ -1109,27 +1452,27 @@ sub allowed {
}
if ($checkreferer) {
- my $refuri=$ENV{'httpref.'.$uri};
+ my $refuri=$ENV{'httpref.'.$orguri};
unless ($refuri) {
map {
if ($_=~/^httpref\..*\*/) {
my $pattern=$_;
+ $pattern=~s/^httpref\.\/res\///;
$pattern=~s/\*/\[\^\/\]\+/g;
$pattern=~s/\//\\\//g;
- if ($uri=~/$pattern/) {
+ 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;
@@ -1139,7 +1482,6 @@ sub allowed {
$uri=$refuri;
$statecond=$refstatecond;
}
- }
}
}
}
@@ -1320,7 +1662,6 @@ sub definerole {
sub metadata_query {
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) {
@@ -1395,6 +1736,20 @@ sub assignrole {
return &reply($command,&homeserver($uname,$udom));
}
+# -------------------------------------------------- Modify user authentication
+sub modifyuserauth {
+ my ($udom,$uname,$umode,$upass)=@_;
+ my $uhome=&homeserver($uname,$udom);
+ &logthis('Call to modify user authentication'.$udom.', '.$uname.', '.
+ $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'});
+ my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.
+ &escape($upass),$uhome);
+ unless ($reply eq 'ok') {
+ return 'error: '.$reply;
+ }
+ return 'ok';
+}
+
# --------------------------------------------------------------- Modify a user
@@ -1483,7 +1838,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),
@@ -1548,7 +1903,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';
}
@@ -1877,12 +2232,24 @@ sub EXT {
# ---------------------------------------------------------------- Get metadata
sub metadata {
- my ($uri,$what)=@_;
+ my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
$uri=&declutter($uri);
my $filename=$uri;
$uri=~s/\.meta$//;
- unless ($metacache{$uri.':keys'}) {
+#
+# Is the metadata already cached?
+# If "keys" are set, the assumption is that everything is already cached.
+# Everything is cached by the main uri, libraries are never directly cached
+#
+ unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600) {
+#
+# Is this a recursive call for a library?
+#
+ if ($liburi) {
+ $liburi=&declutter($liburi);
+ $filename=$liburi;
+ }
my %metathesekeys=();
unless ($filename=~/\.meta$/) { $filename.='.meta'; }
my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
@@ -1892,10 +2259,17 @@ sub metadata {
while ($token=$parser->get_token) {
if ($token->[0] eq 'S') {
if (defined($token->[2]->{'package'})) {
+#
+# This is a package - get package info
+#
my $package=$token->[2]->{'package'};
my $keyroot='';
- if (defined($token->[2]->{'part'})) {
- $keyroot.='_'.$token->[2]->{'part'};
+ if ($prefix) {
+ $keyroot.='_'.$prefix;
+ } else {
+ if (defined($token->[2]->{'part'})) {
+ $keyroot.='_'.$token->[2]->{'part'};
+ }
}
if (defined($token->[2]->{'id'})) {
$keyroot.='_'.$token->[2]->{'id'};
@@ -1924,14 +2298,42 @@ sub metadata {
}
} keys %packagetab;
} else {
- my $entry=$token->[1];
- my $unikey=$entry;
- if (defined($token->[2]->{'part'})) {
- $unikey.='_'.$token->[2]->{'part'};
+#
+# This is not a package - some other kind of start tag
+#
+ my $entry=$token->[1];
+ my $unikey;
+ if ($entry eq 'import') {
+ $unikey='';
+ } else {
+ $unikey=$entry;
+ }
+ if ($prefix) {
+ $unikey.=$prefix;
+ } else {
+ if (defined($token->[2]->{'part'})) {
+ $unikey.='_'.$token->[2]->{'part'};
+ }
}
if (defined($token->[2]->{'id'})) {
$unikey.='_'.$token->[2]->{'id'};
}
+
+ if ($entry eq 'import') {
+#
+# Importing a library here
+#
+ if (defined($depthcount)) { $depthcount++; } else
+ { $depthcount=0; }
+ if ($depthcount<20) {
+ $metacache{$uri.':keys'}.=','.
+ &metadata($uri,'keys',
+ $parser->get_text('/import'),$unikey,
+ $depthcount);
+ }
+
+ } else {
+
if (defined($token->[2]->{'name'})) {
$unikey.='_'.$token->[2]->{'name'};
}
@@ -1944,10 +2346,15 @@ sub metadata {
) { $metacache{$uri.':'.$unikey}=
$metacache{$uri.':'.$unikey.'.default'};
}
- }
+# end of not-a-package not-a-library import
+ }
+# end of not-a-package start tag
+ }
+# the next is the end of "start tag"
}
}
$metacache{$uri.':keys'}=join(',',keys %metathesekeys);
+ $metacache{$uri.':cachedtimestamp'}=time;
}
return $metacache{$uri.':'.$what};
}
@@ -2057,16 +2464,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");
@@ -2169,7 +2581,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");
@@ -2188,9 +2600,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; }
}
}
@@ -2212,8 +2626,10 @@ if ($readit ne 'done') {
while (my $configline=<$config>) {
chomp($configline);
+ if ($configline) {
my ($role,$perm)=split(/ /,$configline);
if ($perm ne '') { $pr{$role}=$perm; }
+ }
}
}
@@ -2223,8 +2639,10 @@ if ($readit ne 'done') {
while (my $configline=<$config>) {
chomp($configline);
+ if ($configline) {
my ($short,$plain)=split(/:/,$configline);
if ($plain ne '') { $prp{$short}=$plain; }
+ }
}
}
@@ -2260,6 +2678,7 @@ if ($readit ne 'done') {
%metacache=();
$readit='done';
+&logtouch();
&logthis('<font color=yellow>INFO: Read configuration</font>');
}
}