--- loncom/lonnet/perl/lonnet.pm 2008/02/29 21:01:24 1.945
+++ loncom/lonnet/perl/lonnet.pm 2008/04/16 22:59:36 1.955
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.945 2008/02/29 21:01:24 raeburn Exp $
+# $Id: lonnet.pm,v 1.955 2008/04/16 22:59:36 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -448,27 +448,39 @@ sub timed_flock {
# ---------------------------------------------------------- Append Environment
sub appenv {
- my %newenv=@_;
- foreach my $key (keys(%newenv)) {
- if (($newenv{$key}=~/^user\.role/) || ($newenv{$key}=~/^user\.priv/)) {
- &logthis("<font color=\"blue\">WARNING: ".
- "Attempt to modify environment ".$key." to ".$newenv{$key}
- .'</font>');
- delete($newenv{$key});
- } else {
- $env{$key}=$newenv{$key};
+ my ($newenv,$roles) = @_;
+ if (ref($newenv) eq 'HASH') {
+ foreach my $key (keys(%{$newenv})) {
+ my $refused = 0;
+ if (($key =~ /^user\.role/) || ($key =~ /^user\.priv/)) {
+ $refused = 1;
+ if (ref($roles) eq 'ARRAY') {
+ my ($type,$role) = ($key =~ /^user\.(role|priv)\.([^.]+)\./);
+ if (grep(/^\Q$role\E$/,@{$roles})) {
+ $refused = 0;
+ }
+ }
+ }
+ if ($refused) {
+ &logthis("<font color=\"blue\">WARNING: ".
+ "Attempt to modify environment ".$key." to ".$newenv->{$key}
+ .'</font>');
+ delete($newenv->{$key});
+ } else {
+ $env{$key}=$newenv->{$key};
+ }
+ }
+ my $opened = open(my $env_file,'+<',$env{'user.environment'});
+ if ($opened
+ && &timed_flock($env_file,LOCK_EX)
+ &&
+ tie(my %disk_env,'GDBM_File',$env{'user.environment'},
+ (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
+ while (my ($key,$value) = each(%{$newenv})) {
+ $disk_env{$key} = $value;
+ }
+ untie(%disk_env);
}
- }
- my $opened = open(my $env_file,'+<',$env{'user.environment'});
- if ($opened
- && &timed_flock($env_file,LOCK_EX)
- &&
- tie(my %disk_env,'GDBM_File',$env{'user.environment'},
- (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
- while (my ($key,$value) = each(%newenv)) {
- $disk_env{$key} = $value;
- }
- untie(%disk_env);
}
return 'ok';
}
@@ -693,24 +705,38 @@ sub queryauthenticate {
# --------- Try to authenticate user from domain's lib servers (first this one)
sub authenticate {
- my ($uname,$upass,$udom)=@_;
+ my ($uname,$upass,$udom,$checkdefauth)=@_;
$upass=&escape($upass);
$uname= &LONCAPA::clean_username($uname);
my $uhome=&homeserver($uname,$udom,1);
+ my $newhome;
if ((!$uhome) || ($uhome eq 'no_host')) {
# Maybe the machine was offline and only re-appeared again recently?
&reconlonc();
# One more
- my $uhome=&homeserver($uname,$udom,1);
+ $uhome=&homeserver($uname,$udom,1);
+ if (($uhome eq 'no_host') && $checkdefauth) {
+ if (defined(&domain($udom,'primary'))) {
+ $newhome=&domain($udom,'primary');
+ }
+ if ($newhome ne '') {
+ $uhome = $newhome;
+ }
+ }
if ((!$uhome) || ($uhome eq 'no_host')) {
&logthis("User $uname at $udom is unknown in authenticate");
- }
- return 'no_host';
+ return 'no_host';
+ }
}
- my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome);
+ my $answer=reply("encrypt:auth:$udom:$uname:$upass:$checkdefauth",$uhome);
if ($answer eq 'authorized') {
- &logthis("User $uname at $udom authorized by $uhome");
- return $uhome;
+ if ($newhome) {
+ &logthis("User $uname at $udom authorized by $uhome, but needs account");
+ return 'no_account_on_host';
+ } else {
+ &logthis("User $uname at $udom authorized by $uhome");
+ return $uhome;
+ }
}
if ($answer eq 'non_authorized') {
&logthis("User $uname at $udom rejected by $uhome");
@@ -1183,7 +1209,7 @@ sub assign_access_key {
# key now belongs to user
my $envkey='key.'.$cdom.'_'.$cnum;
if (&put('environment',{$envkey => $ckey}) eq 'ok') {
- &appenv('environment.'.$envkey => $ckey);
+ &appenv({'environment.'.$envkey => $ckey});
return 'ok';
} else {
return
@@ -1667,12 +1693,21 @@ sub ssi_body {
if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) {
$form{'LONCAPA_INTERNAL_no_discussion'}='true';
}
- my $output=($filelink=~/^http\:/?&externalssi($filelink):
- &ssi($filelink,%form));
+ my $output='';
+ my $response;
+ if ($filelink=~/^http\:/) {
+ ($output,$response)=&externalssi($filelink);
+ } else {
+ ($output,$response)=&ssi($filelink,%form);
+ }
$output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs;
$output=~s/^.*?\<body[^\>]*\>//si;
$output=~s/\<\/body\s*\>.*?$//si;
- return $output;
+ if (wantarray) {
+ return ($output, $response);
+ } else {
+ return $output;
+ }
}
# --------------------------------------------------------- Server Side Include
@@ -1693,19 +1728,13 @@ sub absolute_url {
# form Hash that describes how the rendering should be done
# and other things.
# Returns:
-# Scalar context: The content of the reply.
-# Array context: 2 element list of the content and the full response variable.
+# Scalar context: The content of the response.
+# Array context: 2 element list of the content and the full response object.
#
-# Returns:
-# The content of the response.
sub ssi {
my ($fn,%form)=@_;
- my $count = scalar(@_);
-
-
my $ua=new LWP::UserAgent;
-
my $request;
$form{'no_update_last_known'}=1;
@@ -1719,7 +1748,6 @@ sub ssi {
$request->header(Cookie => $ENV{'HTTP_COOKIE'});
my $response=$ua->request($request);
- my $status = $response->code;
if (wantarray) {
return ($response->content, $response);
@@ -1733,7 +1761,11 @@ sub externalssi {
my $ua=new LWP::UserAgent;
my $request=new HTTP::Request('GET',$url);
my $response=$ua->request($request);
- return $response->content;
+ if (wantarray) {
+ return ($response->content, $response);
+ } else {
+ return $response->content;
+ }
}
# -------------------------------- Allow a /uploaded/ URI to be vouched for
@@ -1746,7 +1778,7 @@ sub allowuploaded {
my %httpref=();
my $httpurl=&hreflocation('',$url);
$httpref{'httpref.'.$httpurl}=$srcurl;
- &Apache::lonnet::appenv(%httpref);
+ &Apache::lonnet::appenv(\%httpref);
}
# --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
@@ -2449,7 +2481,7 @@ sub userrolelog {
}
sub get_course_adv_roles {
- my $cid=shift;
+ my ($cid,$codes) = @_;
$cid=$env{'request.course.id'} unless (defined($cid));
my %coursehash=&coursedescription($cid);
my %nothide=();
@@ -2474,14 +2506,23 @@ sub get_course_adv_roles {
if ((&privileged($username,$domain)) &&
(!$nothide{$username.':'.$domain})) { next; }
if ($role eq 'cr') { next; }
- my $key=&plaintext($role);
- if ($section) { $key.=' (Sec/Grp '.$section.')'; }
- if ($returnhash{$key}) {
- $returnhash{$key}.=','.$username.':'.$domain;
+ if ($codes) {
+ if ($section) { $role .= ':'.$section; }
+ if ($returnhash{$role}) {
+ $returnhash{$role}.=','.$username.':'.$domain;
+ } else {
+ $returnhash{$role}=$username.':'.$domain;
+ }
} else {
- $returnhash{$key}=$username.':'.$domain;
+ my $key=&plaintext($role);
+ if ($section) { $key.=' (Section '.$section.')'; }
+ if ($returnhash{$key}) {
+ $returnhash{$key}.=','.$username.':'.$domain;
+ } else {
+ $returnhash{$key}=$username.':'.$domain;
+ }
}
- }
+ }
return %returnhash;
}
@@ -2643,7 +2684,8 @@ sub courseidput {
sub courseiddump {
my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
- $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;
+ $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
+ $selfenrollonly)=@_;
my $as_hash = 1;
my %returnhash;
if (!$domfilter) { $domfilter=''; }
@@ -2660,7 +2702,8 @@ sub courseiddump {
$sincefilter.':'.&escape($descfilter).':'.
&escape($instcodefilter).':'.&escape($ownerfilter).
':'.&escape($coursefilter).':'.&escape($typefilter).
- ':'.&escape($regexp_ok).':'.$as_hash,$tryserver);
+ ':'.&escape($regexp_ok).':'.$as_hash.':'.
+ &escape($selfenrollonly),$tryserver);
my @pairs=split(/\&/,$rep);
foreach my $item (@pairs) {
my ($key,$value)=split(/\=/,$item,2);
@@ -3397,7 +3440,7 @@ sub coursedescription {
}
}
if (!$args->{'one_time'}) {
- &appenv(%envhash);
+ &appenv(\%envhash);
}
return %returnhash;
}
@@ -3946,6 +3989,7 @@ sub tmpget {
my %returnhash;
foreach my $item (split(/\&/,$rep)) {
my ($key,$value)=split(/=/,$item);
+ next if ($key =~ /^error: 2 /);
$returnhash{&unescape($key)}=&thaw_unescape($value);
}
return %returnhash;
@@ -5312,7 +5356,7 @@ sub plaintext {
# ----------------------------------------------------------------- Assign Role
sub assignrole {
- my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_;
+ my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll)=@_;
my $mrole;
if ($role =~ /^cr\//) {
my $cwosec=$url;
@@ -5346,11 +5390,15 @@ sub assignrole {
} else {
$refused = 1;
}
- if ($refused) {
- &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
- ' '.$role.' '.$end.' '.$start.' by '.
- $env{'user.name'}.' at '.$env{'user.domain'});
- return 'refused';
+ if ($refused) {
+ if (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
+ $refused = '';
+ } else {
+ &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
+ ' '.$role.' '.$end.' '.$start.' by '.
+ $env{'user.name'}.' at '.$env{'user.domain'});
+ return 'refused';
+ }
}
}
$mrole=$role;
@@ -5544,7 +5592,7 @@ sub modifystudent {
}
sub modify_student_enrollment {
- my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_;
+ my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll) = @_;
my ($cdom,$cnum,$chome);
if (!$cid) {
unless ($cid=$env{'request.course.id'}) {
@@ -5602,7 +5650,7 @@ sub modify_student_enrollment {
if ($usec) {
$uurl.='/'.$usec;
}
- return &assignrole($udom,$uname,$uurl,'st',$end,$start);
+ return &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,$selfenroll);
}
sub format_name {
@@ -5721,7 +5769,7 @@ ENDINITMAP
sub is_course {
my ($cdom,$cnum) = @_;
my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,
- undef,'.',undef,1);
+ undef,'.');
if (exists($courses{$cdom.'_'.$cnum})) {
return 1;
}
@@ -5755,9 +5803,17 @@ sub revokecustomrole {
# ------------------------------------------------------------ Disk usage
sub diskusage {
- my ($udom,$uname,$directoryRoot)=@_;
- $directoryRoot =~ s/\/$//;
- my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom));
+ my ($udom,$uname,$directorypath,$getpropath)=@_;
+ $directorypath =~ s/\/$//;
+ my $listing=&reply('du2:'.&escape($directorypath).':'
+ .&escape($getpropath).':'.&escape($uname).':'
+ .&escape($udom),homeserver($uname,$udom));
+ if ($listing eq 'unknown_cmd') {
+ if ($getpropath) {
+ $directorypath = &propath($udom,$uname).'/'.$directorypath;
+ }
+ $listing = &reply('du:'.$directorypath,homeserver($uname,$udom));
+ }
return $listing;
}
@@ -6174,30 +6230,49 @@ sub unmark_as_readonly {
# ------------------------------------------------------------ Directory lister
sub dirlist {
- my ($uri,$userdomain,$username,$alternateDirectoryRoot)=@_;
-
+ my ($uri,$userdomain,$username,$getpropath,$getuserdir,$alternateRoot)=@_;
$uri=~s/^\///;
$uri=~s/\/$//;
my ($udom, $uname);
- (undef,$udom,$uname)=split(/\//,$uri);
- if(defined($userdomain)) {
+ if ($getuserdir) {
$udom = $userdomain;
- }
- if(defined($username)) {
$uname = $username;
+ } else {
+ (undef,$udom,$uname)=split(/\//,$uri);
+ if(defined($userdomain)) {
+ $udom = $userdomain;
+ }
+ if(defined($username)) {
+ $uname = $username;
+ }
}
+ my ($dirRoot,$listing,@listing_results);
- my $dirRoot = $perlvar{'lonDocRoot'};
- if(defined($alternateDirectoryRoot)) {
- $dirRoot = $alternateDirectoryRoot;
+ $dirRoot = $perlvar{'lonDocRoot'};
+ if (defined($getpropath)) {
+ $dirRoot = &propath($udom,$uname);
$dirRoot =~ s/\/$//;
+ } elsif (defined($getuserdir)) {
+ my $subdir=$uname.'__';
+ $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
+ $dirRoot = $Apache::lonnet::perlvar{'lonUsersDir'}
+ ."/$udom/$subdir/$uname";
+ } elsif (defined($alternateRoot)) {
+ $dirRoot = $alternateRoot;
}
if($udom) {
if($uname) {
- my $listing = &reply('ls2:'.$dirRoot.'/'.$uri,
- &homeserver($uname,$udom));
- my @listing_results;
+ $listing = &reply('ls3:'.&escape('/'.$uri).':'.$getpropath.':'
+ .$getuserdir.':'.&escape($alternateRoot)
+ .':'.&escape($uname).':'.&escape($udom),
+ &homeserver($uname,$udom));
+ if ($listing eq 'unknown_cmd') {
+ $listing = &reply('ls2:'.$dirRoot.'/'.$uri,
+ &homeserver($uname,$udom));
+ } else {
+ @listing_results = map { &unescape($_); } split(/:/,$listing);
+ }
if ($listing eq 'unknown_cmd') {
$listing = &reply('ls:'.$dirRoot.'/'.$uri,
&homeserver($uname,$udom));
@@ -6206,13 +6281,18 @@ sub dirlist {
@listing_results = map { &unescape($_); } split(/:/,$listing);
}
return @listing_results;
- } elsif(!defined($alternateDirectoryRoot)) {
+ } elsif(!$alternateRoot) {
my %allusers;
my %servers = &get_servers($udom,'library');
- foreach my $tryserver (keys(%servers)) {
- my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.
- $udom, $tryserver);
- my @listing_results;
+ foreach my $tryserver (keys(%servers)) {
+ $listing = &reply('ls3:'.&escape("/res/$udom").':::::'.
+ &escape($udom),$tryserver);
+ if ($listing eq 'unknown_cmd') {
+ $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.
+ $udom, $tryserver);
+ } else {
+ @listing_results = map { &unescape($_); } split(/:/,$listing);
+ }
if ($listing eq 'unknown_cmd') {
$listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.
$udom, $tryserver);
@@ -6239,13 +6319,13 @@ sub dirlist {
} else {
return ('missing user name');
}
- } elsif(!defined($alternateDirectoryRoot)) {
+ } elsif(!defined($getpropath)) {
my @all_domains = sort(&all_domains());
- foreach my $domain (@all_domains) {
- $domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain';
- }
- return @all_domains;
- } else {
+ foreach my $domain (@all_domains) {
+ $domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain';
+ }
+ return @all_domains;
+ } else {
return ('missing domain');
}
}
@@ -6255,23 +6335,13 @@ sub dirlist {
# when it was last modified. It will also return an error of -1
# if an error occurs
-##
-## FIXME: This subroutine assumes its caller knows something about the
-## directory structure of the home server for the student ($root).
-## Not a good assumption to make. Since this is for looking up files
-## in user directories, the full path should be constructed by lond, not
-## whatever machine we request data from.
-##
sub GetFileTimestamp {
- my ($studentDomain,$studentName,$filename,$root)=@_;
+ my ($studentDomain,$studentName,$filename,$getuserdir)=@_;
$studentDomain = &LONCAPA::clean_domain($studentDomain);
$studentName = &LONCAPA::clean_username($studentName);
- my $subdir=$studentName.'__';
- $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
- my $proname="$studentDomain/$subdir/$studentName";
- $proname .= '/'.$filename;
- my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain,
- $studentName, $root);
+ my ($fileStat) =
+ &Apache::lonnet::dirlist($filename,$studentDomain,$studentName,
+ undef,$getuserdir);
my @stats = split('&', $fileStat);
if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
# @stats contains first the filename, then the stat output
@@ -6285,12 +6355,11 @@ sub stat_file {
my ($uri) = @_;
$uri = &clutter_with_no_wrapper($uri);
- my ($udom,$uname,$file,$dir);
+ my ($udom,$uname,$file);
if ($uri =~ m-^/(uploaded|editupload)/-) {
($udom,$uname,$file) =
($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-);
$file = 'userfiles/'.$file;
- $dir = &propath($udom,$uname);
}
if ($uri =~ m-^/res/-) {
($udom,$uname) =
@@ -6303,7 +6372,8 @@ sub stat_file {
return ();
}
- my ($result) = &dirlist($file,$udom,$uname,$dir);
+ my $getpropath = 1;
+ my ($result) = &dirlist($file,$udom,$uname,$getpropath);
my @stats = split('&', $result);
if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
@@ -6336,7 +6406,7 @@ sub directcondval {
untie(%bighash);
}
my $value = &docondval($sub_condition);
- &appenv('user.state.'.$env{'request.course.id'}.".$number" => $value);
+ &appenv({'user.state.'.$env{'request.course.id'}.".$number" => $value});
return $value;
}
if ($env{'user.state.'.$env{'request.course.id'}}) {
@@ -6522,7 +6592,7 @@ sub EXT_cache_status {
sub EXT_cache_set {
my ($target_domain,$target_user) = @_;
my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
- #&appenv($cachename => time);
+ #&appenv({$cachename => time});
}
# --------------------------------------------------------- Value of a Variable
@@ -7424,7 +7494,7 @@ sub symbread {
if ($syval) {
#unless ($syval=~/\_\d+$/) {
#unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) {
- #&appenv('request.ambiguous' => $thisfn);
+ #&appenv({'request.ambiguous' => $thisfn});
#return $env{$cache_str}='';
#}
#$syval.=$1;
@@ -7476,7 +7546,7 @@ sub symbread {
return $env{$cache_str}=$syval;
}
}
- &appenv('request.ambiguous' => $thisfn);
+ &appenv({'request.ambiguous' => $thisfn});
return $env{$cache_str}='';
}
@@ -7990,7 +8060,7 @@ sub tokenwrapper {
my (undef,$udom,$uname,$file)=split('/',$uri,4);
if ($udom && $uname && $file) {
$file=~s|(\?\.*)*$||;
- &appenv("userfile.$udom/$uname/$file" => $env{'request.course.id'});
+ &appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}});
return 'http://'.&hostname(&homeserver($uname,$udom)).'/'.$uri.
(($uri=~/\?/)?'&':'?').'token='.$token.
'&tokenissued='.$perlvar{'lonHostID'};
@@ -8056,8 +8126,7 @@ sub filelocation {
my @ids=¤t_machine_ids();
foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
if ($is_me) {
- $location=&propath($udom,$uname).
- '/userfiles/'.$filename;
+ $location=&propath($udom,$uname).'/userfiles/'.$filename;
} else {
$location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
$udom.'/'.$uname.'/'.$filename;
@@ -8835,10 +8904,12 @@ that was requested
=item *
X<appenv()>
-B<appenv(%hash)>: the value of %hash is written to
+B<appenv($hashref,$rolesarrayref)>: the value of %{$hashref} is written to
the user envirnoment file, and will be restored for each access this
user makes during this session, also modifies the %env for the current
-process
+process. Optional rolesarrayref - if defined contains a reference to an array
+of roles which are exempt from the restriction on modifying user.role entries
+in the user's environment.db and in %env.
=item *
X<delenv()>