--- loncom/lonnet/perl/lonnet.pm 2002/01/04 16:31:41 1.197
+++ loncom/lonnet/perl/lonnet.pm 2002/06/15 19:45:26 1.238
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.197 2002/01/04 16:31:41 www Exp $
+# $Id: lonnet.pm,v 1.238 2002/06/15 19:45:26 www Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -66,7 +66,7 @@
# 12/18 Scott Harrison
# 12/21,12/22,12/27,12/28 Gerd Kortemeyer
# YEAR=2002
-# 1/4 Gerd Kortemeyer
+# 1/4,2/4,2/7 Gerd Kortemeyer
#
###
@@ -77,14 +77,14 @@ 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);
+ %coursedombuf %coursehombuf %courseresdatacache);
use IO::Socket;
use GDBM_File;
use Apache::Constants qw(:common :http);
-use HTML::TokeParser;
+use HTML::LCParser;
use Fcntl qw(:flock);
my $readit;
@@ -137,8 +137,24 @@ sub subreply {
sub reply {
my ($cmd,$server)=@_;
+ unless (defined($hostname{$server})) { return 'no_such_host'; }
my $answer=subreply($cmd,$server);
- if ($answer eq 'con_lost') { $answer=subreply($cmd,$server); }
+ if ($answer eq 'con_lost') {
+ #sleep 5;
+ #$answer=subreply($cmd,$server);
+ #if ($answer eq 'con_lost') {
+ # &logthis("Second attempt con_lost on $server");
+ # my $peerfile="$perlvar{'lonSockDir'}/$server";
+ # my $client=IO::Socket::UNIX->new(Peer =>"$peerfile",
+ # Type => SOCK_STREAM,
+ # Timeout => 10)
+ # or return "con_lost";
+ # &logthis("Killing socket");
+ # print $client "close_connection_exit\n";
+ #sleep 5;
+ # $answer=subreply($cmd,$server);
+ #}
+ }
if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
&logthis("WARNING:".
" $cmd to $server returned $answer");
@@ -348,6 +364,41 @@ sub spareserver {
return $spareserver;
}
+# --------------------------------------------- Try to change a user's password
+
+sub changepass {
+ my ($uname,$udom,$currentpass,$newpass,$server)=@_;
+ $currentpass = &escape($currentpass);
+ $newpass = &escape($newpass);
+ my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass",
+ $server);
+ if (! $answer) {
+ &logthis("No reply on password change request to $server ".
+ "by $uname in domain $udom.");
+ } elsif ($answer =~ "^ok") {
+ &logthis("$uname in $udom successfully changed their password ".
+ "on $server.");
+ } elsif ($answer =~ "^pwchange_failure") {
+ &logthis("$uname in $udom was unable to change their password ".
+ "on $server. The action was blocked by either lcpasswd ".
+ "or pwchange");
+ } elsif ($answer =~ "^non_authorized") {
+ &logthis("$uname in $udom did not get their password correct when ".
+ "attempting to change it on $server.");
+ } elsif ($answer =~ "^auth_mode_error") {
+ &logthis("$uname in $udom attempted to change their password despite ".
+ "not being locally or internally authenticated on $server.");
+ } elsif ($answer =~ "^unknown_user") {
+ &logthis("$uname in $udom attempted to change their password ".
+ "on $server but were unable to because $server is not ".
+ "their home server.");
+ } elsif ($answer =~ "^refused") {
+ &logthis("$server refused to change $uname in $udom password because ".
+ "it was sent an unencrypted request to change the password.");
+ }
+ return $answer;
+}
+
# ----------------------- Try to determine user's current authentication scheme
sub queryauthenticate {
@@ -391,6 +442,7 @@ sub queryauthenticate {
sub authenticate {
my ($uname,$upass,$udom)=@_;
$upass=escape($upass);
+ $uname=~s/\W//g;
if (($perlvar{'lonRole'} eq 'library') &&
($udom eq $perlvar{'lonDefDomain'})) {
my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'});
@@ -429,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';
@@ -575,6 +631,7 @@ sub subscribe {
sub repcopy {
my $filename=shift;
$filename=~s/\/+/\//g;
+ if ($filename=~/^\/home\/httpd\/html\/adm\//) { return OK; }
my $transname="$filename.in.transfer";
if ((-e $filename) || (-e $transname)) { return OK; }
my $remoteurl=subscribe($filename);
@@ -640,7 +697,7 @@ sub ssi {
if (%form) {
$request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn);
- $request->content(join '&', map { "$_=$form{$_}" } keys %form);
+ $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));
} else {
$request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn);
}
@@ -742,6 +799,7 @@ sub checkout {
my $now=time;
my $lonhost=$perlvar{'lonHostID'};
my $infostr=&escape(
+ 'CHECKOUTTOKEN&'.
$tuname.'&'.
$tudom.'&'.
$tcrsid.'&'.
@@ -791,7 +849,7 @@ sub checkin {
$lonhost=~tr/A-Z/a-z/;
my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb;
$dtoken=~s/\W/\_/g;
- my ($tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
+ my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
unless (($tuname) && ($tudom)) {
@@ -861,10 +919,55 @@ sub devalidate {
}
}
+sub arrayref2str {
+ my ($arrayref) = @_;
+ my $result='_ARRAY_REF__';
+ foreach my $elem (@$arrayref) {
+ if (ref($elem) eq 'ARRAY') {
+ $result.=&escape(&arrayref2str($elem)).'&';
+ } elsif (ref($elem) eq 'HASH') {
+ $result.=&escape(&hashref2str($elem)).'&';
+ } elsif (ref($elem)) {
+ &logthis("Got a ref of ".(ref($elem))." skipping.");
+ } else {
+ $result.=&escape($elem).'&';
+ }
+ }
+ $result=~s/\&$//;
+ return $result;
+}
+
sub hash2str {
- my (%hash)=@_;
- my $result='';
- foreach (keys %hash) { $result.=escape($_).'='.escape($hash{$_}).'&'; }
+ my (%hash) = @_;
+ my $result=&hashref2str(\%hash);
+ $result=~s/^_HASH_REF__//;
+ return $result;
+}
+
+sub hashref2str {
+ my ($hashref)=@_;
+ my $result='_HASH_REF__';
+ foreach (keys(%$hashref)) {
+ if (ref($_) eq 'ARRAY') {
+ $result.=&escape(&arrayref2str($_)).'=';
+ } elsif (ref($_) eq 'HASH') {
+ $result.=&escape(&hashref2str($_)).'=';
+ } elsif (ref($_)) {
+ &logthis("Got a ref of ".(ref($_))." skipping.");
+ } else {
+ $result.=&escape($_).'=';
+ }
+
+ if (ref($$hashref{$_}) eq 'ARRAY') {
+ $result.=&escape(&arrayref2str($$hashref{$_})).'&';
+ } elsif (ref($$hashref{$_}) eq 'HASH') {
+ $result.=&escape(&hashref2str($$hashref{$_})).'&';
+ } elsif (ref($$hashref{$_})) {
+ &logthis("Got a ref of ".(ref($$hashref{$_}))." skipping.");
+ } else {
+ $result.=&escape($$hashref{$_}).'&';
+ }
+ }
$result=~s/\&$//;
return $result;
}
@@ -874,9 +977,39 @@ sub str2hash {
my %returnhash;
foreach (split(/\&/,$string)) {
my ($name,$value)=split(/\=/,$_);
- $returnhash{&unescape($name)}=&unescape($value);
+ $name=&unescape($name);
+ $value=&unescape($value);
+ if ($value =~ /^_HASH_REF__/) {
+ $value =~ s/^_HASH_REF__//;
+ my %hash=&str2hash($value);
+ $value=\%hash;
+ } elsif ($value =~ /^_ARRAY_REF__/) {
+ $value =~ s/^_ARRAY_REF__//;
+ my @array=&str2array($value);
+ $value=\@array;
+ }
+ $returnhash{$name}=$value;
}
- return %returnhash;
+ return (%returnhash);
+}
+
+sub str2array {
+ my ($string) = @_;
+ my @returnarray;
+ foreach my $value (split(/\&/,$string)) {
+ $value=&unescape($value);
+ if ($value =~ /^_HASH_REF__/) {
+ $value =~ s/^_HASH_REF__//;
+ my %hash=&str2hash($value);
+ $value=\%hash;
+ } elsif ($value =~ /^_ARRAY_REF__/) {
+ $value =~ s/^_ARRAY_REF__//;
+ my @array=&str2array($value);
+ $value=\@array;
+ }
+ push(@returnarray,$value);
+ }
+ return (@returnarray);
}
# -------------------------------------------------------------------Temp Store
@@ -1011,6 +1144,7 @@ sub store {
if ($stuname) { $home=&homeserver($stuname,$domain); }
+ $symb=&symbclean($symb);
if (!$symb) { unless ($symb=&symbread()) { return ''; } }
&devalidate($symb);
@@ -1041,6 +1175,7 @@ sub cstore {
if ($stuname) { $home=&homeserver($stuname,$domain); }
+ $symb=&symbclean($symb);
if (!$symb) { unless ($symb=&symbread()) { return ''; } }
&devalidate($symb);
@@ -1076,7 +1211,7 @@ sub restore {
if (!$symb) {
unless ($symb=escape(&symbread())) { return ''; }
} else {
- $symb=&escape($symb);
+ $symb=&escape(&symbclean($symb));
}
if (!$namespace) {
unless ($namespace=$ENV{'request.course.id'}) {
@@ -1366,7 +1501,21 @@ sub allowed {
# Free bre to public access
if ($priv eq 'bre') {
- if (&metadata($uri,'copyright') eq 'public') { return 'F'; }
+ my $copyright=&metadata($uri,'copyright');
+ if ($copyright eq 'public') { return 'F'; }
+ if ($copyright eq 'priv') {
+ $uri=~/([^\/]+)\/([^\/]+)\//;
+ unless (($ENV{'user.name'} eq $2) && ($ENV{'user.domain'} eq $1)) {
+ return '';
+ }
+ }
+ if ($copyright eq 'domain') {
+ $uri=~/([^\/]+)\/([^\/]+)\//;
+ unless (($ENV{'user.domain'} eq $1) ||
+ ($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $1)) {
+ return '';
+ }
+ }
}
my $thisallowed='';
@@ -1414,19 +1563,16 @@ sub allowed {
# the course
if ($ENV{'request.course.id'}) {
+
$courseprivid=$ENV{'request.course.id'};
if ($ENV{'request.course.sec'}) {
$courseprivid.='/'.$ENV{'request.course.sec'};
}
$courseprivid=~s/\_/\//;
my $checkreferer=1;
- my @uriparts=split(/\//,$uri);
- my $filename=$uriparts[$#uriparts];
- my $pathname=$uri;
- $pathname=~s/\/$filename$//;
- if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
- /\&$filename\:([\d\|]+)\&/) {
- $statecond=$1;
+ my ($match,$cond)=&is_on_map($uri);
+ if ($match) {
+ $statecond=$cond;
if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}
=~/$priv\&([^\:]*)/) {
$thisallowed.=$1;
@@ -1436,7 +1582,6 @@ sub allowed {
if ($checkreferer) {
my $refuri=$ENV{'httpref.'.$orguri};
-
unless ($refuri) {
foreach (keys %ENV) {
if ($_=~/^httpref\..*\*/) {
@@ -1450,15 +1595,12 @@ sub allowed {
}
}
}
+
if ($refuri) {
$refuri=&declutter($refuri);
- my @uriparts=split(/\//,$refuri);
- my $filename=$uriparts[$#uriparts];
- my $pathname=$refuri;
- $pathname=~s/\/$filename$//;
- if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
- /\&$filename\:([\d\|]+)\&/) {
- my $refstatecond=$1;
+ my ($match,$cond)=&is_on_map($refuri);
+ if ($match) {
+ my $refstatecond=$cond;
if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}
=~/$priv\&([^\:]*)/) {
$thisallowed.=$1;
@@ -1556,6 +1698,7 @@ sub allowed {
if ($thisallowed=~/C/) {
my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
+ my $unamedom=$ENV{'user.name'}.':'.$ENV{'user.domain'};
if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'}
=~/$rolecode/) {
&log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
@@ -1563,6 +1706,14 @@ sub allowed {
$ENV{'request.course.id'});
return '';
}
+
+ if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.users.denied'}
+ =~/$unamedom/) {
+ &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
+ 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
+ $ENV{'request.course.id'});
+ return '';
+ }
}
# Resource preferences
@@ -1599,6 +1750,23 @@ sub allowed {
return 'F';
}
+# --------------------------------------------------- Is a resource on the map?
+
+sub is_on_map {
+ my $uri=&declutter(shift);
+ my @uriparts=split(/\//,$uri);
+ my $filename=$uriparts[$#uriparts];
+ my $pathname=$uri;
+ $pathname=~s/\/$filename$//;
+ my $match=($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
+ /\&$filename\:([\d\|]+)\&/);
+ if ($match) {
+ return (1,$1);
+ } else {
+ return (0,0);
+ }
+}
+
# ----------------------------------------------------------------- Define Role
sub definerole {
@@ -1732,21 +1900,28 @@ sub modifyuserauth {
# --------------------------------------------------------------- Modify a user
-
sub modifyuser {
- my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,
- $forceid)=@_;
+ my ($udom, $uname, $uid,
+ $umode, $upass, $first,
+ $middle, $last, $gene,
+ $forceid, $desiredhome)=@_;
+ $udom=~s/\W//g;
+ $uname=~s/\W//g;
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
$umode.', '.$first.', '.$middle.', '.
- $last.', '.$gene.'(forceid: '.$forceid.') by '.
- $ENV{'user.name'}.' at '.$ENV{'user.domain'});
- my $uhome=&homeserver($uname,$udom);
+ $last.', '.$gene.'(forceid: '.$forceid.')'.
+ (defined($desiredhome) ? ' desiredhome = '.$desiredhome :
+ ' desiredhome not specified').
+ ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'});
+ my $uhome=&homeserver($uname,$udom,'true');
# ----------------------------------------------------------------- Create User
if (($uhome eq 'no_host') && ($umode) && ($upass)) {
my $unhome='';
- if ($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) {
+ if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) {
+ $unhome = $desiredhome;
+ } elsif($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) {
$unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
- } else {
+ } else { # load balancing routine for determining $unhome
my $tryserver;
my $loadm=10000000;
foreach $tryserver (keys %libserv) {
@@ -1760,18 +1935,19 @@ sub modifyuser {
}
}
if (($unhome eq '') || ($unhome eq 'no_host')) {
- return 'error: find home';
+ return 'error: unable to find a home server for '.$uname.
+ ' in domain '.$udom;
}
my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'.
&escape($upass),$unhome);
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';
}
- }
+ } # End of creation of new user
# ---------------------------------------------------------------------- Add ID
if ($uid) {
$uid=~tr/A-Z/a-z/;
@@ -1789,6 +1965,7 @@ sub modifyuser {
my %names=&get('environment',
['firstname','middlename','lastname','generation'],
$udom,$uname);
+ if ($names{'firstname'} =~ m/^error:.*/) { %names=(); }
if ($first) { $names{'firstname'} = $first; }
if ($middle) { $names{'middlename'} = $middle; }
if ($last) { $names{'lastname'} = $last; }
@@ -1806,14 +1983,15 @@ sub modifyuser {
sub modifystudent {
my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
- $end,$start,$forceid)=@_;
+ $end,$start,$forceid,$desiredhome)=@_;
my $cid='';
unless ($cid=$ENV{'request.course.id'}) {
return 'not_in_class';
}
# --------------------------------------------------------------- Make the user
my $reply=&modifyuser
- ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid);
+ ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,
+ $desiredhome);
unless ($reply eq 'ok') { return $reply; }
my $uhome=&homeserver($uname,$udom);
if (($uhome eq '') || ($uhome eq 'no_host')) {
@@ -1872,11 +2050,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';
}
@@ -1885,7 +2063,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';
}
@@ -2021,11 +2199,54 @@ sub condval {
return $result;
}
+# --------------------------------------------------- Course Resourcedata Query
+
+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 @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 '';
+}
+
# --------------------------------------------------------- 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]) {
@@ -2040,19 +2261,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;
@@ -2061,17 +2291,21 @@ 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;
my %reply=&get($space,[$item]);
return $reply{$item};
}
- } elsif ($realm eq 'request') {
+ } elsif ($realm eq 'query') {
+# ---------------------------------------------- pull stuff out of query string
+ &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},[$space]);
+ return $ENV{'form.'.$space};
+ } elsif ($realm eq 'request') {
# ------------------------------------------------------------- request.browser
if ($space eq 'browser') {
return $ENV{'browser.'.$qualifier};
@@ -2081,127 +2315,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 $reply=&reply('get:'.
- $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.
- $ENV{'course.'.$ENV{'request.course.id'}.'.num'}.
- ':resourcedata:'.
- &escape($seclevelr).'&'.&escape($seclevelm).'&'.&escape($seclevel).'&'.
- &escape($courselevelr).'&'.&escape($courselevelm).'&'.&escape($courselevel),
- $ENV{'course.'.$ENV{'request.course.id'}.'.home'});
- if ($reply!~/^error\:/) {
- foreach (split(/\&/,$reply)) {
- if ($_) { return &unescape($_); }
- }
- }
- if (($reply=~/^con_lost/) || ($reply=~/^error\:/)) {
- &logthis("WARNING:".
- " Getting ".$reply." asking for ".$varname." for ".
- $ENV{'course.'.$ENV{'request.course.id'}.'.num'}.
- ' at '.
- $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.
- ' from '.
- $ENV{'course.'.$ENV{'request.course.id'}.'.home'}.
- "");
- }
+ 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') {
@@ -2235,7 +2454,7 @@ sub metadata {
my %metathesekeys=();
unless ($filename=~/\.meta$/) { $filename.='.meta'; }
my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
- my $parser=HTML::TokeParser->new(\$metastring);
+ my $parser=HTML::LCParser->new(\$metastring);
my $token;
undef %metathesekeys;
while ($token=$parser->get_token) {
@@ -2324,7 +2543,7 @@ sub metadata {
$metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};
}
unless (
- $metacache{$uri.':'.$unikey}=$parser->get_text('/'.$entry)
+ $metacache{$uri.':'.$unikey}=&HTML::Entities::decode($parser->get_text('/'.$entry))
) { $metacache{$uri.':'.$unikey}=
$metacache{$uri.':'.$unikey.'.default'};
}
@@ -2362,12 +2581,63 @@ sub symblist {
return 'error';
}
+# --------------------------------------------------------------- Verify a symb
+
+sub symbverify {
+ my ($symb,$thisfn)=@_;
+ $thisfn=&declutter($thisfn);
+# direct jump to resource in page or to a sequence - will construct own symbs
+ if ($thisfn=~/\.(page|sequence)$/) { return 1; }
+# check URL part
+ my ($map,$resid,$url)=split(/\_\_\_/,$symb);
+ unless (&symbclean($url) eq &symbclean($thisfn)) { return 0; }
+
+ $symb=&symbclean($symb);
+
+ my %bighash;
+ my $okay=0;
+ if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
+ &GDBM_READER,0640)) {
+ my $ids=$bighash{'ids_/res/'.$thisfn};
+ unless ($ids) {
+ $ids=$bighash{'ids_/'.$thisfn};
+ }
+ if ($ids) {
+# ------------------------------------------------------------------- Has ID(s)
+ foreach (split(/\,/,$ids)) {
+ my ($mapid,$resid)=split(/\./,$_);
+ if (
+ &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
+ eq $symb) {
+ $okay=1;
+ }
+ }
+ }
+ untie(%bighash);
+ }
+ return $okay;
+}
+
+# --------------------------------------------------------------- Clean-up symb
+
+sub symbclean {
+ my $symb=shift;
+
+# remove version from map
+ $symb=~s/\.(\d+)\.(\w+)\_\_\_/\.$2\_\_\_/;
+
+# remove version from URL
+ $symb=~s/\.(\d+)\.(\w+)$/\.$2/;
+
+ return $symb;
+}
+
# ------------------------------------------------------ Return symb list entry
sub symbread {
my $thisfn=shift;
unless ($thisfn) {
- if ($ENV{'request.symb'}) { return $ENV{'request.symb'}; }
+ if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); }
$thisfn=$ENV{'request.filename'};
}
$thisfn=declutter($thisfn);
@@ -2426,7 +2696,7 @@ sub symbread {
}
}
if ($syval) {
- return $syval.'___'.$thisfn;
+ return &symbclean($syval.'___'.$thisfn);
}
}
&appenv('request.ambiguous' => $thisfn);
@@ -2530,6 +2800,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;
@@ -2543,6 +2814,7 @@ sub declutter {
$thisfn=~s/^$perlvar{'lonDocRoot'}//;
$thisfn=~s/^\///;
$thisfn=~s/^res\///;
+ $thisfn=~s/\?.+$//;
return $thisfn;
}
@@ -2565,18 +2837,30 @@ sub unescape {
# ================================================================ Main Program
sub goodbye {
+ &logthis("Starting Shut down");
&flushcourselogs();
&logthis("Shutting down");
}
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;
@@ -2827,12 +3111,30 @@ devalidate($symb) : devalidate spreadshe
=item *
hash2str(%hash) : convert a hash into a string complete with escaping and '='
-and '&' separators
+and '&' separators, supports elements that are arrayrefs and hashrefs
+
+=item *
+
+hashref2str($hashref) : convert a hashref into a string complete with
+escaping and '=' and '&' separators, supports elements that are
+arrayrefs and hashrefs
+
+=item *
+
+arrayref2str($arrayref) : convert an arrayref into a string complete
+with escaping and '&' separators, supports elements that are arrayrefs
+and hashrefs
+
+=item *
+
+str2hash($string) : convert string to hash using unescaping and
+splitting on '=' and '&', supports elements that are arrayrefs and
+hashrefs
=item *
-str2hash($string) : convert string to hash using unescaping and splitting on
-'=' and '&'
+str2array($string) : convert string to hash using unescaping and
+splitting on '&', supports elements that are arrayrefs and hashrefs
=item *
@@ -3027,7 +3329,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 *