--- 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=&current_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()>