--- loncom/lonnet/perl/lonnet.pm 2008/03/09 17:22:21 1.947 +++ loncom/lonnet/perl/lonnet.pm 2008/03/28 14:52:57 1.953 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.947 2008/03/09 17:22:21 raeburn Exp $ +# $Id: lonnet.pm,v 1.953 2008/03/28 14:52:57 www 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("WARNING: ". - "Attempt to modify environment ".$key." to ".$newenv{$key} - .''); - 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("WARNING: ". + "Attempt to modify environment ".$key." to ".$newenv->{$key} + .''); + 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=&externalssi($filelink); + } else { + ($output,$response)=&ssi($filelink,%form); + } $output=~s|//(\s*)?\s||gs; $output=~s/^.*?\]*\>//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); @@ -1746,7 +1774,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 +2477,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 +2502,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; } @@ -3399,7 +3436,7 @@ sub coursedescription { } } if (!$args->{'one_time'}) { - &appenv(%envhash); + &appenv(\%envhash); } return %returnhash; } @@ -3948,6 +3985,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; @@ -6342,7 +6380,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'}}) { @@ -6528,7 +6566,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 @@ -7430,7 +7468,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; @@ -7482,7 +7520,7 @@ sub symbread { return $env{$cache_str}=$syval; } } - &appenv('request.ambiguous' => $thisfn); + &appenv({'request.ambiguous' => $thisfn}); return $env{$cache_str}=''; } @@ -7996,7 +8034,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'}; @@ -8841,10 +8879,12 @@ that was requested =item * X -B: the value of %hash is written to +B: 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