--- loncom/lonnet/perl/lonnet.pm 2002/05/08 17:40:03 1.216
+++ loncom/lonnet/perl/lonnet.pm 2002/05/22 13:56:43 1.231
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.216 2002/05/08 17:40:03 www Exp $
+# $Id: lonnet.pm,v 1.231 2002/05/22 13:56:43 stredwic Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -77,7 +77,7 @@ use Apache::File;
use LWP::UserAgent();
use HTTP::Headers;
use vars
-qw(%perlvar %hostname %homecache %hostip %spareid %hostdom
+qw(%perlvar %hostname %homecache %badServerCache %hostip %spareid %hostdom
%libserv %pr %prp %metacache %packagetab
%courselogs %accesshash $processmarker $dumpcount
%coursedombuf %coursehombuf %courseresdatacache);
@@ -481,19 +481,23 @@ sub authenticate {
# ---------------------- Find the homebase for a user from domain's lib servers
sub homeserver {
- my ($uname,$udom)=@_;
-
+ my ($uname,$udom,$ignoreBadCache)=@_;
my $index="$uname:$udom";
- if ($homecache{$index}) { return "$homecache{$index}"; }
-
+ if ($homecache{$index}) {
+ return "$homecache{$index}";
+ }
my $tryserver;
foreach $tryserver (keys %libserv) {
+ next if ($ignoreBadCache ne 'true' &&
+ exists($badServerCache{$tryserver}));
if ($hostdom{$tryserver} eq $udom) {
my $answer=reply("home:$udom:$uname",$tryserver);
if ($answer eq 'found') {
- $homecache{$index}=$tryserver;
+ $homecache{$index}=$tryserver;
return $tryserver;
- }
+ } elsif ($answer eq 'no_host') {
+ $badServerCache{$tryserver}=1;
+ }
}
}
return 'no_host';
@@ -1875,7 +1879,7 @@ sub modifyuser {
(defined($desiredhome) ? ' desiredhome = '.$desiredhome :
' desiredhome not specified').
' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'});
- my $uhome=&homeserver($uname,$udom);
+ my $uhome=&homeserver($uname,$udom,'true');
# ----------------------------------------------------------------- Create User
if (($uhome eq 'no_host') && ($umode) && ($upass)) {
my $unhome='';
@@ -1905,7 +1909,7 @@ sub modifyuser {
unless ($reply eq 'ok') {
return 'error: '.$reply;
}
- $uhome=&homeserver($uname,$udom);
+ $uhome=&homeserver($uname,$udom,'true');
if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {
return 'error: verify home';
}
@@ -2012,11 +2016,11 @@ sub createcourse {
my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
# ----------------------------------------------- Make sure that does not exist
- my $uhome=&homeserver($uname,$udom);
+ my $uhome=&homeserver($uname,$udom,'true');
unless (($uhome eq '') || ($uhome eq 'no_host')) {
$uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
- $uhome=&homeserver($uname,$udom);
+ $uhome=&homeserver($uname,$udom,'true');
unless (($uhome eq '') || ($uhome eq 'no_host')) {
return 'error: unable to generate unique course-ID';
}
@@ -2025,7 +2029,7 @@ sub createcourse {
my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
$ENV{'user.home'});
unless ($reply eq 'ok') { return 'error: '.$reply; }
- $uhome=&homeserver($uname,$udom);
+ $uhome=&homeserver($uname,$udom,'true');
if (($uhome eq '') || ($uhome eq 'no_host')) {
return 'error: no such course';
}
@@ -2196,8 +2200,19 @@ sub courseresdata {
# --------------------------------------------------------- Value of a Variable
sub EXT {
- my ($varname,$symbparm)=@_;
+ my ($varname,$symbparm,$udom,$uname)=@_;
+
unless ($varname) { return ''; }
+
+ #get real user name/domain, courseid and symb
+ my $courseid;
+ if (!($uname && $udom)) {
+ (my $cursymb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
+ if (!$symbparm) { $symbparm=$cursymb; }
+ } else {
+ $courseid=$ENV{'request.course.id'};
+ }
+
my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
my $rest;
if ($therest[0]) {
@@ -2212,19 +2227,28 @@ sub EXT {
if ($realm eq 'user') {
# --------------------------------------------------------------- user.resource
if ($space eq 'resource') {
- my %restored=&restore();
+ my %restored=&restore(undef,undef,$udom,$uname);
return $restored{$qualifierrest};
# ----------------------------------------------------------------- user.access
} elsif ($space eq 'access') {
+ # FIXME - not supporting calls for a specific user
return &allowed($qualifier,$rest);
# ------------------------------------------ user.preferences, user.environment
} elsif (($space eq 'preferences') || ($space eq 'environment')) {
- return $ENV{join('.',('environment',$qualifierrest))};
+ if (($uname eq $ENV{'user.name'}) &&
+ ($udom eq $ENV{'user.domain'})) {
+ return $ENV{join('.',('environment',$qualifierrest))};
+ } else {
+ my %returnhash=&userenvironment($udom,$uname,$qualifierrest);
+ return $returnhash{$qualifierrest};
+ }
# ----------------------------------------------------------------- user.course
} elsif ($space eq 'course') {
+ # FIXME - not supporting calls for a specific user
return $ENV{join('.',('request.course',$qualifier))};
# ------------------------------------------------------------------- user.role
} elsif ($space eq 'role') {
+ # FIXME - not supporting calls for a specific user
my ($role,$where)=split(/\./,$ENV{'request.role'});
if ($qualifier eq 'value') {
return $role;
@@ -2233,10 +2257,10 @@ sub EXT {
}
# ----------------------------------------------------------------- user.domain
} elsif ($space eq 'domain') {
- return $ENV{'user.domain'};
+ return $udom;
# ------------------------------------------------------------------- user.name
} elsif ($space eq 'name') {
- return $ENV{'user.name'};
+ return $uname;
# ---------------------------------------------------- Any other user namespace
} else {
my $item=($rest)?$qualifier.'.'.$rest:$qualifier;
@@ -2253,112 +2277,112 @@ sub EXT {
}
} elsif ($realm eq 'course') {
# ---------------------------------------------------------- course.description
- return $ENV{'course.'.$ENV{'request.course.id'}.'.'.
- $spacequalifierrest};
+ return $ENV{'course.'.$courseid.'.'.$spacequalifierrest};
} elsif ($realm eq 'resource') {
- if ($ENV{'request.course.id'}) {
-# print '
'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
+ if ($courseid eq $ENV{'request.course.id'}) {
+ #print '
'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
# ----------------------------------------------------- Cascading lookup scheme
- my $symbp;
- if ($symbparm) {
- $symbp=$symbparm;
- } else {
- $symbp=&symbread();
- }
- my $mapp=(split(/\_\_\_/,$symbp))[0];
-
- my $symbparm=$symbp.'.'.$spacequalifierrest;
- my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
-
- my $seclevel=
- $ENV{'request.course.id'}.'.['.
- $ENV{'request.course.sec'}.'].'.$spacequalifierrest;
- my $seclevelr=
- $ENV{'request.course.id'}.'.['.
- $ENV{'request.course.sec'}.'].'.$symbparm;
- my $seclevelm=
- $ENV{'request.course.id'}.'.['.
- $ENV{'request.course.sec'}.'].'.$mapparm;
-
- my $courselevel=
- $ENV{'request.course.id'}.'.'.$spacequalifierrest;
- my $courselevelr=
- $ENV{'request.course.id'}.'.'.$symbparm;
- my $courselevelm=
- $ENV{'request.course.id'}.'.'.$mapparm;
+ if (!$symbparm) { $symbparm=&symbread(); }
+ my $symbp=$symbparm;
+ my $mapp=(split(/\_\_\_/,$symbp))[0];
+
+ my $symbparm=$symbp.'.'.$spacequalifierrest;
+ my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
+
+ my $section;
+ if (($ENV{'user.name'} eq $uname) &&
+ ($ENV{'user.domain'} eq $udom)) {
+ $section={'request.course.sec'};
+ } else {
+ $section=&usection($udom,$uname,$courseid);
+ }
-# ----------------------------------------------------------- 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 $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
+ my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;
+ my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;
+
+ my $courselevel=$courseid.'.'.$spacequalifierrest;
+ my $courselevelr=$courseid.'.'.$symbparm;
+ my $courselevelm=$courseid.'.'.$mapparm;
- } else {
- if ($resourcedata{$courselevelr}!~/No such file/) {
- &logthis("WARNING:".
- " Trying to get resource data for ".$ENV{'user.name'}." at "
- .$ENV{'user.domain'}.": ".$resourcedata{$courselevelr}.
- "");
- }
- }
+# ----------------------------------------------------------- first, check user
+ my %resourcedata=&get('resourcedata',
+ [$courselevelr,$courselevelm,$courselevel],
+ $udom,$uname);
+ 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/) {
+ &logthis("WARNING:".
+ " Trying to get resource data for ".
+ $uname." at ".$udom.": ".
+ $resourcedata{$courselevelr}."");
+ }
+ }
# -------------------------------------------------------- second, check course
- my $coursereply=&courseresdata(
- $ENV{'course.'.$ENV{'request.course.id'}.'.num'},
- $ENV{'course.'.$ENV{'request.course.id'}.'.domain'},
- ($seclevelr,$seclevelm,$seclevel,
- $courselevelr,$courselevelm,$courselevel));
- if ($coursereply) { return $coursereply; }
+ my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'},
+ $ENV{'course.'.$courseid.'.domain'},
+ ($seclevelr,$seclevelm,$seclevel,
+ $courselevelr,$courselevelm,
+ $courselevel));
+ if ($coursereply) { return $coursereply; }
# ------------------------------------------------------ third, check map parms
- my %parmhash=();
- my $thisparm='';
- if (tie(%parmhash,'GDBM_File',
- $ENV{'request.course.fn'}.'_parms.db',&GDBM_READER,0640)) {
- $thisparm=$parmhash{$symbparm};
- untie(%parmhash);
- }
- if ($thisparm) { return $thisparm; }
- }
-
+ my %parmhash=();
+ my $thisparm='';
+ if (tie(%parmhash,'GDBM_File',
+ $ENV{'request.course.fn'}.'_parms.db',
+ &GDBM_READER,0640)) {
+ $thisparm=$parmhash{$symbparm};
+ untie(%parmhash);
+ }
+ if ($thisparm) { return $thisparm; }
+ }
# --------------------------------------------- last, look in resource metadata
- $spacequalifierrest=~s/\./\_/;
- my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest);
- if ($metadata) { return $metadata; }
- $metadata=&metadata($ENV{'request.filename'},
- 'parameter_'.$spacequalifierrest);
- if ($metadata) { return $metadata; }
+ $spacequalifierrest=~s/\./\_/;
+ my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest);
+ if ($metadata) { return $metadata; }
+ $metadata=&metadata($ENV{'request.filename'},
+ '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; }
- }
- }
+ unless ($space eq '0') {
+ my ($part,$id)=split(/\_/,$space);
+ if ($id) {
+ my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
+ $symbparm,$udom,$uname);
+ if ($partgeneral) { return $partgeneral; }
+ } else {
+ my $resourcegeneral=&EXT('resource.0.'.$qualifierrest,
+ $symbparm,$udom,$uname);
+ if ($resourcegeneral) { return $resourcegeneral; }
+ }
+ }
# ---------------------------------------------------- Any other user namespace
} elsif ($realm eq 'environment') {
# ----------------------------------------------------------------- environment
- return $ENV{'environment.'.$spacequalifierrest};
+ if (($uname eq $ENV{'user.name'})&&($udom eq $ENV{'user.domain'})) {
+ return $ENV{'environment.'.$spacequalifierrest};
+ } else {
+ my %returnhash=&userenvironment($udom,$uname,
+ $spacequalifierrest);
+ return $returnhash{$spacequalifierrest};
+ }
} elsif ($realm eq 'system') {
# ----------------------------------------------------------------- system.time
if ($space eq 'time') {
@@ -2738,6 +2762,7 @@ sub hreflocation {
unless (($file=~/^http:\/\//i) || ($file=~/^\//)) {
my $finalpath=filelocation($dir,$file);
$finalpath=~s/^\/home\/httpd\/html//;
+ $finalpath=~s-/home/(\w+)/public_html/-/~$1/-;
return $finalpath;
} else {
return $file;
@@ -2779,13 +2804,24 @@ sub goodbye {
}
BEGIN {
-# ------------------------------------------------------------ Read access.conf
+# ----------------------------------- Read loncapa.conf and loncapa_apache.conf
unless ($readit) {
{
- my $config=Apache::File->new("/etc/httpd/conf/access.conf");
+ my $config=Apache::File->new("/etc/httpd/conf/loncapa.conf");
+
+ while (my $configline=<$config>) {
+ if ($configline =~ /^[^\#]*PerlSetVar/) {
+ my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
+ chomp($varvalue);
+ $perlvar{$varname}=$varvalue;
+ }
+ }
+}
+{
+ my $config=Apache::File->new("/etc/httpd/conf/loncapa_apache.conf");
while (my $configline=<$config>) {
- if ($configline =~ /PerlSetVar/) {
+ if ($configline =~ /^[^\#]*PerlSetVar/) {
my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
chomp($varvalue);
$perlvar{$varname}=$varvalue;
@@ -3254,7 +3290,7 @@ replicates and subscribes to the file
=item *
filelocation($dir,$file) : returns file system location of a file based on URI;
-meant to be "fairly clean" absolute reference
+meant to be "fairly clean" absolute reference, $dir is a directory that relative $file lookups are to looked in ($dir of /a/dir and a file of ../bob will become /a/bob)
=item *