--- loncom/lonnet/perl/lonnet.pm 2002/06/24 20:25:44 1.244
+++ loncom/lonnet/perl/lonnet.pm 2002/07/27 19:06:41 1.254
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.244 2002/06/24 20:25:44 matthew Exp $
+# $Id: lonnet.pm,v 1.254 2002/07/27 19:06:41 www Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -80,7 +80,7 @@ use vars
qw(%perlvar %hostname %homecache %badServerCache %hostip %spareid %hostdom
%libserv %pr %prp %metacache %packagetab
%courselogs %accesshash $processmarker $dumpcount
- %coursedombuf %coursehombuf %courseresdatacache);
+ %coursedombuf %coursehombuf %courseresdatacache %domaindescription);
use IO::Socket;
use GDBM_File;
use Apache::Constants qw(:common :http);
@@ -708,6 +708,16 @@ sub ssi {
return $response->content;
}
+# ------- Add a token to a remote URI's query string to vouch for access rights
+
+sub tokenwrapper {
+ my $uri=shift;
+ my $token=&reply('tmpput:'.&escape($uri),$perlvar{'lonHostID'});
+ return $uri.(($uri=~/\?/)?'&':'?').
+ 'token='.$token.'&server='.$perlvar{'lonHostID'};
+}
+
+
# ------------------------------------------------------------------------- Log
sub log {
@@ -1737,9 +1747,15 @@ sub allowed {
}
}
-# Restricted by state?
+# Restricted by state or randomout?
if ($thisallowed=~/X/) {
+ if ($ENV{'acc.randomout'}) {
+ my $symb=&symbread($uri,1);
+ if (($symb) && ($ENV{'acc.randomout'}=~/\&$symb\&/)) {
+ return '';
+ }
+ }
if (&condval($statecond)) {
return '2';
} else {
@@ -2160,51 +2176,74 @@ sub revokecustomrole {
# ------------------------------------------------------------ Directory lister
sub dirlist {
- my $uri=shift;
+ my ($uri,$userdomain,$username,$alternateDirectoryRoot)=@_;
+
$uri=~s/^\///;
$uri=~s/\/$//;
- my ($res,$udom,$uname,@rest)=split(/\//,$uri);
- if ($udom) {
- if ($uname) {
- my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/'.$uri,
- homeserver($uname,$udom));
- return split(/:/,$listing);
- } else {
- my $tryserver;
- my %allusers=();
- foreach $tryserver (keys %libserv) {
- if ($hostdom{$tryserver} eq $udom) {
- my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.$udom,
- $tryserver);
- if (($listing ne 'no_such_dir') && ($listing ne 'empty')
- && ($listing ne 'con_lost')) {
- foreach (split(/:/,$listing)) {
- my ($entry,@stat)=split(/&/,$_);
- $allusers{$entry}=1;
+ my ($udom, $uname);
+ (undef,$udom,$uname)=split(/\//,$uri);
+ if(defined($userdomain)) {
+ $udom = $userdomain;
+ }
+ if(defined($username)) {
+ $uname = $username;
+ }
+
+ my $dirRoot = $perlvar{'lonDocRoot'};
+ if(defined($alternateDirectoryRoot)) {
+ $dirRoot = $alternateDirectoryRoot;
+ $dirRoot =~ s/\/$//;
+ }
+
+ if($udom) {
+ if($uname) {
+ my $listing=reply('ls:'.$dirRoot.'/'.$uri,
+ homeserver($uname,$udom));
+ return split(/:/,$listing);
+ } elsif(!defined($alternateDirectoryRoot)) {
+ my $tryserver;
+ my %allusers=();
+ foreach $tryserver (keys %libserv) {
+ if($hostdom{$tryserver} eq $udom) {
+ my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.
+ $udom, $tryserver);
+ if (($listing ne 'no_such_dir') && ($listing ne 'empty')
+ && ($listing ne 'con_lost')) {
+ foreach (split(/:/,$listing)) {
+ my ($entry,@stat)=split(/&/,$_);
+ $allusers{$entry}=1;
+ }
+ }
}
- }
- }
- }
- my $alluserstr='';
- foreach (sort keys %allusers) {
- $alluserstr.=$_.'&user:';
- }
- $alluserstr=~s/:$//;
- return split(/:/,$alluserstr);
- }
- } else {
- my $tryserver;
- my %alldom=();
- foreach $tryserver (keys %libserv) {
- $alldom{$hostdom{$tryserver}}=1;
- }
- my $alldomstr='';
- foreach (sort keys %alldom) {
- $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:';
- }
- $alldomstr=~s/:$//;
- return split(/:/,$alldomstr);
- }
+ }
+ my $alluserstr='';
+ foreach (sort keys %allusers) {
+ $alluserstr.=$_.'&user:';
+ }
+ $alluserstr=~s/:$//;
+ return split(/:/,$alluserstr);
+ } else {
+ my @emptyResults = ();
+ push(@emptyResults, 'missing user name');
+ return split(':',@emptyResults);
+ }
+ } elsif(!defined($alternateDirectoryRoot)) {
+ my $tryserver;
+ my %alldom=();
+ foreach $tryserver (keys %libserv) {
+ $alldom{$hostdom{$tryserver}}=1;
+ }
+ my $alldomstr='';
+ foreach (sort keys %alldom) {
+ $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:';
+ }
+ $alldomstr=~s/:$//;
+ return split(/:/,$alldomstr);
+ } else {
+ my @emptyResults = ();
+ push(@emptyResults, 'missing domain');
+ return split(':',@emptyResults);
+ }
}
# -------------------------------------------------------- Value of a Condition
@@ -2265,30 +2304,26 @@ sub courseresdata {
my ($coursenum,$coursedomain,@which)=@_;
my $coursehom=&homeserver($coursenum,$coursedomain);
my $hashid=$coursenum.':'.$coursedomain;
- unless (defined($courseresdatacache{$hashid.'.time'})) {
- unless (time-$courseresdatacache{$hashid.'.time'}<300) {
- my $coursehom=&homeserver($coursenum,$coursedomain);
- if ($coursehom) {
- my $dumpreply=&reply('dump:'.$coursedomain.':'.$coursenum.
- ':resourcedata:.',$coursehom);
- unless ($dumpreply=~/^error\:/) {
- $courseresdatacache{$hashid.'.time'}=time;
- $courseresdatacache{$hashid}=$dumpreply;
- }
- }
- }
+ my $dodump=0;
+ if (!defined($courseresdatacache{$hashid.'.time'})) {
+ $dodump=1;
+ } else {
+ if (time-$courseresdatacache{$hashid.'.time'}>300) { $dodump=1; }
}
- my @pairs=split(/\&/,$courseresdatacache{$hashid});
- my %returnhash=();
- foreach (@pairs) {
- my ($key,$value)=split(/=/,$_);
- $returnhash{unescape($key)}=unescape($value);
- }
- my $item;
- foreach $item (@which) {
- if ($returnhash{$item}) { return $returnhash{$item}; }
- }
- return '';
+ if ($dodump) {
+ my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum);
+ my ($tmp) = keys(%dumpreply);
+ if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
+ $courseresdatacache{$hashid.'.time'}=time;
+ $courseresdatacache{$hashid}=\%dumpreply;
+ }
+ }
+ foreach my $item (@which) {
+ if ($courseresdatacache{$hashid}->{$item}) {
+ return $courseresdatacache{$hashid}->{$item};
+ }
+ }
+ return '';
}
# --------------------------------------------------------- Value of a Variable
@@ -2695,7 +2730,7 @@ sub symbclean {
# ------------------------------------------------------ Return symb list entry
sub symbread {
- my $thisfn=shift;
+ my ($thisfn,$donotrecurse)=@_;
# no filename provided? try from environment
unless ($thisfn) {
if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); }
@@ -2744,7 +2779,7 @@ sub symbread {
# ----------------------------------------------- There is only one possibility
my ($mapid,$resid)=split(/\./,$ids);
$syval=declutter($bighash{'map_id_'.$mapid}).'___'.$resid;
- } else {
+ } elsif (!$donotrecurse) {
# ------------------------------------------ There is more than one possibility
my $realpossible=0;
foreach (@possibilities) {
@@ -2759,6 +2794,8 @@ sub symbread {
}
}
if ($realpossible!=1) { $syval=''; }
+ } else {
+ $syval='';
}
}
untie(%bighash)
@@ -2943,11 +2980,18 @@ BEGIN {
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; }
+ my ($id,$domain,$role,$name,$ip,$domdescr)=split(/:/,$configline);
+ if ($id && $domain && $role && $name && $ip) {
+ $hostname{$id}=$name;
+ $hostdom{$id}=$domain;
+ $hostip{$id}=$ip;
+ if ($domdescr) { $domaindescription{$domain}=$domdescr; }
+ if ($role eq 'library') { $libserv{$id}=$name; }
+ } else {
+ if ($configline) {
+ &logthis("Skipping hosts.tab line -$configline-");
+ }
+ }
}
}