loncom/lonnet/perl/lonnet.pm - diff

Return to lonnet.pm CVS log

Up to [LON-CAPA] / loncom / lonnet / perl

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.921 and 1.1056.4.6

-version 1.921, 2007/10/06 04:32:40
+version 1.1056.4.6, 2010/08/17 01:49:04
  Line 27
  #
  ###
+ =pod
+ =head1 NAME
+ Apache::lonnet.pm
+ =head1 SYNOPSIS
+ This file is an interface to the lonc processes of
+ the LON-CAPA network as well as set of elaborated functions for handling information
+ necessary for navigating through a given cluster of LON-CAPA machines within a
+ domain. There are over 40 specialized functions in this module which handle the
+ reading and transmission of metadata, user information (ids, names, environments, roles,
+ logs), file information (storage, reading, directories, extensions, replication, embedded
+ styles and descriptors), educational resources (course descriptions, section names and
+ numbers), url hashing (to assign roles on a url basis), and translating abbreviated symbols to
+ and from more descriptive phrases or explanations.
+ This is part of the LearningOnline Network with CAPA project
+ described at http://www.lon-capa.org.
+ =head1 Package Variables
+ These are largely undocumented, so if you decipher one please note it here.
+ =over 4
+ =item $processmarker
+ Contains the time this process was started and this servers host id.
+ =item $dumpcount
+ Counts the number of times a message log flush has been attempted (regardless
+ of success) by this process.  Used as part of the filename when messages are
+ delayed.
+ =back
+ =cut
  package Apache::lonnet;
  use strict;
  use LWP::UserAgent();
  use HTTP::Date;
- # use Date::Parse;
+ use Image::Magick;
  use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
-             $_64bit %env);
+             $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease);
  my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
      %userrolehash, $processmarker, $dumpcount, %coursedombuf,
      %coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf,
-     %courseownerbuf, %coursetypebuf);
+     %courseownerbuf, %coursetypebuf,$locknum);
  use IO::Socket;
  use GDBM_File;
- Line 50  use Time::HiRes qw( gettimeofday tv_inte
+ Line 92  use Time::HiRes qw( gettimeofday tv_inte
  use Cache::Memcached;
  use Digest::MD5;
  use Math::Random;
+ use File::MMagic;
  use LONCAPA qw(:DEFAULT :match);
  use LONCAPA::Configuration;
- Line 61  require Exporter;
+ Line 104  require Exporter;
  our @ISA = qw (Exporter);
  our @EXPORT = qw(%env);
- =pod
- =head1 Package Variables
- These are largely undocumented, so if you decipher one please note it here.
- =over 4
- =item $processmarker
- Contains the time this process was started and this servers host id.
- =item $dumpcount
- Counts the number of times a message log flush has been attempted (regardless
- of success) by this process.  Used as part of the filename when messages are
- delayed.
- =back
- =cut
  # --------------------------------------------------------------------- Logging
  {
      my $logid;
      sub instructor_log {
- 	my ($hash_name,$storehash,$delflag,$uname,$udom)=@_;
+ 	my ($hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_;
+         if (($cnum eq '') || ($cdom eq '')) {
+             $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
+             $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
+         }
  	$logid++;
- 	my $id=time().'00000'.$$.'00000'.$logid;
+         my $now = time();
+ 	my $id=$now.'00000'.$$.'00000'.$logid;
  	return &Apache::lonnet::put('nohist_'.$hash_name,
  				    { $id => {
  					'exe_uname' => $env{'user.name'},
  					'exe_udom'  => $env{'user.domain'},
- 					'exe_time'  => time(),
+ 					'exe_time'  => $now,
  					'exe_ip'    => $ENV{'REMOTE_ADDR'},
  					'delflag'   => $delflag,
  					'logentry'  => $storehash,
  					'uname'     => $uname,
  					'udom'      => $udom,
  				    }
- 				  },
+ 				  },$cdom,$cnum);
- 				    $env{'course.'.$env{'request.course.id'}.'.domain'},
- 				    $env{'course.'.$env{'request.course.id'}.'.num'}
- 				    );
      }
  }
- Line 125  sub logthis {
+ Line 148  sub logthis {
      my $now=time;
      my $local=localtime($now);
      if (open(my $fh,">>$execdir/logs/lonnet.log")) {
- 	print $fh "$local ($$): $message\n";
+ 	my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string.
+ 	print $fh $logstring;
  	close($fh);
      }
      return 1;
- Line 156  sub create_connection {
+ Line 180  sub create_connection {
      return 0;
  }
+ sub get_server_timezone {
+     my ($cnum,$cdom) = @_;
+     my $home=&homeserver($cnum,$cdom);
+     if ($home ne 'no_host') {
+         my $cachetime = 24*3600;
+         my ($timezone,$cached)=&is_cached_new('servertimezone',$home);
+         if (defined($cached)) {
+             return $timezone;
+         } else {
+             my $timezone = &reply('servertimezone',$home);
+             return &do_cache_new('servertimezone',$home,$timezone,$cachetime);
+         }
+     }
+ }
+ sub get_server_loncaparev {
+     my ($dom,$lonhost,$ignore_cache,$caller) = @_;
+     if (defined($lonhost)) {
+         if (!defined(&hostname($lonhost))) {
+             undef($lonhost);
+         }
+     }
+     if (!defined($lonhost)) {
+         if (defined(&domain($dom,'primary'))) {
+             $lonhost=&domain($dom,'primary');
+             if ($lonhost eq 'no_host') {
+                 undef($lonhost);
+             }
+         }
+     }
+     if (defined($lonhost)) {
+         my $cachetime = 12*3600;
+         if (!$ignore_cache) {
+             my ($loncaparev,$cached)=&is_cached_new('serverloncaparev',$lonhost);
+             if (defined($cached)) {
+                 return $loncaparev;
+             }
+         }
+         my ($answer,$loncaparev);
+         my @ids=&current_machine_ids();
+         if (grep(/^\Q$lonhost\E$/,@ids)) {
+             $answer = $perlvar{'lonVersion'};
+             if ($answer =~ /^[\'\"]?([\d.\-]+)[\'\"]?$/) {
+                 $loncaparev = $1;
+             }
+         } else {
+             $answer = &reply('serverloncaparev',$lonhost);
+             if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) {
+                 if ($caller eq 'loncron') {
+                     my $ua=new LWP::UserAgent;
+                     $ua->timeout(20);
+                     my $protocol = $protocol{$lonhost};
+                     $protocol = 'http' if ($protocol ne 'https');
+                     my $url = $protocol.'://'.&hostname($lonhost).'/adm/about.html';
+                     my $request=new HTTP::Request('GET',$url);
+                     my $response=$ua->request($request);
+                     unless ($response->is_error()) {
+                         my $content = $response->content;
+                         if ($content =~ /<p>VERSION\:\s*([\d.\-]+)<\/p>/) {
+                             $loncaparev = $1;
+                         }
+                     }
+                 } else {
+                     $loncaparev = $loncaparevs{$lonhost};
+                 }
+             } elsif ($answer =~ /^[\'\"]?([\d.\-]+)[\'\"]?$/) {
+                 $loncaparev = $1;
+             }
+         }
+         return &do_cache_new('serverloncaparev',$lonhost,$loncaparev,$cachetime);
+     }
+ }
+ sub get_server_homeID {
+     my ($hostname,$ignore_cache,$caller) = @_;
+     unless ($ignore_cache) {
+         my ($serverhomeID,$cached)=&is_cached_new('serverhomeID',$hostname);
+         if (defined($cached)) {
+             return $serverhomeID;
+         }
+     }
+     my $cachetime = 12*3600;
+     my $serverhomeID;
+     if ($caller eq 'loncron') {
+         my @machine_ids = &machine_ids($hostname);
+         foreach my $id (@machine_ids) {
+             my $response = &reply('serverhomeID',$id);
+             unless (($response eq 'unknown_cmd') || ($response eq 'con_lost')) {
+                 $serverhomeID = $response;
+                 last;
+             }
+         }
+         if ($serverhomeID eq '') {
+             $serverhomeID = $machine_ids[-1];
+         }
+     } else {
+         $serverhomeID = $serverhomeIDs{$hostname};
+     }
+     return &do_cache_new('serverhomeID',$hostname,$serverhomeID,$cachetime);
+ }
  # -------------------------------------------------- Non-critical communication
  sub subreply {
- Line 448  sub timed_flock {
+ Line 572  sub timed_flock {
  # ---------------------------------------------------------- Append Environment
  sub appenv {
-     my %newenv=@_;
+     my ($newenv,$roles) = @_;
-     foreach my $key (keys(%newenv)) {
+     if (ref($newenv) eq 'HASH') {
- 	if (($newenv{$key}=~/^user\.role/) || ($newenv{$key}=~/^user\.priv/)) {
+         foreach my $key (keys(%{$newenv})) {
-             &logthis("<font color=\"blue\">WARNING: ".
+             my $refused = 0;
-                 "Attempt to modify environment ".$key." to ".$newenv{$key}
+ 	    if (($key =~ /^user\.role/) || ($key =~ /^user\.priv/)) {
-                 .'</font>');
+                 $refused = 1;
- 	    delete($newenv{$key});
+                 if (ref($roles) eq 'ARRAY') {
-         } else {
+                     my ($type,$role) = ($key =~ /^user\.(role|priv)\.([^.]+)\./);
-             $env{$key}=$newenv{$key};
+                     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';
  }
  # ----------------------------------------------------- Delete from Environment
  sub delenv {
-     my $delthis=shift;
+     my ($delthis,$regexp) = @_;
      if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
          &logthis("<font color=\"blue\">WARNING: ".
                  "Attempt to delete from environment ".$delthis);
- Line 488  sub delenv {
+ Line 624  sub delenv {
  	tie(my %disk_env,'GDBM_File',$env{'user.environment'},
  	    (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
  	foreach my $key (keys(%disk_env)) {
- 	    if ($key=~/^$delthis/) {
+ 	    if ($regexp) {
- 		delete($env{$key});
+                 if ($key=~/^$delthis/) {
- 		delete($disk_env{$key});
+                     delete($env{$key});
- 	    }
+                     delete($disk_env{$key});
+                 }
+             } else {
+                 if ($key=~/^\Q$delthis\E/) {
+ 		    delete($env{$key});
+ 		    delete($disk_env{$key});
+ 	        }
+             }
  	}
  	untie(%disk_env);
      }
- Line 512  sub get_env_multiple {
+ Line 655  sub get_env_multiple {
      return(@values);
  }
+ # ------------------------------------------------------------------- Locking
+ sub set_lock {
+     my ($text)=@_;
+     $locknum++;
+     my $id=$$.'-'.$locknum;
+     &appenv({'session.locks' => $env{'session.locks'}.','.$id,
+              'session.lock.'.$id => $text});
+     return $id;
+ }
+ sub get_locks {
+     my $num=0;
+     my %texts=();
+     foreach my $lock (split(/\,/,$env{'session.locks'})) {
+        if ($lock=~/\w/) {
+           $num++;
+           $texts{$lock}=$env{'session.lock.'.$lock};
+        }
+    }
+    return ($num,%texts);
+ }
+ sub remove_lock {
+     my ($id)=@_;
+     my $newlocks='';
+     foreach my $lock (split(/\,/,$env{'session.locks'})) {
+        if (($lock=~/\w/) && ($lock ne $id)) {
+           $newlocks.=','.$lock;
+        }
+     }
+     &appenv({'session.locks' => $newlocks});
+     &delenv('session.lock.'.$id);
+ }
+ sub remove_all_locks {
+     my $activelocks=$env{'session.locks'};
+     foreach my $lock (split(/\,/,$env{'session.locks'})) {
+        if ($lock=~/\w/) {
+           &remove_lock($lock);
+        }
+     }
+ }
  # ------------------------------------------ Find out current server userload
- # there is a copy in lond
  sub userload {
      my $numusers=0;
      {
- Line 521  sub userload {
+ Line 708  sub userload {
  	my $filename;
  	my $curtime=time;
  	while ($filename=readdir(LONIDS)) {
- 	    if ($filename eq '.' || $filename eq '..') {next;}
+ 	    next if ($filename eq '.' || $filename eq '..');
+ 	    next if ($filename =~ /publicuser_\d+\.id/);
  	    my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
  	    if ($curtime-$mtime < 1800) { $numusers++; }
  	}
- Line 584  sub spareserver {
+ Line 772  sub spareserver {
      }
      if (!$want_server_name) {
- 	$spare_server="http://".&hostname($spare_server);
+         my $protocol = 'http';
+         if ($protocol{$spare_server} eq 'https') {
+             $protocol = $protocol{$spare_server};
+         }
+         if (defined($spare_server)) {
+             my $hostname = &hostname($spare_server);
+             if (defined($hostname)) {
+ 	        $spare_server = $protocol.'://'.$hostname;
+             }
+         }
      }
      return $spare_server;
  }
- Line 596  sub compare_server_load {
+ Line 793  sub compare_server_load {
      my $userloadans = &reply('userload',$try_server);
      if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
- 	next; #didn't get a number from the server
+         return; #didn't get a number from the server
      }
      my $load;
- Line 639  sub has_user_session {
+ Line 836  sub has_user_session {
      return 0;
  }
+ # --------- determine least loaded server in a user's domain which allows login
+ sub choose_server {
+     my ($udom) = @_;
+     my %domconfhash = &Apache::loncommon::get_domainconf($udom);
+     my %servers = &get_servers($udom);
+     my $lowest_load = 30000;
+     my ($login_host,$hostname);
+     foreach my $lonhost (keys(%servers)) {
+         my $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};
+         if ($loginvia eq '') {
+             ($login_host, $lowest_load) =
+             &compare_server_load($lonhost, $login_host, $lowest_load);
+         }
+     }
+     if ($login_host ne '') {
+         $hostname = $servers{$login_host};
+     }
+     return ($login_host,$hostname);
+ }
  # --------------------------------------------- Try to change a user's password
  sub changepass {
      my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_;
      $currentpass = &escape($currentpass);
      $newpass     = &escape($newpass);
-     my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context",
+     my $lonhost = $perlvar{'lonHostID'};
+     my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context:$lonhost",
  		       $server);
      if (! $answer) {
  	&logthis("No reply on password change request to $server ".
- Line 670  sub changepass {
+ Line 889  sub changepass {
      } elsif ($answer =~ "^refused") {
  	&logthis("$server refused to change $uname in $udom password because ".
  		 "it was sent an unencrypted request to change the password.");
+     } elsif ($answer =~ "invalid_client") {
+         &logthis("$server refused to change $uname in $udom password because ".
+                  "it was a reset by e-mail originating from an invalid server.");
      }
      return $answer;
  }
- Line 693  sub queryauthenticate {
+ Line 915  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,$clientcancheckhost)=@_;
      $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:$clientcancheckhost",$uhome);
      if ($answer eq 'authorized') {
- 	&logthis("User $uname at $udom authorized by $uhome");
+         if ($newhome) {
- 	return $uhome;
+             &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");
- Line 720  sub authenticate {
+ Line 956  sub authenticate {
      return 'no_host';
  }
+ sub can_host_session {
+     my ($udom,$lonhost,$remoterev,$remotesessions,$hostedsessions) = @_;
+     my $canhost = 1;
+     my $host_idn = &Apache::lonnet::internet_dom($lonhost);
+     if (ref($remotesessions) eq 'HASH') {
+         if (ref($remotesessions->{'excludedomain'}) eq 'ARRAY') {
+             if (grep(/^\Q$host_idn\E$/,@{$remotesessions->{'excludedomain'}})) {
+                 $canhost = 0;
+             } else {
+                 $canhost = 1;
+             }
+         }
+         if (ref($remotesessions->{'includedomain'}) eq 'ARRAY') {
+             if (grep(/^\Q$host_idn\E$/,@{$remotesessions->{'includedomain'}})) {
+                 $canhost = 1;
+             } else {
+                 $canhost = 0;
+             }
+         }
+         if ($canhost) {
+             if ($remotesessions->{'version'} ne '') {
+                 my ($reqmajor,$reqminor) = ($remotesessions->{'version'} =~ /^(\d+)\.(\d+)$/);
+                 if ($reqmajor ne '' && $reqminor ne '') {
+                     if ($remoterev =~ /^\'?(\d+)\.(\d+)/) {
+                         my $major = $1;
+                         my $minor = $2;
+                         if (($major < $reqmajor ) ||
+                             (($major == $reqmajor) && ($minor < $reqminor))) {
+                             $canhost = 0;
+                         }
+                     } else {
+                         $canhost = 0;
+                     }
+                 }
+             }
+         }
+     }
+     if ($canhost) {
+         if (ref($hostedsessions) eq 'HASH') {
+             if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') {
+                 if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'excludedomain'}})) {
+                     $canhost = 0;
+                 } else {
+                     $canhost = 1;
+                 }
+             }
+             if (ref($hostedsessions->{'includedomain'}) eq 'ARRAY') {
+                 if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'includedomain'}})) {
+                     $canhost = 1;
+                 } else {
+                     $canhost = 0;
+                 }
+             }
+         }
+     }
+     return $canhost;
+ }
  # ---------------------- Find the homebase for a user from domain's lib servers
  my %homecache;
- Line 805  sub idput {
+ Line 1099  sub idput {
      }
  }
- # ------------------------------------------- get items from domain db files
+ # ------------------------------dump from db file owned by domainconfig user
+ sub dump_dom {
+     my ($namespace,$udom,$regexp,$range)=@_;
+     if (!$udom) {
+         $udom=$env{'user.domain'};
+     }
+     my %returnhash;
+     if ($udom) {
+         my $uname = &get_domainconfiguser($udom);
+         %returnhash = &dump($namespace,$udom,$uname,$regexp,$range);
+     }
+     return %returnhash;
+ }
+ # ------------------------------------------ get items from domain db files
  sub get_dom {
      my ($namespace,$storearr,$udom,$uhome)=@_;
- Line 879  sub put_dom {
+ Line 1187  sub put_dom {
      }
  }
+ # --------------------- newput for items in db file owned by domainconfig user
+ sub newput_dom {
+     my ($namespace,$storehash,$udom) = @_;
+     my $result;
+     if (!$udom) {
+         $udom=$env{'user.domain'};
+     }
+     if ($udom) {
+         my $uname = &get_domainconfiguser($udom);
+         $result = &newput($namespace,$storehash,$udom,$uname);
+     }
+     return $result;
+ }
+ # --------------------- delete for items in db file owned by domainconfig user
+ sub del_dom {
+     my ($namespace,$storearr,$udom)=@_;
+     if (ref($storearr) eq 'ARRAY') {
+         if (!$udom) {
+             $udom=$env{'user.domain'};
+         }
+         if ($udom) {
+             my $uname = &get_domainconfiguser($udom);
+             return &del($namespace,$storearr,$udom,$uname);
+         }
+     }
+ }
+ # ----------------------------------construct domainconfig user for a domain
+ sub get_domainconfiguser {
+     my ($udom) = @_;
+     return $udom.'-domainconfig';
+ }
  sub retrieve_inst_usertypes {
      my ($udom) = @_;
      my (%returnhash,@order);
-     if (defined(&domain($udom,'primary'))) {
+     my %domdefs = &Apache::lonnet::get_domain_defaults($udom);
-         my $uhome=&domain($udom,'primary');
+     if ((ref($domdefs{'inststatustypes'}) eq 'HASH') &&
-         my $rep=&reply("inst_usertypes:$udom",$uhome);
+         (ref($domdefs{'inststatusorder'}) eq 'ARRAY')) {
-         my ($hashitems,$orderitems) = split(/:/,$rep);
+         %returnhash = %{$domdefs{'inststatustypes'}};
-         my @pairs=split(/\&/,$hashitems);
+         @order = @{$domdefs{'inststatusorder'}};
-         foreach my $item (@pairs) {
-             my ($key,$value)=split(/=/,$item,2);
-             $key = &unescape($key);
-             next if ($key =~ /^error: 2 /);
-             $returnhash{$key}=&thaw_unescape($value);
-         }
-         my @esc_order = split(/\&/,$orderitems);
-         foreach my $item (@esc_order) {
-             push(@order,&unescape($item));
-         }
      } else {
-         &logthis("get_dom failed - no primary domain server for $udom");
+         if (defined(&domain($udom,'primary'))) {
+             my $uhome=&domain($udom,'primary');
+             my $rep=&reply("inst_usertypes:$udom",$uhome);
+             if ($rep =~ /^(con_lost|error|no_such_host|refused)/) {
+                 &logthis("get_dom failed - $rep returned from $uhome in domain: $udom");
+                 return (\%returnhash,\@order);
+             }
+             my ($hashitems,$orderitems) = split(/:/,$rep);
+             my @pairs=split(/\&/,$hashitems);
+             foreach my $item (@pairs) {
+                 my ($key,$value)=split(/=/,$item,2);
+                 $key = &unescape($key);
+                 next if ($key =~ /^error: 2 /);
+                 $returnhash{$key}=&thaw_unescape($value);
+             }
+             my @esc_order = split(/\&/,$orderitems);
+             foreach my $item (@esc_order) {
+                 push(@order,&unescape($item));
+             }
+         } else {
+             &logthis("get_dom failed - no primary domain server for $udom");
+         }
      }
      return (\%returnhash,\@order);
  }
- Line 1047  sub get_instuser {
+ Line 1400  sub get_instuser {
  }
  sub inst_rulecheck {
-     my ($udom,$uname,$rules) = @_;
+     my ($udom,$uname,$id,$item,$rules) = @_;
      my %returnhash;
      if ($udom ne '') {
          if (ref($rules) eq 'ARRAY') {
- Line 1055  sub inst_rulecheck {
+ Line 1408  sub inst_rulecheck {
              my $rulestr = join(':',@{$rules});
              my $homeserver=&domain($udom,'primary');
              if (($homeserver ne '') && ($homeserver ne 'no_host')) {
-                 my $response=&unescape(&reply('instrulecheck:'.&escape($udom).':'.
+                 my $response;
-                                               &escape($uname).':'.$rulestr,
+                 if ($item eq 'username') {
+                     $response=&unescape(&reply('instrulecheck:'.&escape($udom).
+                                               ':'.&escape($uname).':'.$rulestr,
                                                $homeserver));
+                 } elsif ($item eq 'id') {
+                     $response=&unescape(&reply('instidrulecheck:'.&escape($udom).
+                                               ':'.&escape($id).':'.$rulestr,
+                                               $homeserver));
+                 } elsif ($item eq 'selfcreate') {
+                     $response=&unescape(&reply('instselfcreatecheck:'.
+                                                &escape($udom).':'.&escape($uname).
+                                               ':'.$rulestr,$homeserver));
+                 }
                  if ($response ne 'refused') {
                      my @pairs=split(/\&/,$response);
                      foreach my $item (@pairs) {
- Line 1074  sub inst_rulecheck {
+ Line 1438  sub inst_rulecheck {
  }
  sub inst_userrules {
-     my ($udom) = @_;
+     my ($udom,$check) = @_;
      my (%ruleshash,@ruleorder);
      if ($udom ne '') {
          my $homeserver=&domain($udom,'primary');
          if (($homeserver ne '') && ($homeserver ne 'no_host')) {
-             my $response=&reply('instuserrules:'.&escape($udom),
+             my $response;
+             if ($check eq 'id') {
+                 $response=&reply('instidrules:'.&escape($udom),
                                   $homeserver);
+             } elsif ($check eq 'email') {
+                 $response=&reply('instemailrules:'.&escape($udom),
+                                  $homeserver);
+             } else {
+                 $response=&reply('instuserrules:'.&escape($udom),
+                                  $homeserver);
+             }
              if (($response ne 'refused') && ($response ne 'error') &&
+                 ($response ne 'unknown_cmd') &&
                  ($response ne 'no_such_host')) {
                  my ($hashitems,$orderitems) = split(/:/,$response);
                  my @pairs=split(/\&/,$hashitems);
- Line 1101  sub inst_userrules {
+ Line 1475  sub inst_userrules {
      return (\%ruleshash,\@ruleorder);
  }
+ # ------------- Get Authentication, Language and User Tools Defaults for Domain
+ sub get_domain_defaults {
+     my ($domain) = @_;
+     my $cachetime = 60*60*24;
+     my ($result,$cached)=&is_cached_new('domdefaults',$domain);
+     if (defined($cached)) {
+         if (ref($result) eq 'HASH') {
+             return %{$result};
+         }
+     }
+     my %domdefaults;
+     my %domconfig =
+          &Apache::lonnet::get_dom('configuration',['defaults','quotas',
+                                   'requestcourses','inststatus',
+                                   'coursedefaults','usersessions'],$domain);
+     if (ref($domconfig{'defaults'}) eq 'HASH') {
+         $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};
+         $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
+         $domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'};
+         $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};
+         $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};
+     } else {
+         $domdefaults{'lang_def'} = &domain($domain,'lang_def');
+         $domdefaults{'auth_def'} = &domain($domain,'auth_def');
+         $domdefaults{'auth_arg_def'} = &domain($domain,'auth_arg_def');
+     }
+     if (ref($domconfig{'quotas'}) eq 'HASH') {
+         if (ref($domconfig{'quotas'}{'defaultquota'}) eq 'HASH') {
+             $domdefaults{'defaultquota'} = $domconfig{'quotas'}{'defaultquota'};
+         } else {
+             $domdefaults{'defaultquota'} = $domconfig{'quotas'};
+         }
+         my @usertools = ('aboutme','blog','portfolio');
+         foreach my $item (@usertools) {
+             if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {
+                 $domdefaults{$item} = $domconfig{'quotas'}{$item};
+             }
+         }
+     }
+     if (ref($domconfig{'requestcourses'}) eq 'HASH') {
+         foreach my $item ('official','unofficial','community') {
+             $domdefaults{$item} = $domconfig{'requestcourses'}{$item};
+         }
+     }
+     if (ref($domconfig{'inststatus'}) eq 'HASH') {
+         foreach my $item ('inststatustypes','inststatusorder') {
+             $domdefaults{$item} = $domconfig{'inststatus'}{$item};
+         }
+     }
+     if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
+         foreach my $item ('canuse_pdfforms') {
+             $domdefaults{$item} = $domconfig{'coursedefaults'}{$item};
+         }
+     }
+     if (ref($domconfig{'usersessions'}) eq 'HASH') {
+         if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') {
+             $domdefaults{'remotesessions'} = $domconfig{'usersessions'}{'remote'};
+         }
+         if (ref($domconfig{'usersessions'}{'hosted'}) eq 'HASH') {
+             $domdefaults{'hostedsessions'} = $domconfig{'usersessions'}{'hosted'};
+         }
+     }
+     &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,
+                                   $cachetime);
+     return %domdefaults;
+ }
  # --------------------------------------------------- Assign a key to a student
  sub assign_access_key {
- Line 1133  sub assign_access_key {
+ Line 1575  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
- Line 1420  sub purge_remembered {
+ Line 1862  sub purge_remembered {
  sub userenvironment {
      my ($udom,$unam,@what)=@_;
+     my $items;
+     foreach my $item (@what) {
+         $items.=&escape($item).'&';
+     }
+     $items=~s/\&$//;
      my %returnhash=();
-     my @answer=split(/\&/,
+     my $uhome = &homeserver($unam,$udom);
-                 &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what),
+     unless ($uhome eq 'no_host') {
-                       &homeserver($unam,$udom)));
+         my @answer=split(/\&/,
-     my $i;
+             &reply('get:'.$udom.':'.$unam.':environment:'.$items,$uhome));
-     for ($i=0;$i<=$#what;$i++) {
+         if ($#answer==0 && $answer[0] =~ /^(con_lost|error:|no_such_host)/i) {
- 	$returnhash{$what[$i]}=&unescape($answer[$i]);
+             return %returnhash;
+         }
+         my $i;
+         for ($i=0;$i<=$#what;$i++) {
+ 	    $returnhash{$what[$i]}=&unescape($answer[$i]);
+         }
      }
      return %returnhash;
  }
- Line 1617  sub ssi_body {
+ Line 2069  sub ssi_body {
      if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) {
          $form{'LONCAPA_INTERNAL_no_discussion'}='true';
      }
-     my $output=($filelink=~/^http\:/?&externalssi($filelink):
+     my $output='';
-                                      &ssi($filelink,%form));
+     my $response;
+     if ($filelink=~/^https?\:/) {
+        ($output,$response)=&externalssi($filelink);
+     } else {
+        $filelink .= $filelink=~/\?/ ? '&' : '?';
+        $filelink .= 'inhibitmenu=yes';
+        ($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*\>.*?$/$1/si;
+     $output=~s/\<\/body\s*\>.*?$//si;
-     return $output;
+     if (wantarray) {
+         return ($output, $response);
+     } else {
+         return $output;
+     }
  }
  # --------------------------------------------------------- Server Side Include
- Line 1636  sub absolute_url {
+ Line 2099  sub absolute_url {
      return $protocol.$host_name;
  }
+ #
+ #   Server side include.
+ # Parameters:
+ #  fn     Possibly encrypted resource name/id.
+ #  form   Hash that describes how the rendering should be done
+ #         and other things.
+ # Returns:
+ #   Scalar context: The content of the response.
+ #   Array context:  2 element list of the content and the full response object.
+ #
  sub ssi {
      my ($fn,%form)=@_;
      my $ua=new LWP::UserAgent;
      my $request;
      $form{'no_update_last_known'}=1;
      &Apache::lonenc::check_encrypt(\$fn);
      if (%form) {
        $request=new HTTP::Request('POST',&absolute_url().$fn);
-       $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));
+       $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys(%form)));
      } else {
        $request=new HTTP::Request('GET',&absolute_url().$fn);
      }
- Line 1656  sub ssi {
+ Line 2127  sub ssi {
      $request->header(Cookie => $ENV{'HTTP_COOKIE'});
      my $response=$ua->request($request);
-     return $response->content;
+     if (wantarray) {
+ 	return ($response->content, $response);
+     } else {
+ 	return $response->content;
+     }
  }
  sub externalssi {
- Line 1664  sub externalssi {
+ Line 2139  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
- Line 1677  sub allowuploaded {
+ Line 2156  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
- Line 1738  sub process_coursefile {
+ Line 2217  sub process_coursefile {
              print $fh $env{'form.'.$source};
              close($fh);
              if ($parser eq 'parse') {
-                 my $parse_result = &extract_embedded_items($filepath,$fname,$allfiles,$codebase);
+                 my $mm = new File::MMagic;
-                 unless ($parse_result eq 'ok') {
+                 my $mime_type = $mm->checktype_filename($filepath.'/'.$fname);
-                     &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);
+                 if ($mime_type eq 'text/html') {
+                     my $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase);
+                     unless ($parse_result eq 'ok') {
+                         &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);
+                     }
                  }
              }
              $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
- Line 1817  sub clean_filename {
+ Line 2300  sub clean_filename {
      $fname=~s/\.(\d+)(?=\.)/_$1/g;
      return $fname;
  }
+ # This Function checks if an Image's dimensions exceed either $resizewidth (width)
+ # or $resizeheight (height) - both pixels. If so, the image is scaled to produce an
+ # image with the same aspect ratio as the original, but with dimensions which do
+ # not exceed $resizewidth and $resizeheight.
+ sub resizeImage {
+     my ($img_path,$resizewidth,$resizeheight) = @_;
+     my $ima = Image::Magick->new;
+     my $resized;
+     if (-e $img_path) {
+         $ima->Read($img_path);
+         if (($resizewidth =~ /^\d+$/) && ($resizeheight > 0)) {
+             my $width = $ima->Get('width');
+             my $height = $ima->Get('height');
+             if ($width > $resizewidth) {
+ 	        my $factor = $width/$resizewidth;
+                 my $newheight = $height/$factor;
+                 $ima->Scale(width=>$resizewidth,height=>$newheight);
+                 $resized = 1;
+             }
+         }
+         if (($resizeheight =~ /^\d+$/) && ($resizeheight > 0)) {
+             my $width = $ima->Get('width');
+             my $height = $ima->Get('height');
+             if ($height > $resizeheight) {
+                 my $factor = $height/$resizeheight;
+                 my $newwidth = $width/$factor;
+                 $ima->Scale(width=>$newwidth,height=>$resizeheight);
+                 $resized = 1;
+             }
+         }
+         if ($resized) {
+             $ima->Write($img_path);
+         }
+     }
+     return;
+ }
  # --------------- Take an uploaded file and put it into the userfiles directory
  # input: $formname - the contents of the file are in $env{"form.$formname"}
- Line 1831  sub clean_filename {
+ Line 2351  sub clean_filename {
  #        $dsetudom - domain for permanaent storage of uploaded file
  #        $thumbwidth - width (pixels) of thumbnail to make for uploaded image
  #        $thumbheight - height (pixels) of thumbnail to make for uploaded image
+ #        $resizewidth - width (pixels) to which to resize uploaded image
+ #        $resizeheight - height (pixels) to which to resize uploaded image
  #
  # output: url of file in userspace, or error: <message>
  #             or /adm/notfound.html if failure to upload occurse
  sub userfileupload {
      my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname,
-         $destudom,$thumbwidth,$thumbheight)=@_;
+         $destudom,$thumbwidth,$thumbheight,$resizewidth,$resizeheight)=@_;
      if (!defined($subdir)) { $subdir='unknown'; }
      my $fname=$env{'form.'.$formname.'.filename'};
      $fname=&clean_filename($fname);
- Line 1876  sub userfileupload {
+ Line 2397  sub userfileupload {
          close($fh);
          return $fullpath.'/'.$fname;
      }
+     if ($subdir eq 'scantron') {
+         $fname = 'scantron_orig_'.$fname;
+     } else {
  # Create the directory if not present
-     $fname="$subdir/$fname";
+         $fname="$subdir/$fname";
+     }
      if ($coursedoc) {
  	my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
  	my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
          if ($env{'form.folder'} =~ m/^(default|supplemental)/) {
              return &finishuserfileupload($docuname,$docudom,
  					 $formname,$fname,$parser,$allfiles,
- 					 $codebase,$thumbwidth,$thumbheight);
+ 					 $codebase,$thumbwidth,$thumbheight,
+                                          $resizewidth,$resizeheight);
          } else {
              $fname=$env{'form.folder'}.'/'.$fname;
              return &process_coursefile('uploaddoc',$docuname,$docudom,
- Line 1897  sub userfileupload {
+ Line 2422  sub userfileupload {
          my $docudom=$destudom;
  	return &finishuserfileupload($docuname,$docudom,$formname,$fname,
  				     $parser,$allfiles,$codebase,
-                                      $thumbwidth,$thumbheight);
+                                      $thumbwidth,$thumbheight,
+                                      $resizewidth,$resizeheight);
      } else {
          my $docuname=$env{'user.name'};
- Line 1908  sub userfileupload {
+ Line 2434  sub userfileupload {
          }
  	return &finishuserfileupload($docuname,$docudom,$formname,$fname,
  				     $parser,$allfiles,$codebase,
-                                      $thumbwidth,$thumbheight);
+                                      $thumbwidth,$thumbheight,
+                                      $resizewidth,$resizeheight);
      }
  }
  sub finishuserfileupload {
      my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase,
-         $thumbwidth,$thumbheight) = @_;
+         $thumbwidth,$thumbheight,$resizewidth,$resizeheight) = @_;
      my $path=$docudom.'/'.$docuname.'/';
      my $filepath=$perlvar{'lonDocRoot'};
      my ($fnamepath,$file,$fetchthumb);
      $file=$fname;
      if ($fname=~m|/|) {
- Line 1931  sub finishuserfileupload {
+ Line 2459  sub finishuserfileupload {
  	    mkdir($filepath,0777);
          }
      }
  # Save the file
      {
  	if (!open(FH,'>'.$filepath.'/'.$file)) {
- Line 1944  sub finishuserfileupload {
+ Line 2473  sub finishuserfileupload {
  	    return '/adm/notfound.html';
  	}
  	close(FH);
+         if ($resizewidth && $resizeheight) {
+             my $mm = new File::MMagic;
+             my $mime_type = $mm->checktype_filename($filepath.'/'.$file);
+             if ($mime_type =~ m{^image/}) {
+ 	        &resizeImage($filepath.'/'.$file,$resizewidth,$resizeheight);
+             }
+ 	}
      }
      if ($parser eq 'parse') {
-         my $parse_result = &extract_embedded_items($filepath,$file,$allfiles,
+         my $mm = new File::MMagic;
- 						   $codebase);
+         my $mime_type = $mm->checktype_filename($filepath.'/'.$file);
-         unless ($parse_result eq 'ok') {
+         if ($mime_type eq 'text/html') {
-             &logthis('Failed to parse '.$filepath.$file.
+             my $parse_result = &extract_embedded_items($filepath.'/'.$file,
- 		     ' for embedded media: '.$parse_result);
+                                                        $allfiles,$codebase);
+             unless ($parse_result eq 'ok') {
+                 &logthis('Failed to parse '.$filepath.$file.
+ 	   	         ' for embedded media: '.$parse_result);
+             }
          }
      }
      if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
- Line 1965  sub finishuserfileupload {
+ Line 2505  sub finishuserfileupload {
  # Notify homeserver to grep it
  #
      my $docuhome=&homeserver($docuname,$docudom);
      my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
      if ($fetchresult eq 'ok') {
          if ($fetchthumb) {
- Line 1986  sub finishuserfileupload {
+ Line 2526  sub finishuserfileupload {
  }
  sub extract_embedded_items {
-     my ($filepath,$file,$allfiles,$codebase,$content) = @_;
+     my ($fullpath,$allfiles,$codebase,$content) = @_;
      my @state = ();
      my %javafiles = (
                        codebase => '',
- Line 2001  sub extract_embedded_items {
+ Line 2541  sub extract_embedded_items {
      if ($content) {
          $p = HTML::LCParser->new($content);
      } else {
-         $p = HTML::LCParser->new($filepath.'/'.$file);
+         $p = HTML::LCParser->new($fullpath);
      }
      while (my $t=$p->get_token()) {
  	if ($t->[0] eq 'S') {
- Line 2097  sub add_filetype {
+ Line 2637  sub add_filetype {
  }
  sub removeuploadedurl {
      my ($url)=@_;
      my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);
      return &removeuserfile($uname,$udom,$fname);
  }
  sub removeuserfile {
      my ($docuname,$docudom,$fname)=@_;
      my $home=&homeserver($docuname,$docudom);
      my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home);
      if ($result eq 'ok') {
          if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {
              my $metafile = $fname.'.meta';
              my $metaresult = &removeuserfile($docuname,$docudom,$metafile);
  	    my $url = "/uploaded/$docudom/$docuname/$fname";
              my ($file,$group) = (&parse_portfolio_url($url))[3,4];
              my $sqlresult =
                  &update_portfolio_table($docuname,$docudom,$file,
                                          'portfolio_metadata',$group,
- Line 2186  sub flushcourselogs {
+ Line 2726  sub flushcourselogs {
              }
          }
          $courseidbuffer{$coursehombuf{$crsid}}{$crsid} = {
-             'description' => &escape($coursedescrbuf{$crsid}),
+             'description' => $coursedescrbuf{$crsid},
-             'inst_code'    => &escape($courseinstcodebuf{$crsid}),
+             'inst_code'    => $courseinstcodebuf{$crsid},
-             'type'        => &escape($coursetypebuf{$crsid}),
+             'type'        => $coursetypebuf{$crsid},
-             'owner'       => &escape($courseownerbuf{$crsid}),
+             'owner'       => $courseownerbuf{$crsid},
          };
      }
  #
- Line 2254  sub flushcourselogs {
+ Line 2794  sub flushcourselogs {
  # Reverse lookup of domain roles (dc, ad, li, sc, au)
  #
      my %domrolebuffer = ();
-     foreach my $entry (keys %domainrolehash) {
+     foreach my $entry (keys(%domainrolehash)) {
          my ($role,$uname,$udom,$runame,$rudom,$rsec)=split(/:/,$entry);
          if ($domrolebuffer{$rudom}) {
              $domrolebuffer{$rudom}.='&'.&escape($entry).
- Line 2314  sub courseacclog {
+ Line 2854  sub courseacclog {
          # FIXME: Probably ought to escape things....
  	foreach my $key (keys(%env)) {
              if ($key=~/^form\.(.*)/) {
- 		$what.=':'.$1.'='.$env{$key};
+                 my $formitem = $1;
+                 if ($formitem =~ /^HWFILE(?:SIZE|TOOBIG)/) {
+                     $what.=':'.$formitem.'='.$env{$key};
+                 } elsif ($formitem !~ /^HWFILE(?:[^.]+)$/) {
+                     $what.=':'.$formitem.'='.$env{$key};
+                 }
              }
          }
      } elsif ($fnsymb =~ m:^/adm/searchcat:) {
- Line 2354  sub userrolelog {
+ Line 2899  sub userrolelog {
      if (($trole=~/^ca/) || ($trole=~/^aa/) ||
          ($trole=~/^in/) || ($trole=~/^cc/) ||
          ($trole=~/^ep/) || ($trole=~/^cr/) ||
-         ($trole=~/^ta/)) {
+         ($trole=~/^ta/) || ($trole=~/^co/)) {
         my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
         $userrolehash
           {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
- Line 2363  sub userrolelog {
+ Line 2908  sub userrolelog {
      if (($env{'request.role'} =~ /dc\./) &&
  	(($trole=~/^au/) || ($trole=~/^in/) ||
  	 ($trole=~/^cc/) || ($trole=~/^ep/) ||
- 	 ($trole=~/^cr/) || ($trole=~/^ta/))) {
+ 	 ($trole=~/^cr/) || ($trole=~/^ta/) ||
+          ($trole=~/^co/))) {
         $userrolehash
           {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}
                      =$tend.':'.$tstart;
- Line 2379  sub userrolelog {
+ Line 2925  sub userrolelog {
      }
  }
+ sub courserolelog {
+     my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_;
+     if (($trole eq 'cc') || ($trole eq 'in') ||
+         ($trole eq 'ep') || ($trole eq 'ad') ||
+         ($trole eq 'ta') || ($trole eq 'st') ||
+         ($trole=~/^cr/) || ($trole eq 'gr') ||
+         ($trole eq 'co')) {
+         if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {
+             my $cdom = $1;
+             my $cnum = $2;
+             my $sec = $3;
+             my $namespace = 'rolelog';
+             my %storehash = (
+                                role    => $trole,
+                                start   => $tstart,
+                                end     => $tend,
+                                selfenroll => $selfenroll,
+                                context    => $context,
+                             );
+             if ($trole eq 'gr') {
+                 $namespace = 'groupslog';
+                 $storehash{'group'} = $sec;
+             } else {
+                 $storehash{'section'} = $sec;
+             }
+             &instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom);
+             if (($trole ne 'st') || ($sec ne '')) {
+                 &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum);
+             }
+         }
+     }
+     return;
+ }
  sub get_course_adv_roles {
-     my $cid=shift;
+     my ($cid,$codes) = @_;
      $cid=$env{'request.course.id'} unless (defined($cid));
      my %coursehash=&coursedescription($cid);
+     my $crstype = &Apache::loncommon::course_type($cid);
      my %nothide=();
      foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
- 	$nothide{join(':',split(/[\@\:]/,$user))}=1;
+         if ($user !~ /:/) {
+ 	    $nothide{join(':',split(/[\@]/,$user))}=1;
+         } else {
+             $nothide{$user}=1;
+         }
      }
      my %returnhash=();
      my %dumphash=
              &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
      my $now=time;
-     foreach my $entry (keys %dumphash) {
+     my %privileged;
+     foreach my $entry (keys(%dumphash)) {
  	my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
          if (($tstart) && ($tstart<0)) { next; }
          if (($tend) && ($tend<$now)) { next; }
          if (($tstart) && ($now<$tstart)) { next; }
          my ($role,$username,$domain,$section)=split(/\:/,$entry);
  	if ($username eq '' || $domain eq '') { next; }
- 	if ((&privileged($username,$domain)) &&
+         unless (ref($privileged{$domain}) eq 'HASH') {
- 	    (!$nothide{$username.':'.$domain})) { next; }
+             my %dompersonnel =
+                 &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now);
+             $privileged{$domain} = {};
+             foreach my $server (keys(%dompersonnel)) {
+                 if (ref($dompersonnel{$server}) eq 'HASH') {
+                     foreach my $user (keys(%{$dompersonnel{$server}})) {
+                         my ($trole,$uname,$udom) = split(/:/,$user);
+                         $privileged{$udom}{$uname} = 1;
+                     }
+                 }
+             }
+         }
+         if ((exists($privileged{$domain}{$username})) &&
+             (!$nothide{$username.':'.$domain})) { next; }
  	if ($role eq 'cr') { next; }
-         my $key=&plaintext($role);
+         if ($codes) {
-         if ($section) { $key.=' (Sec/Grp '.$section.')'; }
+             if ($section) { $role .= ':'.$section; }
-         if ($returnhash{$key}) {
+             if ($returnhash{$role}) {
- 	    $returnhash{$key}.=','.$username.':'.$domain;
+                 $returnhash{$role}.=','.$username.':'.$domain;
+             } else {
+                 $returnhash{$role}=$username.':'.$domain;
+             }
          } else {
-             $returnhash{$key}=$username.':'.$domain;
+             my $key=&plaintext($role,$crstype);
+             if ($section) { $key.=' ('.&Apache::lonlocal::mt('Section [_1]',$section).')'; }
+             if ($returnhash{$key}) {
+ 	        $returnhash{$key}.=','.$username.':'.$domain;
+             } else {
+                 $returnhash{$key}=$username.':'.$domain;
+             }
          }
-      }
+     }
      return %returnhash;
  }
  sub get_my_roles {
-     my ($uname,$udom,$context,$types,$roles,$roledoms)=@_;
+     my ($uname,$udom,$context,$types,$roles,$roledoms,$withsec,$hidepriv)=@_;
      unless (defined($uname)) { $uname=$env{'user.name'}; }
      unless (defined($udom)) { $udom=$env{'user.domain'}; }
-     my %dumphash;
+     my (%dumphash,%nothide);
      if ($context eq 'userroles') {
          %dumphash = &dump('roles',$udom,$uname);
      } else {
          %dumphash=
              &dump('nohist_userroles',$udom,$uname);
+         if ($hidepriv) {
+             my %coursehash=&coursedescription($udom.'_'.$uname);
+             foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
+                 if ($user !~ /:/) {
+                     $nothide{join(':',split(/[\@]/,$user))} = 1;
+                 } else {
+                     $nothide{$user} = 1;
+                 }
+             }
+         }
      }
      my %returnhash=();
      my $now=time;
+     my %privileged;
      foreach my $entry (keys(%dumphash)) {
          my ($role,$tend,$tstart);
          if ($context eq 'userroles') {
- Line 2434  sub get_my_roles {
+ Line 3053  sub get_my_roles {
          }
          if (($tstart) && ($tstart<0)) { next; }
          my $status = 'active';
-         if (($tend) && ($tend<$now)) {
+         if (($tend) && ($tend<=$now)) {
              $status = 'previous';
          }
          if (($tstart) && ($now<$tstart)) {
- Line 2463  sub get_my_roles {
+ Line 3082  sub get_my_roles {
          }
          if (ref($roles) eq 'ARRAY') {
              if (!grep(/^\Q$role\E$/,@{$roles})) {
-                 next;
+                 if ($role =~ /^cr\//) {
+                     if (!grep(/^cr$/,@{$roles})) {
+                         next;
+                     }
+                 } else {
+                     next;
+                 }
+             }
+         }
+         if ($hidepriv) {
+             if ($context eq 'userroles') {
+                 if ((&privileged($username,$domain)) &&
+                     (!$nothide{$username.':'.$domain})) {
+                     next;
+                 }
+             } else {
+                 unless (ref($privileged{$domain}) eq 'HASH') {
+                     my %dompersonnel =
+                         &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now);
+                     $privileged{$domain} = {};
+                     if (keys(%dompersonnel)) {
+                         foreach my $server (keys(%dompersonnel)) {
+                             if (ref($dompersonnel{$server}) eq 'HASH') {
+                                 foreach my $user (keys(%{$dompersonnel{$server}})) {
+                                     my ($trole,$uname,$udom) = split(/:/,$user);
+                                     $privileged{$udom}{$uname} = $trole;
+                                 }
+                             }
+                         }
+                     }
+                 }
+                 if (exists($privileged{$domain}{$username})) {
+                     if (!$nothide{$username.':'.$domain}) {
+                         next;
+                     }
+                 }
              }
          }
- 	$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
+         if ($withsec) {
+             $returnhash{$username.':'.$domain.':'.$role.':'.$section} =
+                 $tstart.':'.$tend;
+         } else {
+             $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
+         }
      }
      return %returnhash;
  }
- Line 2506  sub getannounce {
+ Line 3165  sub getannounce {
  sub courseidput {
      my ($domain,$storehash,$coursehome,$caller) = @_;
+     return unless (ref($storehash) eq 'HASH');
      my $outcome;
      if ($caller eq 'timeonly') {
          my $cids = '';
- Line 2530  sub courseidput {
+ Line 3190  sub courseidput {
          foreach my $cid (keys(%$storehash)) {
              $what .= &escape($cid).'=';
              foreach my $item ('description','inst_code','owner','type') {
-                 $what .= &escape($storehash->{$item}).':';
+                 $what .= &escape($storehash->{$cid}{$item}).':';
              }
              $what =~ s/\:$/&/;
          }
- Line 2543  sub courseidput {
+ Line 3203  sub courseidput {
  sub courseiddump {
      my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
-         $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;
+         $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
+         $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,
+         $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner)=@_;
      my $as_hash = 1;
      my %returnhash;
      if (!$domfilter) { $domfilter=''; }
- Line 2560  sub courseiddump {
+ Line 3222  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).':'.&escape($catfilter).':'.
+                          $showhidden.':'.$caller.':'.&escape($cloner).':'.
+                          &escape($cc_clone).':'.$cloneonly.':'.
+                          &escape($createdbefore).':'.&escape($createdafter).':'.
+                          &escape($creationcontext).':'.$domcloner,
+                          $tryserver);
                  my @pairs=split(/\&/,$rep);
                  foreach my $item (@pairs) {
                      my ($key,$value)=split(/\=/,$item,2);
- Line 2575  sub courseiddump {
+ Line 3243  sub courseiddump {
                          for (my $i=0; $i<@responses; $i++) {
                              $returnhash{$key}{$items[$i]} = &unescape($responses[$i]);
                          }
                      }
                  }
              }
          }
- Line 2583  sub courseiddump {
+ Line 3251  sub courseiddump {
      return %returnhash;
  }
+ sub courselastaccess {
+     my ($cdom,$cnum,$hostidref) = @_;
+     my %returnhash;
+     if ($cdom && $cnum) {
+         my $chome = &homeserver($cnum,$cdom);
+         if ($chome ne 'no_host') {
+             my $rep = &reply('courselastaccess:'.$cdom.':'.$cnum,$chome);
+             &extract_lastaccess(\%returnhash,$rep);
+         }
+     } else {
+         if (!$cdom) { $cdom=''; }
+         my %libserv = &all_library();
+         foreach my $tryserver (keys(%libserv)) {
+             if (ref($hostidref) eq 'ARRAY') {
+                 next unless (grep(/^\Q$tryserver\E$/,@{$hostidref}));
+             }
+             if (($cdom eq '') || (&host_domain($tryserver) eq $cdom)) {
+                 my $rep = &reply('courselastaccess:'.&host_domain($tryserver).':',$tryserver);
+                 &extract_lastaccess(\%returnhash,$rep);
+             }
+         }
+     }
+     return %returnhash;
+ }
+ sub extract_lastaccess {
+     my ($returnhash,$rep) = @_;
+     if (ref($returnhash) eq 'HASH') {
+         unless ($rep eq 'unknown_command' || $rep eq 'no_such_host' ||
+                 $rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' ||
+                  $rep eq '') {
+             my @pairs=split(/\&/,$rep);
+             foreach my $item (@pairs) {
+                 my ($key,$value)=split(/\=/,$item,2);
+                 $key = &unescape($key);
+                 next if ($key =~ /^error: 2 /);
+                 $returnhash->{$key} = &thaw_unescape($value);
+             }
+         }
+     }
+     return;
+ }
  # ---------------------------------------------------------- DC e-mail
  sub dcmailput {
- Line 2615  sub dcmaildump {
+ Line 3326  sub dcmaildump {
  sub get_domain_roles {
      my ($dom,$roles,$startdate,$enddate)=@_;
-     if (undef($startdate) || $startdate eq '') {
+     if ((!defined($startdate)) || ($startdate eq '')) {
          $startdate = '.';
      }
-     if (undef($enddate) || $enddate eq '') {
+     if ((!defined($enddate)) || ($enddate eq '')) {
          $enddate = '.';
      }
-     my $rolelist = join(':',@{$roles});
+     my $rolelist;
+     if (ref($roles) eq 'ARRAY') {
+         $rolelist = join(':',@{$roles});
+     }
      my %personnel = ();
      my %servers = &get_servers($dom,'library');
- Line 2647  sub get_first_access {
+ Line 3361  sub get_first_access {
      my ($symb,$courseid,$udom,$uname)=&whichuser();
      if ($argsymb) { $symb=$argsymb; }
      my ($map,$id,$res)=&decode_symb($symb);
-     if ($type eq 'map') {
+     if ($type eq 'course') {
+ 	$res='course';
+     } elsif ($type eq 'map') {
  	$res=&symbread($map);
      } else {
  	$res=$symb;
- Line 2660  sub set_first_access {
+ Line 3376  sub set_first_access {
      my ($type)=@_;
      my ($symb,$courseid,$udom,$uname)=&whichuser();
      my ($map,$id,$res)=&decode_symb($symb);
-     if ($type eq 'map') {
+     if ($type eq 'course') {
+ 	$res='course';
+     } elsif ($type eq 'map') {
  	$res=&symbread($map);
      } else {
  	$res=$symb;
- Line 3018  sub tmpreset {
+ Line 3736  sub tmpreset {
    if (tie(%hash,'GDBM_File',
  	  $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
  	  &GDBM_WRCREAT(),0640)) {
-     foreach my $key (keys %hash) {
+     foreach my $key (keys(%hash)) {
        if ($key=~ /:$symb/) {
  	delete($hash{$key});
        }
- Line 3290  sub coursedescription {
+ Line 4008  sub coursedescription {
         }
      }
      if (!$args->{'one_time'}) {
- 	&appenv(%envhash);
+ 	&appenv(\%envhash);
      }
      return %returnhash;
  }
+ sub update_released_required {
+     my ($needsrelease,$cdom,$cnum,$chome,$cid) = @_;
+     if ($cdom eq '' || $cnum eq '' || $chome eq '' || $cid eq '') {
+         $cid = $env{'request.course.id'};
+         $cdom = $env{'course.'.$cid.'.domain'};
+         $cnum = $env{'course.'.$cid.'.num'};
+         $chome = $env{'course.'.$cid.'.home'};
+     }
+     if ($needsrelease) {
+         my %curr_reqd_hash = &userenvironment($cdom,$cnum,'internal.releaserequired');
+         my $needsupdate;
+         if ($curr_reqd_hash{'internal.releaserequired'} eq '') {
+             $needsupdate = 1;
+         } else {
+             my ($currmajor,$currminor) = split(/\./,$curr_reqd_hash{'internal.releaserequired'});
+             my ($needsmajor,$needsminor) = split(/\./,$needsrelease);
+             if (($currmajor < $needsmajor) || ($currmajor == $needsmajor && $currminor < $needsminor)) {
+                 $needsupdate = 1;
+             }
+         }
+         if ($needsupdate) {
+             my %needshash = (
+                              'internal.releaserequired' => $needsrelease,
+                             );
+             my $putresult = &put('environment',\%needshash,$cdom,$cnum);
+             if ($putresult eq 'ok') {
+                 &appenv({'course.'.$cid.'.internal.releaserequired' => $needsrelease});
+                 my %crsinfo = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.');
+                 if (ref($crsinfo{$cid}) eq 'HASH') {
+                     $crsinfo{$cid}{'releaserequired'} = $needsrelease;
+                     &courseidput($cdom,\%crsinfo,$chome,'notime');
+                 }
+             }
+         }
+     }
+     return;
+ }
  # -------------------------------------------------See if a user is privileged
  sub privileged {
      my ($username,$domain)=@_;
      my $rolesdump=&reply("dump:$domain:$username:roles",
  			&homeserver($username,$domain));
-     if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return 0; }
+     if (($rolesdump eq 'con_lost') || ($rolesdump eq '') ||
+         ($rolesdump =~ /^error:/)) {
+         return 0;
+     }
      my $now=time;
      if ($rolesdump ne '') {
          foreach my $entry (split(/&/,$rolesdump)) {
- Line 3329  sub privileged {
+ Line 4088  sub privileged {
  sub rolesinit {
      my ($domain,$username,$authhost)=@_;
-     my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
-     if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }
-     my %allroles=();
-     my %allgroups=();
      my $now=time;
      my %userroles = ('user.login.time' => $now);
+     my $extra = &freeze_escape({'clientcheckrole' => 1});
+     my $rolesdump=reply("dump:$domain:$username:roles:.::$extra",$authhost);
+     if (($rolesdump eq 'con_lost') || ($rolesdump eq '') ||
+         ($rolesdump =~ /^error:/)) {
+         return \%userroles;
+     }
+     my %allroles=();
+     my %allgroups=();
      my $group_privs;
      if ($rolesdump ne '') {
- Line 3400  sub custom_roleprivs {
+ Line 4163  sub custom_roleprivs {
          if (($rdummy ne 'con_lost') && ($roledef ne '')) {
              my ($syspriv,$dompriv,$coursepriv)=split(/\_/,$roledef);
              if (defined($syspriv)) {
+                 if ($trest =~ /^$match_community$/) {
+                     $syspriv =~ s/bre\&S//;
+                 }
                  $$allroles{'cm./'}.=':'.$syspriv;
                  $$allroles{$spec.'./'}.=':'.$syspriv;
              }
- Line 3448  sub standard_roleprivs {
+ Line 4214  sub standard_roleprivs {
  }
  sub set_userprivs {
-     my ($userroles,$allroles,$allgroups) = @_;
+     my ($userroles,$allroles,$allgroups,$groups_roles) = @_;
      my $author=0;
      my $adv=0;
      my %grouproles = ();
      if (keys(%{$allgroups}) > 0) {
-         foreach my $role (keys %{$allroles}) {
+         my @groupkeys;
-             my ($trole,$area,$sec,$extendedarea);
+         foreach my $role (keys(%{$allroles})) {
-             if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) {
+             push(@groupkeys,$role);
-                 $trole = $1;
+         }
-                 $area = $2;
+         if (ref($groups_roles) eq 'HASH') {
-                 $sec = $3;
+             foreach my $key (keys(%{$groups_roles})) {
-                 $extendedarea = $area.$sec;
+                 unless (grep(/^\Q$key\E$/,@groupkeys)) {
-                 if (exists($$allgroups{$area})) {
+                     push(@groupkeys,$key);
-                     foreach my $group (keys(%{$$allgroups{$area}})) {
+                 }
-                         my $spec = $trole.'.'.$extendedarea;
+             }
-                         $grouproles{$spec.'.'.$area.'/'.$group} =
+         }
+         if (@groupkeys > 0) {
+             foreach my $role (@groupkeys) {
+                 my ($trole,$area,$sec,$extendedarea);
+                 if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) {
+                     $trole = $1;
+                     $area = $2;
+                     $sec = $3;
+                     $extendedarea = $area.$sec;
+                     if (exists($$allgroups{$area})) {
+                         foreach my $group (keys(%{$$allgroups{$area}})) {
+                             my $spec = $trole.'.'.$extendedarea;
+                             $grouproles{$spec.'.'.$area.'/'.$group} =
                                                  $$allgroups{$area}{$group};
+                         }
                      }
                  }
              }
- Line 3475  sub set_userprivs {
+ Line 4254  sub set_userprivs {
      }
      foreach my $role (keys(%{$allroles})) {
          my %thesepriv;
-         if (($role=~/^au/) || ($role=~/^ca/)) { $author=1; }
+         if (($role=~/^au/) || ($role=~/^ca/) || ($role=~/^aa/)) { $author=1; }
          foreach my $item (split(/:/,$$allroles{$role})) {
              if ($item ne '') {
                  my ($privilege,$restrictions)=split(/&/,$item);
- Line 3496  sub set_userprivs {
+ Line 4275  sub set_userprivs {
      return ($author,$adv);
  }
+ sub role_status {
+     my ($rolekey,$then,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;
+     my @pwhere = ();
+     if (exists($env{$rolekey}) && $env{$rolekey} ne '') {
+         (undef,undef,$$role,@pwhere)=split(/\./,$rolekey);
+         unless (!defined($$role) || $$role eq '') {
+             $$where=join('.',@pwhere);
+             $$trolecode=$$role.'.'.$$where;
+             ($$tstart,$$tend)=split(/\./,$env{$rolekey});
+             $$tstatus='is';
+             if ($$tstart && $$tstart>$then) {
+                 $$tstatus='future';
+                 if ($$tstart<$now) {
+                     if ($$tstart && $$tstart>$refresh) {
+                         if (($$where ne '') && ($$role ne '')) {
+                             my (%allroles,%allgroups,$group_privs,
+                                 %groups_roles,@rolecodes);
+                             my %userroles = (
+                                 'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend
+                             );
+                             @rolecodes = ('cm');
+                             my $spec=$$role.'.'.$$where;
+                             my ($tdummy,$tdomain,$trest)=split(/\//,$$where);
+                             if ($$role =~ /^cr\//) {
+                                 &custom_roleprivs(\%allroles,$$role,$tdomain,$trest,$spec,$$where);
+                                 push(@rolecodes,'cr');
+                             } elsif ($$role eq 'gr') {
+                                 push(@rolecodes,$$role);
+                                 my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'},
+                                                     $env{'user.name'});
+                                 my ($trole) = split('_',$rolehash{$$where.'_'.$$role},2);
+                                 (undef,my $group_privs) = split(/\//,$trole);
+                                 $group_privs = &unescape($group_privs);
+                                 &group_roleprivs(\%allgroups,$$where,$group_privs,$$tend,$$tstart);
+                                 my %course_roles = &get_my_roles($env{'user.name'},$env{'user.domain'},'userroles',['active'],['cc','co','in','ta','ep','ad','st','cr'],[$tdomain],1);
+                                 if (keys(%course_roles) > 0) {
+                                     my ($tnum) = ($trest =~ /^($match_courseid)/);
+                                     if ($tdomain ne '' && $tnum ne '') {
+                                         foreach my $key (keys(%course_roles)) {
+                                             if ($key =~ /^\Q$tnum\E:\Q$tdomain\E:([^:]+):?([^:]*)/) {
+                                                 my $crsrole = $1;
+                                                 my $crssec = $2;
+                                                 if ($crsrole =~ /^cr/) {
+                                                     unless (grep(/^cr$/,@rolecodes)) {
+                                                         push(@rolecodes,'cr');
+                                                     }
+                                                 } else {
+                                                     unless(grep(/^\Q$crsrole\E$/,@rolecodes)) {
+                                                         push(@rolecodes,$crsrole);
+                                                     }
+                                                 }
+                                                 my $rolekey = $crsrole.'./'.$tdomain.'/'.$tnum;
+                                                 if ($crssec ne '') {
+                                                     $rolekey .= '/'.$crssec;
+                                                 }
+                                                 $rolekey .= './';
+                                                 $groups_roles{$rolekey} = \@rolecodes;
+                                             }
+                                         }
+                                     }
+                                 }
+                             } else {
+                                 push(@rolecodes,$$role);
+                                 &standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where);
+                             }
+                             my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups,\%groups_roles);
+                             &appenv(\%userroles,\@rolecodes);
+                             &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);
+                         }
+                     }
+                     $$tstatus = 'is';
+                 }
+             }
+             if ($$tend) {
+                 if ($$tend<$then) {
+                     $$tstatus='expired';
+                 } elsif ($$tend<$now) {
+                     $$tstatus='will_not';
+                 }
+             }
+         }
+     }
+ }
+ sub check_adhoc_privs {
+     my ($cdom,$cnum,$then,$refresh,$now,$checkrole) = @_;
+     my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;
+     if ($env{$cckey}) {
+         my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);
+         &role_status($cckey,$then,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);
+         unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) {
+             &set_adhoc_privileges($cdom,$cnum,$checkrole);
+         }
+     } else {
+         &set_adhoc_privileges($cdom,$cnum,$checkrole);
+     }
+ }
+ sub set_adhoc_privileges {
+ # role can be cc or ca
+     my ($dcdom,$pickedcourse,$role) = @_;
+     my $area = '/'.$dcdom.'/'.$pickedcourse;
+     my $spec = $role.'.'.$area;
+     my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'},
+                                   $env{'user.name'});
+     my %ccrole = ();
+     &standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area);
+     my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole);
+     &appenv(\%userroles,[$role,'cm']);
+     &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);
+     &appenv( {'request.role'        => $spec,
+               'request.role.domain' => $dcdom,
+               'request.course.sec'  => ''
+              }
+            );
+     my $tadv=0;
+     if (&allowed('adv') eq 'F') { $tadv=1; }
+     &appenv({'request.role.adv'    => $tadv});
+ }
  # --------------------------------------------------------------- get interface
  sub get {
- Line 3531  sub del {
+ Line 4430  sub del {
     foreach my $item (@$storearr) {
         $items.=&escape($item).'&';
     }
     $items=~s/\&$//;
     if (!$udomain) { $udomain=$env{'user.domain'}; }
     if (!$uname) { $uname=$env{'user.name'}; }
     my $uhome=&homeserver($uname,$udomain);
     return &reply("del:$udomain:$uname:$namespace:$items",$uhome);
  }
- Line 3839  sub tmpget {
+ Line 4738  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;
- Line 3955  sub get_portfolio_access {
+ Line 4855  sub get_portfolio_access {
                  my (%allgroups,%allroles);
                  my ($start,$end,$role,$sec,$group);
                  foreach my $envkey (%env) {
-                     if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) {
+                     if ($envkey =~ m-^user\.role\.(gr|cc|co|in|ta|ep|ad|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) {
                          my $cid = $2.'_'.$3;
                          if ($1 eq 'gr') {
                              $group = $4;
- Line 4094  sub is_portfolio_file {
+ Line 4994  sub is_portfolio_file {
      return;
  }
+ sub usertools_access {
+     my ($uname,$udom,$tool,$action,$context) = @_;
+     my ($access,%tools);
+     if ($context eq '') {
+         $context = 'tools';
+     }
+     if ($context eq 'requestcourses') {
+         %tools = (
+                       official   => 1,
+                       unofficial => 1,
+                       community  => 1,
+                  );
+     } else {
+         %tools = (
+                       aboutme   => 1,
+                       blog      => 1,
+                       portfolio => 1,
+                  );
+     }
+     return if (!defined($tools{$tool}));
+     if ((!defined($udom)) || (!defined($uname))) {
+         $udom = $env{'user.domain'};
+         $uname = $env{'user.name'};
+     }
+     if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
+         if ($action ne 'reload') {
+             if ($context eq 'requestcourses') {
+                 return $env{'environment.canrequest.'.$tool};
+             } else {
+                 return $env{'environment.availabletools.'.$tool};
+             }
+         }
+     }
+     my ($toolstatus,$inststatus);
+     if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&
+          ($action ne 'reload')) {
+         $toolstatus = $env{'environment.'.$context.'.'.$tool};
+         $inststatus = $env{'environment.inststatus'};
+     } else {
+         my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus');
+         $toolstatus = $userenv{$context.'.'.$tool};
+         $inststatus = $userenv{'inststatus'};
+     }
+     if ($toolstatus ne '') {
+         if ($toolstatus) {
+             $access = 1;
+         } else {
+             $access = 0;
+         }
+         return $access;
+     }
+     my $is_adv = &is_advanced_user($udom,$uname);
+     my %domdef = &get_domain_defaults($udom);
+     if (ref($domdef{$tool}) eq 'HASH') {
+         if ($is_adv) {
+             if ($domdef{$tool}{'_LC_adv'} ne '') {
+                 if ($domdef{$tool}{'_LC_adv'}) {
+                     $access = 1;
+                 } else {
+                     $access = 0;
+                 }
+                 return $access;
+             }
+         }
+         if ($inststatus ne '') {
+             my ($hasaccess,$hasnoaccess);
+             foreach my $affiliation (split(/:/,$inststatus)) {
+                 if ($domdef{$tool}{$affiliation} ne '') {
+                     if ($domdef{$tool}{$affiliation}) {
+                         $hasaccess = 1;
+                     } else {
+                         $hasnoaccess = 1;
+                     }
+                 }
+             }
+             if ($hasaccess || $hasnoaccess) {
+                 if ($hasaccess) {
+                     $access = 1;
+                 } elsif ($hasnoaccess) {
+                     $access = 0;
+                 }
+                 return $access;
+             }
+         } else {
+             if ($domdef{$tool}{'default'} ne '') {
+                 if ($domdef{$tool}{'default'}) {
+                     $access = 1;
+                 } elsif ($domdef{$tool}{'default'} == 0) {
+                     $access = 0;
+                 }
+                 return $access;
+             }
+         }
+     } else {
+         if ($context eq 'tools') {
+             $access = 1;
+         } else {
+             $access = 0;
+         }
+         return $access;
+     }
+ }
+ sub is_course_owner {
+     my ($cdom,$cnum,$udom,$uname) = @_;
+     if (($udom eq '') || ($uname eq '')) {
+         $udom = $env{'user.domain'};
+         $uname = $env{'user.name'};
+     }
+     unless (($udom eq '') || ($uname eq '')) {
+         if (exists($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'})) {
+             if ($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'} eq $uname.':'.$udom) {
+                 return 1;
+             } else {
+                 my %courseinfo = &Apache::lonnet::coursedescription($cdom.'/'.$cnum);
+                 if ($courseinfo{'internal.courseowner'} eq $uname.':'.$udom) {
+                     return 1;
+                 }
+             }
+         }
+     }
+     return;
+ }
+ sub is_advanced_user {
+     my ($udom,$uname) = @_;
+     my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1);
+     my %allroles;
+     my $is_adv;
+     foreach my $role (keys(%roleshash)) {
+         my ($trest,$tdomain,$trole,$sec) = split(/:/,$role);
+         my $area = '/'.$tdomain.'/'.$trest;
+         if ($sec ne '') {
+             $area .= '/'.$sec;
+         }
+         if (($area ne '') && ($trole ne '')) {
+             my $spec=$trole.'.'.$area;
+             if ($trole =~ /^cr\//) {
+                 &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
+             } elsif ($trole ne 'gr') {
+                 &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
+             }
+         }
+     }
+     foreach my $role (keys(%allroles)) {
+         last if ($is_adv);
+         foreach my $item (split(/:/,$allroles{$role})) {
+             if ($item ne '') {
+                 my ($privilege,$restrictions)=split(/&/,$item);
+                 if ($privilege eq 'adv') {
+                     $is_adv = 1;
+                     last;
+                 }
+             }
+         }
+     }
+     return $is_adv;
+ }
+ sub check_can_request {
+     my ($dom,$can_request,$request_domains) = @_;
+     my $canreq = 0;
+     my ($types,$typename) = &Apache::loncommon::course_types();
+     my @options = ('approval','validate','autolimit');
+     my $optregex = join('|',@options);
+     if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) {
+         foreach my $type (@{$types}) {
+             if (&usertools_access($env{'user.name'},
+                                   $env{'user.domain'},
+                                   $type,undef,'requestcourses')) {
+                 $canreq ++;
+                 if (ref($request_domains) eq 'HASH') {
+                     push(@{$request_domains->{$type}},$env{'user.domain'});
+                 }
+                 if ($dom eq $env{'user.domain'}) {
+                     $can_request->{$type} = 1;
+                 }
+             }
+             if ($env{'environment.reqcrsotherdom.'.$type} ne '') {
+                 my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type});
+                 if (@curr > 0) {
+                     foreach my $item (@curr) {
+                         if (ref($request_domains) eq 'HASH') {
+                             my ($otherdom) = ($item =~ /^($match_domain):($optregex)(=?\d*)$/);
+                             if ($otherdom ne '') {
+                                 if (ref($request_domains->{$type}) eq 'ARRAY') {
+                                     unless (grep(/^\Q$otherdom\E$/,@{$request_domains->{$type}})) {
+                                         push(@{$request_domains->{$type}},$otherdom);
+                                     }
+                                 } else {
+                                     push(@{$request_domains->{$type}},$otherdom);
+                                 }
+                             }
+                         }
+                     }
+                     unless($dom eq $env{'user.domain'}) {
+                         $canreq ++;
+                         if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) {
+                             $can_request->{$type} = 1;
+                         }
+                     }
+                 }
+             }
+         }
+     }
+     return $canreq;
+ }
  # ---------------------------------------------- Custom access rule evaluation
- Line 4249  sub allowed {
+ Line 5362  sub allowed {
      my $statecond=0;
      my $courseprivid='';
+     my $ownaccess;
+     # Community Coordinator or Assistant Co-author browsing resource space.
+     if (($priv eq 'bro') && ($env{'user.author'})) {
+         if ($uri eq '') {
+             $ownaccess = 1;
+         } else {
+             if (($env{'user.domain'} ne '') && ($env{'user.name'} ne '')) {
+                 my $udom = $env{'user.domain'};
+                 my $uname = $env{'user.name'};
+                 if ($uri =~ m{^\Q$udom\E/?$}) {
+                     $ownaccess = 1;
+                 } elsif ($uri =~ m{^\Q$udom\E/\Q$uname\E/?}) {
+                     unless ($uri =~ m{\.\./}) {
+                         $ownaccess = 1;
+                     }
+                 } elsif (($udom ne 'public') && ($uname ne 'public')) {
+                     my $now = time;
+                     if ($uri =~ m{^([^/]+)/?$}) {
+                         my $adom = $1;
+                         foreach my $key (keys(%env)) {
+                             if ($key =~ m{^user\.role\.(ca|aa)/\Q$adom\E}) {
+                                 my ($start,$end) = split('.',$env{$key});
+                                 if (($now >= $start) && (!$end || $end < $now)) {
+                                     $ownaccess = 1;
+                                     last;
+                                 }
+                             }
+                         }
+                     } elsif ($uri =~ m{^([^/]+)/([^/]+)/?}) {
+                         my $adom = $1;
+                         my $aname = $2;
+                         foreach my $role ('ca','aa') {
+                             if ($env{"user.role.$role./$adom/$aname"}) {
+                                 my ($start,$end) =
+                                     split('.',$env{"user.role.$role./$adom/$aname"});
+                                 if (($now >= $start) && (!$end || $end < $now)) {
+                                     $ownaccess = 1;
+                                     last;
+                                 }
+                             }
+                         }
+                     }
+                 }
+             }
+         }
+     }
  # Course
      if ($env{'user.priv.'.$env{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) {
-        $thisallowed.=$1;
+         unless (($priv eq 'bro') && (!$ownaccess)) {
+             $thisallowed.=$1;
+         }
      }
  # Domain
      if ($env{'user.priv.'.$env{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}
         =~/\Q$priv\E\&([^\:]*)/) {
-        $thisallowed.=$1;
+         unless (($priv eq 'bro') && (!$ownaccess)) {
+             $thisallowed.=$1;
+         }
      }
  # Course: uri itself is a course
- Line 4269  sub allowed {
+ Line 5433  sub allowed {
      if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri}
         =~/\Q$priv\E\&([^\:]*)/) {
-        $thisallowed.=$1;
+         unless (($priv eq 'bro') && (!$ownaccess)) {
+             $thisallowed.=$1;
+         }
      }
  # URI is an uploaded document for this course, default permissions don't matter
- Line 4306  sub allowed {
+ Line 5472  sub allowed {
      }
  # Full access at system, domain or course-wide level? Exit.
      if ($thisallowed=~/F/) {
  	return 'F';
      }
- Line 4410  sub allowed {
+ Line 5575  sub allowed {
      my $envkey;
      if ($thisallowed=~/L/) {
-         foreach $envkey (keys %env) {
+         foreach $envkey (keys(%env)) {
             if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
                 my $courseid=$2;
                 my $roleid=$1.'.'.$2;
- Line 4659  sub log_query {
+ Line 5824  sub log_query {
  sub update_portfolio_table {
      my ($uname,$udom,$file_name,$query,$group,$action) = @_;
+     if ($group ne '') {
+         $file_name =~s /^\Q$group\E//;
+     }
      my $homeserver = &homeserver($uname,$udom);
      my $queryid=
          &reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group).
- Line 4680  sub update_allusers_table {
+ Line 5848  sub update_allusers_table {
                 'generation='.&escape($names->{'generation'}).'%%'.
                 'permanentemail='.&escape($names->{'permanentemail'}).'%%'.
                 'id='.&escape($names->{'id'}),$homeserver);
-     my $reply = &get_query_reply($queryid);
+     return;
-     return $reply;
  }
  # ------- Request retrieval of institutional classlists for course(s)
- Line 4698  sub fetch_enrollment_query {
+ Line 5865  sub fetch_enrollment_query {
      }
      my $host=&hostname($homeserver);
      my $cmd = '';
-     foreach my $affiliate (keys %{$affiliatesref}) {
+     foreach my $affiliate (keys(%{$affiliatesref})) {
          $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
      }
      $cmd =~ s/%%$//;
- Line 4816  sub auto_run {
+ Line 5983  sub auto_run {
              $response = 1;
          }
      } else {
-         my $homeserver = &homeserver($cnum,$cdom);
+         my $homeserver;
-         $response = &reply('autorun:'.$cdom,$homeserver);
+         if (&is_course($cdom,$cnum)) {
+             $homeserver = &homeserver($cnum,$cdom);
+         } else {
+             $homeserver = &domain($cdom,'primary');
+         }
+         if ($homeserver ne 'no_host') {
+             $response = &reply('autorun:'.$cdom,$homeserver);
+         }
      }
      return $response;
  }
  sub auto_get_sections {
      my ($cnum,$cdom,$inst_coursecode) = @_;
-     my $homeserver = &homeserver($cnum,$cdom);
+     my $homeserver;
-     my @secs = ();
+     if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
-     my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));
+         $homeserver = &homeserver($cnum,$cdom);
-     unless ($response eq 'refused') {
+     }
-         @secs = split(/:/,$response);
+     if (!defined($homeserver)) {
+         if ($cdom =~ /^$match_domain$/) {
+             $homeserver = &domain($cdom,'primary');
+         }
+     }
+     my @secs;
+     if (defined($homeserver)) {
+         my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));
+         unless ($response eq 'refused') {
+             @secs = split(/:/,$response);
+         }
      }
      return @secs;
  }
- Line 4847  sub auto_validate_courseID {
+ Line 6031  sub auto_validate_courseID {
      return $response;
  }
+ sub auto_validate_instcode {
+     my ($cnum,$cdom,$instcode,$owner) = @_;
+     my ($homeserver,$response);
+     if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
+         $homeserver = &homeserver($cnum,$cdom);
+     }
+     if (!defined($homeserver)) {
+         if ($cdom =~ /^$match_domain$/) {
+             $homeserver = &domain($cdom,'primary');
+         }
+     }
+     $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.
+                         &escape($instcode).':'.&escape($owner),$homeserver));
+     my ($outcome,$description) = map { &unescape($_); } split('&',$response,2);
+     return ($outcome,$description);
+ }
  sub auto_create_password {
      my ($cnum,$cdom,$authparam,$udom) = @_;
      my ($homeserver,$response);
- Line 4961  sub auto_instcode_format {
+ Line 6162  sub auto_instcode_format {
  		push(@homeservers,$tryserver);
  	    }
          }
+     } elsif ($caller eq 'requests') {
+         if ($codedom =~ /^$match_domain$/) {
+             my $chome = &domain($codedom,'primary');
+             unless ($chome eq 'no_host') {
+                 push(@homeservers,$chome);
+             }
+         }
      } else {
          push(@homeservers,&homeserver($caller,$codedom));
      }
- Line 5018  sub auto_instcode_defaults {
+ Line 6226  sub auto_instcode_defaults {
      }
      return $response;
  }
+ sub auto_possible_instcodes {
+     my ($domain,$codetitles,$cat_titles,$cat_orders,$code_order) = @_;
+     unless ((ref($codetitles) eq 'ARRAY') && (ref($cat_titles) eq 'HASH') &&
+             (ref($cat_orders) eq 'HASH') && (ref($code_order) eq 'ARRAY')) {
+         return;
+     }
+     my (@homeservers,$uhome);
+     if (defined(&domain($domain,'primary'))) {
+         $uhome=&domain($domain,'primary');
+         push(@homeservers,&domain($domain,'primary'));
+     } else {
+         my %servers = &get_servers($domain,'library');
+         foreach my $tryserver (keys(%servers)) {
+             if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
+                 push(@homeservers,$tryserver);
+             }
+         }
+     }
+     my $response;
+     foreach my $server (@homeservers) {
+         $response=&reply('autopossibleinstcodes:'.$domain,$server);
+         next if ($response =~ /(con_lost|error|no_such_host|refused)/);
+         my ($codetitlestr,$codeorderstr,$cat_title,$cat_order) =
+             split(':',$response);
+         @{$codetitles} = map { &unescape($_); } (split('&',$codetitlestr));
+         @{$code_order} = map { &unescape($_); } (split('&',$codeorderstr));
+         foreach my $item (split('&',$cat_title)) {
+             my ($name,$value)=split('=',$item);
+             $cat_titles->{&unescape($name)}=&thaw_unescape($value);
+         }
+         foreach my $item (split('&',$cat_order)) {
+             my ($name,$value)=split('=',$item);
+             $cat_orders->{&unescape($name)}=&thaw_unescape($value);
+         }
+         return 'ok';
+     }
+     return $response;
+ }
+ sub auto_courserequest_checks {
+     my ($dom) = @_;
+     my ($homeserver,%validations);
+     if ($dom =~ /^$match_domain$/) {
+         $homeserver = &domain($dom,'primary');
+     }
+     unless ($homeserver eq 'no_host') {
+         my $response=&reply('autocrsreqchecks:'.$dom,$homeserver);
+         unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
+             my @items = split(/&/,$response);
+             foreach my $item (@items) {
+                 my ($key,$value) = split('=',$item);
+                 $validations{&unescape($key)} = &thaw_unescape($value);
+             }
+         }
+     }
+     return %validations;
+ }
+ sub auto_courserequest_validation {
+     my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist) = @_;
+     my ($homeserver,$response);
+     if ($dom =~ /^$match_domain$/) {
+         $homeserver = &domain($dom,'primary');
+     }
+     unless ($homeserver eq 'no_host') {
+         $response=&unescape(&reply('autocrsreqvalidation:'.$dom.':'.&escape($owner).
+                                     ':'.&escape($crstype).':'.&escape($inststatuslist).
+                                     ':'.&escape($instcode).':'.&escape($instseclist),
+                                     $homeserver));
+     }
+     return $response;
+ }
  sub auto_validate_class_sec {
      my ($cdom,$cnum,$owners,$inst_class) = @_;
- Line 5078  sub toggle_coursegroup_status {
+ Line 6360  sub toggle_coursegroup_status {
  }
  sub modify_group_roles {
-     my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_;
+     my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs,$selfenroll,$context) = @_;
      my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
      my $role = 'gr/'.&escape($userprivs);
      my ($uname,$udom) = split(/:/,$user);
-     my $result = &assignrole($udom,$uname,$url,$role,$end,$start);
+     my $result = &assignrole($udom,$uname,$url,$role,$end,$start,'',$selfenroll,$context);
      if ($result eq 'ok') {
          &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
      }
- Line 5171  sub devalidate_getgroups_cache {
+ Line 6453  sub devalidate_getgroups_cache {
  # ------------------------------------------------------------------ Plain Text
  sub plaintext {
-     my ($short,$type,$cid) = @_;
+     my ($short,$type,$cid,$forcedefault) = @_;
-     if ($short =~ /^cr/) {
+     if ($short =~ m{^cr/}) {
  	return (split('/',$short))[-1];
      }
      if (!defined($cid)) {
          $cid = $env{'request.course.id'};
      }
-     if (defined($cid) && defined($env{'course.'.$cid.'.'.$short.'.plaintext'})) {
-         return &Apache::lonlocal::mt($env{'course.'.$cid.'.'.$short.
-                                           '.plaintext'});
-     }
      my %rolenames = (
-                       Course => 'std',
+                       Course    => 'std',
-                       Group => 'alt1',
+                       Community => 'alt1',
                      );
-     if (defined($type) &&
+     if ($cid ne '') {
-          defined($rolenames{$type}) &&
+         if ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '') {
-          defined($prp{$short}{$rolenames{$type}})) {
+             unless ($forcedefault) {
+                 my $roletext = $env{'course.'.$cid.'.'.$short.'.plaintext'};
+                 &Apache::lonlocal::mt_escape(\$roletext);
+                 return &Apache::lonlocal::mt($roletext);
+             }
+         }
+     }
+     if ((defined($type)) && (defined($rolenames{$type})) &&
+         (defined($rolenames{$type})) &&
+         (defined($prp{$short}{$rolenames{$type}}))) {
          return &Apache::lonlocal::mt($prp{$short}{$rolenames{$type}});
-     } else {
+     } elsif ($cid ne '') {
-         return &Apache::lonlocal::mt($prp{$short}{'std'});
+         my $crstype = $env{'course.'.$cid.'.type'};
+         if (($crstype ne '') && (defined($rolenames{$crstype})) &&
+             (defined($prp{$short}{$rolenames{$crstype}}))) {
+             return &Apache::lonlocal::mt($prp{$short}{$rolenames{$crstype}});
+         }
      }
+     return &Apache::lonlocal::mt($prp{$short}{'std'});
  }
  # ----------------------------------------------------------------- Assign Role
  sub assignrole {
-     my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_;
+     my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,
+         $context)=@_;
      my $mrole;
      if ($role =~ /^cr\//) {
          my $cwosec=$url;
          $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
  	unless (&allowed('ccr',$cwosec)) {
-            &logthis('Refused custom assignrole: '.
+            my $refused = 1;
-              $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
+            if ($context eq 'requestcourses') {
- 		    $env{'user.name'}.' at '.$env{'user.domain'});
+                if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {
-            return 'refused';
+                    if ($role =~ m{^cr/($match_domain)/($match_username)/([^/]+)$}) {
+                        if (($1 eq $env{'user.domain'}) && ($2 eq $env{'user.name'})) {
+                            my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
+                            my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
+                            if ($crsenv{'internal.courseowner'} eq
+                                $env{'user.name'}.':'.$env{'user.domain'}) {
+                                $refused = '';
+                            }
+                        }
+                    }
+                }
+            }
+            if ($refused) {
+                &logthis('Refused custom assignrole: '.
+                         $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.
+                         ' by '.$env{'user.name'}.' at '.$env{'user.domain'});
+                return 'refused';
+            }
          }
          $mrole='cr';
      } elsif ($role =~ /^gr\//) {
- Line 5223  sub assignrole {
+ Line 6533  sub assignrole {
      } else {
          my $cwosec=$url;
          $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
-         unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) {
+         if (!(&allowed('c'.$role,$cwosec)) && !(&allowed('c'.$role,$udom))) {
-            &logthis('Refused assignrole: '.
+             my $refused;
-              $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
+             if (($env{'request.course.sec'}  ne '') && ($role eq 'st')) {
- 		    $env{'user.name'}.' at '.$env{'user.domain'});
+                 if (!(&allowed('c'.$role,$url))) {
-            return 'refused';
+                     $refused = 1;
+                 }
+             } else {
+                 $refused = 1;
+             }
+             if ($refused) {
+                 my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
+                 if (!$selfenroll && $context eq 'course') {
+                     my %crsenv;
+                     if ($role eq 'cc' || $role eq 'co') {
+                         %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
+                         if (($role eq 'cc') && ($cnum !~ /^$match_community$/)) {
+                             if ($env{'request.role'} eq 'cc./'.$cdom.'/'.$cnum) {
+                                 if ($crsenv{'internal.courseowner'} eq
+                                     $env{'user.name'}.':'.$env{'user.domain'}) {
+                                     $refused = '';
+                                 }
+                             }
+                         } elsif (($role eq 'co') && ($cnum =~ /^$match_community$/)) {
+                             if ($env{'request.role'} eq 'co./'.$cdom.'/'.$cnum) {
+                                 if ($crsenv{'internal.courseowner'} eq
+                                     $env{'user.name'}.':'.$env{'user.domain'}) {
+                                     $refused = '';
+                                 }
+                             }
+                         }
+                     }
+                 } elsif (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
+                     $refused = '';
+                 } elsif ($context eq 'requestcourses') {
+                     my @possroles = ('st','ta','ep','in','cc','co');
+                     if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {
+                         my $wrongcc;
+                         if ($cnum =~ /^$match_community$/) {
+                             $wrongcc = 1 if ($role eq 'cc');
+                         } else {
+                             $wrongcc = 1 if ($role eq 'co');
+                         }
+                         unless ($wrongcc) {
+                             my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
+                             if ($crsenv{'internal.courseowner'} eq
+                                  $env{'user.name'}.':'.$env{'user.domain'}) {
+                                 $refused = '';
+                             }
+                         }
+                     }
+                 }
+                 if ($refused) {
+                     &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
+                              ' '.$role.' '.$end.' '.$start.' by '.
+ 	  	             $env{'user.name'}.' at '.$env{'user.domain'});
+                     return 'refused';
+                 }
+             }
          }
          $mrole=$role;
      }
- Line 5243  sub assignrole {
+ Line 6606  sub assignrole {
      }
      my $origstart = $start;
      my $origend = $end;
+     my $delflag;
  # actually delete
      if ($deleteflag) {
  	if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) {
- Line 5253  sub assignrole {
+ Line 6617  sub assignrole {
  # set start and finish to negative values for userrolelog
             $start=-1;
             $end=-1;
+            $delflag = 1;
          }
      }
  # send command
- Line 5261  sub assignrole {
+ Line 6626  sub assignrole {
      if ($answer eq 'ok') {
  	&userrolelog($role,$uname,$udom,$url,$start,$end);
  # for course roles, perform group memberships changes triggered by role change.
+         &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,$selfenroll,$context);
          unless ($role =~ /^gr/) {
              &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
-                                              $origstart);
+                                              $origstart,$selfenroll,$context);
+         }
+         if ($role eq 'cc') {
+             &autoupdate_coowners($url,$end,$start,$uname,$udom);
          }
      }
      return $answer;
  }
+ sub autoupdate_coowners {
+     my ($url,$end,$start,$uname,$udom) = @_;
+     my ($cdom,$cnum) = ($url =~ m{^/($match_domain)/($match_courseid)});
+     if (($cdom ne '') && ($cnum ne '')) {
+         my $now = time;
+         my %domdesign = &Apache::loncommon::get_domainconf($cdom);
+         if ($domdesign{$cdom.'.autoassign.co-owners'}) {
+             my %coursehash = &coursedescription($cdom.'_'.$cnum);
+             my $instcode = $coursehash{'internal.coursecode'};
+             if ($instcode ne '') {
+                 if (($start && $start <= $now) && ($end == 0) || ($end > $now)) {
+                     unless ($coursehash{'internal.courseowner'} eq $uname.':'.$udom) {
+                         my ($delcoowners,@newcoowners,$putresult,$delresult,$coowners);
+                         my ($result,$desc) = &auto_validate_instcode($cnum,$cdom,$instcode,$uname.':'.$udom);
+                         if ($result eq 'valid') {
+                             if ($coursehash{'internal.co-owners'}) {
+                                 foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
+                                     push(@newcoowners,$coowner);
+                                 }
+                                 unless (grep(/^\Q$uname\E:\Q$udom\E$/,@newcoowners)) {
+                                     push(@newcoowners,$uname.':'.$udom);
+                                 }
+                                 @newcoowners = sort(@newcoowners);
+                             } else {
+                                 push(@newcoowners,$uname.':'.$udom);
+                             }
+                         } else {
+                             if ($coursehash{'internal.co-owners'}) {
+                                 foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
+                                     unless ($coowner eq $uname.':'.$udom) {
+                                         push(@newcoowners,$coowner);
+                                     }
+                                 }
+                                 unless (@newcoowners > 0) {
+                                     $delcoowners = 1;
+                                     $coowners = '';
+                                 }
+                             }
+                         }
+                         if (@newcoowners || $delcoowners) {
+                             &store_coowners($cdom,$cnum,$coursehash{'home'},
+                                             $delcoowners,@newcoowners);
+                         }
+                     }
+                 }
+             }
+         }
+     }
+ }
+ sub store_coowners {
+     my ($cdom,$cnum,$chome,$delcoowners,@newcoowners) = @_;
+     my $cid = $cdom.'_'.$cnum;
+     my ($coowners,$delresult,$putresult);
+     if (@newcoowners) {
+         $coowners = join(',',@newcoowners);
+         my %coownershash = (
+                             'internal.co-owners' => $coowners,
+                            );
+         $putresult = &put('environment',\%coownershash,$cdom,$cnum);
+         if ($putresult eq 'ok') {
+             if ($env{'course.'.$cid.'.num'} eq $cnum) {
+                 &appenv({'course.'.$cid.'.internal.co-owners' => $coowners});
+             }
+         }
+     }
+     if ($delcoowners) {
+         $delresult = &Apache::lonnet::del('environment',['internal.co-owners'],$cdom,$cnum);
+         if ($delresult eq 'ok') {
+             if ($env{'course.'.$cid.'.internal.co-owners'}) {
+                 &Apache::lonnet::delenv('course.'.$cid.'.internal.co-owners');
+             }
+         }
+     }
+     if (($putresult eq 'ok') || ($delresult eq 'ok')) {
+         my %crsinfo =
+             &Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.');
+         if (ref($crsinfo{$cid}) eq 'HASH') {
+             $crsinfo{$cid}{'co-owners'} = \@newcoowners;
+             my $cidput = &Apache::lonnet::courseidput($cdom,\%crsinfo,$chome,'notime');
+         }
+     }
+ }
  # -------------------------------------------------- Modify user authentication
  # Overrides without validation
- Line 5301  sub modifyuser {
+ Line 6754  sub modifyuser {
      my ($udom,    $uname, $uid,
          $umode,   $upass, $first,
          $middle,  $last,  $gene,
-         $forceid, $desiredhome, $email)=@_;
+         $forceid, $desiredhome, $email, $inststatus, $candelete)=@_;
      $udom= &LONCAPA::clean_domain($udom);
      $uname=&LONCAPA::clean_username($uname);
+     my $showcandelete = 'none';
+     if (ref($candelete) eq 'ARRAY') {
+         if (@{$candelete} > 0) {
+             $showcandelete = join(', ',@{$candelete});
+         }
+     }
      &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
               $umode.', '.$first.', '.$middle.', '.
- 	     $last.', '.$gene.'(forceid: '.$forceid.')'.
+              $last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$showcandelete.')'.
               (defined($desiredhome) ? ' desiredhome = '.$desiredhome :
                                       ' desiredhome not specified').
               ' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
               ' in domain '.$env{'request.role.domain'});
      my $uhome=&homeserver($uname,$udom,'true');
+     my $newuser;
+     if ($uhome eq 'no_host') {
+         $newuser = 1;
+     }
  # ----------------------------------------------------------------- Create User
      if (($uhome eq 'no_host') &&
  	(($umode && $upass) || ($umode eq 'localauth'))) {
- Line 5362  sub modifyuser {
+ Line 6825  sub modifyuser {
  # -------------------------------------------------------------- Add names, etc
      my @tmp=&get('environment',
  		   ['firstname','middlename','lastname','generation','id',
-                     'permanentemail'],
+                     'permanentemail','inststatus'],
  		   $udom,$uname);
-     my %names;
+     my (%names,%oldnames);
      if ($tmp[0] =~ m/^error:.*/) {
          %names=();
      } else {
          %names = @tmp;
+         %oldnames = %names;
      }
  #
- # Make sure to not trash student environment if instructor does not bother
+ # If name, email and/or uid are blank (e.g., because an uploaded file
- # to supply name and email information
+ # of users did not contain them), do not overwrite existing values
- #
+ # unless field is in $candelete array ref.
+ #
+     my @fields = ('firstname','middlename','lastname','generation',
+                   'permanentemail','id');
+     my %newvalues;
+     if (ref($candelete) eq 'ARRAY') {
+         foreach my $field (@fields) {
+             if (grep(/^\Q$field\E$/,@{$candelete})) {
+                 if ($field eq 'firstname') {
+                     $names{$field} = $first;
+                 } elsif ($field eq 'middlename') {
+                     $names{$field} = $middle;
+                 } elsif ($field eq 'lastname') {
+                     $names{$field} = $last;
+                 } elsif ($field eq 'generation') {
+                     $names{$field} = $gene;
+                 } elsif ($field eq 'permanentemail') {
+                     $names{$field} = $email;
+                 } elsif ($field eq 'id') {
+                     $names{$field}  = $uid;
+                 }
+             }
+         }
+     }
      if ($first)  { $names{'firstname'}  = $first; }
      if (defined($middle)) { $names{'middlename'} = $middle; }
      if ($last)   { $names{'lastname'}   = $last; }
      if (defined($gene))   { $names{'generation'} = $gene; }
      if ($email) {
         $email=~s/[^\w\@\.\-\,]//gs;
-        if ($email=~/\@/) { $names{'notification'} = $email;
+        if ($email=~/\@/) { $names{'permanentemail'} = $email; }
- 			   $names{'critnotification'} = $email;
- 			   $names{'permanentemail'} = $email; }
      }
      if ($uid) { $names{'id'}  = $uid; }
+     if (defined($inststatus)) {
+         $names{'inststatus'} = '';
+         my ($usertypes,$typesorder) = &retrieve_inst_usertypes($udom);
+         if (ref($usertypes) eq 'HASH') {
+             my @okstatuses;
+             foreach my $item (split(/:/,$inststatus)) {
+                 if (defined($usertypes->{$item})) {
+                     push(@okstatuses,$item);
+                 }
+             }
+             if (@okstatuses) {
+                 $names{'inststatus'} = join(':', map { &escape($_); } @okstatuses);
+             }
+         }
+     }
+     my $logmsg = $udom.', '.$uname.', '.$uid.', '.
+                  $umode.', '.$first.', '.$middle.', '.
+                  $last.', '.$gene.', '.$email.', '.$inststatus;
+     if ($env{'user.name'} ne '' && $env{'user.domain'}) {
+         $logmsg .= ' by '.$env{'user.name'}.' at '.$env{'user.domain'};
+     } else {
+         $logmsg .= ' during self creation';
+     }
+     my $changed;
+     if ($newuser) {
+         $changed = 1;
+     } else {
+         foreach my $field (@fields) {
+             if ($names{$field} ne $oldnames{$field}) {
+                 $changed = 1;
+                 last;
+             }
+         }
+     }
+     unless ($changed) {
+         $logmsg = 'No changes in user information needed for: '.$logmsg;
+         &logthis($logmsg);
+         return 'ok';
+     }
      my $reply = &put('environment', \%names, $udom,$uname);
-     if ($reply ne 'ok') { return 'error: '.$reply; }
+     if ($reply ne 'ok') {
+         return 'error: '.$reply;
+     }
      my $sqlresult = &update_allusers_table($uname,$udom,\%names);
      &devalidate_cache_new('namescache',$uname.':'.$udom);
-     &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
+     $logmsg = 'Success modifying user '.$logmsg;
-              $umode.', '.$first.', '.$middle.', '.
+     &logthis($logmsg);
- 	     $last.', '.$gene.' by '.
-              $env{'user.name'}.' at '.$env{'user.domain'});
      return 'ok';
  }
- Line 5400  sub modifyuser {
+ Line 6925  sub modifyuser {
  sub modifystudent {
      my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
-         $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_;
+         $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid,
+         $selfenroll,$context,$inststatus)=@_;
      if (!$cid) {
  	unless ($cid=$env{'request.course.id'}) {
  	    return 'not_in_class';
- Line 5409  sub modifystudent {
+ Line 6935  sub modifystudent {
  # --------------------------------------------------------------- Make the user
      my $reply=&modifyuser
  	($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,
-          $desiredhome,$email);
+          $desiredhome,$email,$inststatus);
      unless ($reply eq 'ok') { return $reply; }
      # This will cause &modify_student_enrollment to get the uid from the
      # students environment
      $uid = undef if (!$forceid);
      $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
- 					$gene,$usec,$end,$start,$type,$locktype,$cid);
+ 					$gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context);
      return $reply;
  }
  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,$context) = @_;
      my ($cdom,$cnum,$chome);
      if (!$cid) {
  	unless ($cid=$env{'request.course.id'}) {
- Line 5478  sub modify_student_enrollment {
+ Line 7004  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,$context);
  }
  sub format_name {
- Line 5523  sub writecoursepref {
+ Line 7049  sub writecoursepref {
  sub createcourse {
      my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
-         $course_owner,$crstype)=@_;
+         $course_owner,$crstype,$cnum,$context,$category)=@_;
      $url=&declutter($url);
      my $cid='';
-     unless (&allowed('ccc',$udom)) {
+     if ($context eq 'requestcourses') {
+         my $can_create = 0;
+         my ($ownername,$ownerdom) = split(':',$course_owner);
+         if ($udom eq $ownerdom) {
+             if (&usertools_access($ownername,$ownerdom,$category,undef,
+                                   $context)) {
+                 $can_create = 1;
+             }
+         } else {
+             my %userenv = &userenvironment($ownerdom,$ownername,'reqcrsotherdom.'.
+                                            $category);
+             if ($userenv{'reqcrsotherdom.'.$category} ne '') {
+                 my @curr = split(',',$userenv{'reqcrsotherdom.'.$category});
+                 if (@curr > 0) {
+                     my @options = qw(approval validate autolimit);
+                     my $optregex = join('|',@options);
+                     if (grep(/^\Q$udom\E:($optregex)(=?\d*)$/,@curr)) {
+                         $can_create = 1;
+                     }
+                 }
+             }
+         }
+         if ($can_create) {
+             unless ($ownername eq $env{'user.name'} && $ownerdom eq $env{'user.domain'}) {
+                 unless (&allowed('ccc',$udom)) {
+                     return 'refused';
+                 }
+             }
+         } else {
+             return 'refused';
+         }
+     } elsif (!&allowed('ccc',$udom)) {
          return 'refused';
      }
- # ------------------------------------------------------------------- Create ID
+ # --------------------------------------------------------------- Get Unique ID
-    my $uname=int(1+rand(9)).
+     my $uname;
-        ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
+     if ($cnum =~ /^$match_courseid$/) {
-        substr($$.time,0,5).unpack("H8",pack("I32",time)).
+         my $chome=&homeserver($cnum,$udom,'true');
-        unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
+         if (($chome eq '') || ($chome eq 'no_host')) {
- # ----------------------------------------------- Make sure that does not exist
+             $uname = $cnum;
-    my $uhome=&homeserver($uname,$udom,'true');
+         } else {
-    unless (($uhome eq '') || ($uhome eq 'no_host')) {
+             $uname = &generate_coursenum($udom,$crstype);
-        $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
+         }
-         unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
+     } else {
-        $uhome=&homeserver($uname,$udom,'true');
+         $uname = &generate_coursenum($udom,$crstype);
-        unless (($uhome eq '') || ($uhome eq 'no_host')) {
+     }
-            return 'error: unable to generate unique course-ID';
+     return $uname if ($uname =~ /^error/);
-        }
+ # -------------------------------------------------- Check supplied server name
-    }
+     if (!defined($course_server)) {
- # ------------------------------------------------ Check supplied server name
+         if (defined(&domain($udom,'primary'))) {
-     $course_server = $env{'user.homeserver'} if (! defined($course_server));
+             $course_server = &domain($udom,'primary');
-     if (! &is_library($course_server)) {
+         } else {
-         return 'error:bad server name '.$course_server;
+             $course_server = $env{'user.home'};
+         }
+     }
+     my %host_servers =
+         &Apache::lonnet::get_servers($udom,'library');
+     unless ($host_servers{$course_server}) {
+         return 'error: invalid home server for course: '.$course_server;
      }
  # ------------------------------------------------------------- Make the course
      my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
                        $course_server);
      unless ($reply eq 'ok') { return 'error: '.$reply; }
-     $uhome=&homeserver($uname,$udom,'true');
+     my $uhome=&homeserver($uname,$udom,'true');
      if (($uhome eq '') || ($uhome eq 'no_host')) {
  	return 'error: no such course';
      }
  # ----------------------------------------------------------------- Course made
  # log existence
+     my $now = time;
      my $newcourse = {
                      $udom.'_'.$uname => {
                                       description => $description,
                                       inst_code   => $inst_code,
                                       owner       => $course_owner,
                                       type        => $crstype,
+                                      creator     => $env{'user.name'}.':'.
+                                                     $env{'user.domain'},
+                                      created     => $now,
+                                      context     => $context,
                                                  },
                      };
      &courseidput($udom,$newcourse,$uhome,'notime');
- Line 5589  ENDINITMAP
+ Line 7157  ENDINITMAP
      }
  # ----------------------------------------------------------- Write preferences
      &writecoursepref($udom.'_'.$uname,
-                      ('description' => $description,
+                      ('description'              => $description,
-                       'url'         => $topurl));
+                       'url'                      => $topurl,
+                       'internal.creator'         => $env{'user.name'}.':'.
+                                                     $env{'user.domain'},
+                       'internal.created'         => $now,
+                       'internal.creationcontext' => $context)
+                     );
      return '/'.$udom.'/'.$uname;
  }
+ # ------------------------------------------------------------------- Create ID
+ sub generate_coursenum {
+     my ($udom,$crstype) = @_;
+     my $domdesc = &domain($udom);
+     return 'error: invalid domain' if ($domdesc eq '');
+     my $first;
+     if ($crstype eq 'Community') {
+         $first = '0';
+     } else {
+         $first = int(1+rand(9));
+     }
+     my $uname=$first.
+         ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
+         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,'true');
+     unless (($uhome eq '') || ($uhome eq 'no_host')) {
+         if ($crstype eq 'Community') {
+             $first = '0';
+         } else {
+             $first = int(1+rand(9));
+         }
+         $uname=$first.
+                ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
+                substr($$.time,0,5).unpack("H8",pack("I32",time)).
+                unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
+         $uhome=&homeserver($uname,$udom,'true');
+         unless (($uhome eq '') || ($uhome eq 'no_host')) {
+             return 'error: unable to generate unique course-ID';
+         }
+     }
+     return $uname;
+ }
  sub is_course {
      my ($cdom,$cnum) = @_;
      my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,
- 				undef,'.',undef,1);
+ 				undef,'.');
      if (exists($courses{$cdom.'_'.$cnum})) {
          return 1;
      }
      return 0;
  }
+ sub store_userdata {
+     my ($storehash,$datakey,$namespace,$udom,$uname) = @_;
+     my $result;
+     if ($datakey ne '') {
+         if (ref($storehash) eq 'HASH') {
+             if ($udom eq '' || $uname eq '') {
+                 $udom = $env{'user.domain'};
+                 $uname = $env{'user.name'};
+             }
+             my $uhome=&homeserver($uname,$udom);
+             if (($uhome eq '') || ($uhome eq 'no_host')) {
+                 $result = 'error: no_host';
+             } else {
+                 $storehash->{'ip'} = $ENV{'REMOTE_ADDR'};
+                 $storehash->{'host'} = $perlvar{'lonHostID'};
+                 my $namevalue='';
+                 foreach my $key (keys(%{$storehash})) {
+                     $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
+                 }
+                 $namevalue=~s/\&$//;
+                 $result =  &reply("store:$env{'user.domain'}:$env{'user.name'}:".
+                                   "$namespace:$datakey:$namevalue",$uhome);
+             }
+         } else {
+             $result = 'error: data to store was not a hash reference';
+         }
+     } else {
+         $result= 'error: invalid requestkey';
+     }
+     return $result;
+ }
  # ---------------------------------------------------------- Assign Custom Role
  sub assigncustomrole {
-     my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag)=@_;
+     my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag,$selfenroll,$context)=@_;
      return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
-                        $end,$start,$deleteflag);
+                        $end,$start,$deleteflag,$selfenroll,$context);
  }
  # ----------------------------------------------------------------- Revoke Role
  sub revokerole {
-     my ($udom,$uname,$url,$role,$deleteflag)=@_;
+     my ($udom,$uname,$url,$role,$deleteflag,$selfenroll,$context)=@_;
      my $now=time;
-     return &assignrole($udom,$uname,$url,$role,$now,$deleteflag);
+     return &assignrole($udom,$uname,$url,$role,$now,undef,$deleteflag,$selfenroll,$context);
  }
  # ---------------------------------------------------------- Revoke Custom Role
  sub revokecustomrole {
-     my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag)=@_;
+     my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag,$selfenroll,$context)=@_;
      my $now=time;
      return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now,
-            $deleteflag);
+            $deleteflag,$selfenroll,$context);
  }
  # ------------------------------------------------------------ Disk usage
  sub diskusage {
-     my ($udom,$uname,$directoryRoot)=@_;
+     my ($udom,$uname,$directorypath,$getpropath)=@_;
-     $directoryRoot =~ s/\/$//;
+     $directorypath =~ s/\/$//;
-     my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom));
+     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;
  }
- Line 5874  sub modify_access_controls {
+ Line 7523  sub modify_access_controls {
                  }
              }
          }
+         my ($group);
+         if (&is_course($domain,$user)) {
+             ($group,my $file) = split(/\//,$file_name,2);
+         }
          $deloutcome = &del('file_permissions',\@deletions,$domain,$user);
          $new_values{$file_name."\0".'accesscontrol'} = \%new_control;
          $outcome = &put('file_permissions',\%new_values,$domain,$user);
          #  remove lock
          my @del_lock = ($file_name."\0".'locked_access_records');
          my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user);
-         my ($file,$group);
-         if (&is_course($domain,$user)) {
-             ($group,$file) = split(/\//,$file_name,2);
-         } else {
-             $file = $file_name;
-         }
          my $sqlresult =
-             &update_portfolio_table($user,$domain,$file,'portfolio_access',
+             &update_portfolio_table($user,$domain,$file_name,'portfolio_access',
                                      $group);
      } else {
          $outcome = "error: could not obtain lockfile\n";
- Line 6050  sub unmark_as_readonly {
+ Line 7697  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 ($getuserdir) {
-     if(defined($userdomain)) {
          $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'};
+     $dirRoot = $perlvar{'lonDocRoot'};
-     if(defined($alternateDirectoryRoot)) {
+     if (defined($getpropath)) {
-         $dirRoot = $alternateDirectoryRoot;
+         $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,
+             $listing = &reply('ls3:'.&escape('/'.$uri).':'.$getpropath.':'
- 				 &homeserver($uname,$udom));
+                               .$getuserdir.':'.&escape($dirRoot)
-             my @listing_results;
+                               .':'.&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));
- Line 6082  sub dirlist {
+ Line 7748  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)) {
+  	    foreach my $tryserver (keys(%servers)) {
- 		my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.
+                 $listing = &reply('ls3:'.&escape("/res/$udom").':::::'.
- 				     $udom, $tryserver);
+                                   &escape($udom),$tryserver);
- 		my @listing_results;
+                 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);
- Line 6115  sub dirlist {
+ Line 7786  sub dirlist {
          } else {
              return ('missing user name');
          }
-     } elsif(!defined($alternateDirectoryRoot)) {
+     } elsif(!defined($getpropath)) {
          my @all_domains = sort(&all_domains());
-          foreach my $domain (@all_domains) {
+         foreach my $domain (@all_domains) {
-              $domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain';
+             $domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain';
-          }
+         }
-          return @all_domains;
+         return @all_domains;
-      } else {
+     } else {
          return ('missing domain');
      }
  }
- Line 6131  sub dirlist {
+ Line 7802  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.'__';
+     my ($fileStat) =
-     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
+         &Apache::lonnet::dirlist($filename,$studentDomain,$studentName,
-     my $proname="$studentDomain/$subdir/$studentName";
+                                  undef,$getuserdir);
-     $proname .= '/'.$filename;
-     my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain,
-                                               $studentName, $root);
      my @stats = split('&', $fileStat);
      if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
          # @stats contains first the filename, then the stat output
- Line 6161  sub stat_file {
+ Line 7822  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) =
- Line 6178  sub stat_file {
+ Line 7838  sub stat_file {
  	# unable to handle the uri
  	return ();
      }
+     my $getpropath;
-     my ($result) = &dirlist($file,$udom,$uname,$dir);
+     if ($file =~ /^userfiles\//) {
+         $getpropath = 1;
+     }
+     my ($result) = &dirlist($file,$udom,$uname,$getpropath);
      my @stats = split('&', $result);
      if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
- Line 6212  sub directcondval {
+ Line 7875  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'}}) {
- Line 6369  sub resdata {
+ Line 8032  sub resdata {
      }
      if (!ref($result)) { return $result; }
      foreach my $item (@which) {
- 	if (defined($result->{$item})) {
+ 	if (defined($result->{$item->[0]})) {
- 	    return $result->{$item};
+ 	    return [$result->{$item->[0]},$item->[1]];
  	}
      }
      return undef;
- Line 6398  sub EXT_cache_status {
+ Line 8061  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
- Line 6582  sub EXT {
+ Line 8245  sub EXT {
  # ----------------------------------------------------------- first, check user
  	    my $userreply=&resdata($uname,$udom,'user',
- 				       ($courselevelr,$courselevelm,
+ 				       ([$courselevelr,'resource'],
- 					$courselevel));
+ 					[$courselevelm,'map'     ],
- 	    if (defined($userreply)) { return $userreply; }
+ 					[$courselevel, 'course'  ]));
+ 	    if (defined($userreply)) { return &get_reply($userreply); }
  # ------------------------------------------------ second, check some of course
              my $coursereply;
              if (@groups > 0) {
                  $coursereply = &check_group_parms($courseid,\@groups,$symbparm,
                                         $mapparm,$spacequalifierrest);
-                 if (defined($coursereply)) { return $coursereply; }
+                 if (defined($coursereply)) { return &get_reply($coursereply); }
              }
  	    $coursereply=&resdata($env{'course.'.$courseid.'.num'},
- 				     $env{'course.'.$courseid.'.domain'},
+ 				  $env{'course.'.$courseid.'.domain'},
- 				     'course',
+ 				  'course',
- 				     ($seclevelr,$seclevelm,$seclevel,
+ 				  ([$seclevelr,   'resource'],
- 				      $courselevelr));
+ 				   [$seclevelm,   'map'     ],
- 	    if (defined($coursereply)) { return $coursereply; }
+ 				   [$seclevel,    'course'  ],
+ 				   [$courselevelr,'resource']));
+ 	    if (defined($coursereply)) { return &get_reply($coursereply); }
  # ------------------------------------------------------ third, check map parms
  	    my %parmhash=();
- Line 6610  sub EXT {
+ Line 8276  sub EXT {
  		$thisparm=$parmhash{$symbparm};
  		untie(%parmhash);
  	    }
- 	    if ($thisparm) { return $thisparm; }
+ 	    if ($thisparm) { return &get_reply([$thisparm,'resource']); }
  	}
  # ------------------------------------------ fourth, look in resource metadata
- Line 6623  sub EXT {
+ Line 8289  sub EXT {
  	    $filename=$env{'request.filename'};
  	}
  	my $metadata=&metadata($filename,$spacequalifierrest);
- 	if (defined($metadata)) { return $metadata; }
+ 	if (defined($metadata)) { return &get_reply([$metadata,'resource']); }
  	$metadata=&metadata($filename,'parameter_'.$spacequalifierrest);
- 	if (defined($metadata)) { return $metadata; }
+ 	if (defined($metadata)) { return &get_reply([$metadata,'resource']); }
- # ---------------------------------------------- fourth, look in rest pf course
+ # ---------------------------------------------- fourth, look in rest of course
  	if ($symbparm && defined($courseid) &&
  	    $courseid eq $env{'request.course.id'}) {
  	    my $coursereply=&resdata($env{'course.'.$courseid.'.num'},
  				     $env{'course.'.$courseid.'.domain'},
  				     'course',
- 				     ($courselevelm,$courselevel));
+ 				     ([$courselevelm,'map'   ],
- 	    if (defined($coursereply)) { return $coursereply; }
+ 				      [$courselevel, 'course']));
+ 	    if (defined($coursereply)) { return &get_reply($coursereply); }
  	}
  # ------------------------------------------------------------------ Cascade up
  	unless ($space eq '0') {
- Line 6642  sub EXT {
+ Line 8309  sub EXT {
  	    my $id=pop(@parts);
  	    my $part=join('_',@parts);
  	    if ($part eq '') { $part='0'; }
- 	    my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
+ 	    my @partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
  				 $symbparm,$udom,$uname,$section,1);
- 	    if (defined($partgeneral)) { return $partgeneral; }
+ 	    if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); }
  	}
  	if ($recurse) { return undef; }
  	my $pack_def=&packages_tab_default($filename,$varname);
- 	if (defined($pack_def)) { return $pack_def; }
+ 	if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); }
  # ---------------------------------------------------- Any other user namespace
      } elsif ($realm eq 'environment') {
  # ----------------------------------------------------------------- environment
- Line 6677  sub EXT {
+ Line 8343  sub EXT {
      return '';
  }
+ sub get_reply {
+     my ($reply_value) = @_;
+     if (ref($reply_value) eq 'ARRAY') {
+         if (wantarray) {
+ 	    return @$reply_value;
+         }
+         return $reply_value->[0];
+     } else {
+         return $reply_value;
+     }
+ }
  sub check_group_parms {
      my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;
      my @groupitems = ();
      my $resultitem;
-     my @levels = ($symbparm,$mapparm,$what);
+     my @levels = ([$symbparm,'resource'],[$mapparm,'map'],[$what,'course']);
      foreach my $group (@{$groups}) {
          foreach my $level (@levels) {
-              my $item = $courseid.'.['.$group.'].'.$level;
+              my $item = $courseid.'.['.$group.'].'.$level->[0];
-              push(@groupitems,$item);
+              push(@groupitems,[$item,$level->[1]]);
          }
      }
      my $coursereply = &resdata($env{'course.'.$courseid.'.num'},
- Line 6778  sub metadata {
+ Line 8456  sub metadata {
      if (($uri eq '') ||
  	(($uri =~ m|^/*adm/|) &&
  	     ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||
-         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||
+         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) ) {
- 	($uri =~ m|home/$match_username/public_html/|)) {
+ 	return undef;
+     }
+     if (($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/})
+ 	&& &Apache::lonxml::get_state('target') =~ /^(|meta)$/) {
  	return undef;
      }
      my $filename=$uri;
- Line 6800  sub metadata {
+ Line 8481  sub metadata {
  #	if (! exists($metacache{$uri})) {
  #	    $metacache{$uri}={};
  #	}
+ 	my $cachetime = 60*60;
          if ($liburi) {
  	    $liburi=&declutter($liburi);
              $filename=$liburi;
- Line 6810  sub metadata {
+ Line 8492  sub metadata {
          my %metathesekeys=();
          unless ($filename=~/\.meta$/) { $filename.='.meta'; }
  	my $metastring;
- 	if ($uri !~ m -^(editupload)/-) {
+ 	if ($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/}) {
+ 	    my $which = &hreflocation('','/'.($liburi || $uri));
+ 	    $metastring =
+ 		&Apache::lonnet::ssi_body($which,
+ 					  ('grade_target' => 'meta'));
+ 	    $cachetime = 1; # only want this cached in the child not long term
+ 	} elsif ($uri !~ m -^(editupload)/-) {
  	    my $file=&filelocation('',&clutter($filename));
  	    #push(@{$metaentry{$uri.'.file'}},$file);
  	    $metastring=&getfile($file);
- Line 6900  sub metadata {
+ Line 8588  sub metadata {
  			    }
  			}
  		    } else {
  			if (defined($token->[2]->{'name'})) {
  			    $unikey.='_'.$token->[2]->{'name'};
  			}
- Line 6977  sub metadata {
+ Line 8664  sub metadata {
  	$metaentry{':keys'} = join(',',keys(%metathesekeys));
  	&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
  	$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
- 	&do_cache_new('meta',$uri,\%metaentry,60*60);
+ 	&do_cache_new('meta',$uri,\%metaentry,$cachetime);
  # this is the end of "was not already recently cached
      }
      return $metaentry{':'.$what};
- Line 7046  sub devalidate_title_cache {
+ Line 8733  sub devalidate_title_cache {
      &devalidate_cache_new('title',$key);
  }
+ # ------------------------------------------------- Get the title of a course
+ sub current_course_title {
+     return $env{ 'course.' . $env{'request.course.id'} . '.description' };
+ }
  # ------------------------------------------------- Get the title of a resource
  sub gettitle {
- Line 7112  sub symblist {
+ Line 8804  sub symblist {
      if (($env{'request.course.fn'}) && (%newhash)) {
          if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
                        &GDBM_WRCREAT(),0640)) {
- 	    foreach my $url (keys %newhash) {
+ 	    foreach my $url (keys(%newhash)) {
  		next if ($url eq 'last_known'
  			 && $env{'form.no_update_last_known'});
  		$hash{declutter($url)}=&encode_symb($mapname,
- Line 7149  sub symbverify {
+ Line 8841  sub symbverify {
      if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
                              &GDBM_READER(),0640)) {
+         if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) {
+             $thisurl =~ s/\?.+$//;
+         }
          my $ids=$bighash{'ids_'.&clutter($thisurl)};
          unless ($ids) {
             $ids=$bighash{'ids_/'.$thisurl};
- Line 7157  sub symbverify {
+ Line 8852  sub symbverify {
  # ------------------------------------------------------------------- Has ID(s)
  	    foreach my $id (split(/\,/,$ids)) {
  	       my ($mapid,$resid)=split(/\./,$id);
+                if ($thisfn =~ m{^/adm/wrapper/ext/}) {
+                    $symb =~ s/\?.+$//;
+                }
                 if (
    &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
     eq $symb) {
- Line 7275  sub symbread {
+ Line 8973  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;
- Line 7327  sub symbread {
+ Line 9025  sub symbread {
  	    return $env{$cache_str}=$syval;
          }
      }
-     &appenv('request.ambiguous' => $thisfn);
+     &appenv({'request.ambiguous' => $thisfn});
      return $env{$cache_str}='';
  }
- Line 7819  sub repcopy_userfile {
+ Line 9517  sub repcopy_userfile {
      if (-e $transferfile) { return 'ok'; }
      my $request;
      $uri=~s/^\///;
-     $request=new HTTP::Request('GET','http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri);
+     my $homeserver = &homeserver($cnum,$cdom);
+     my $protocol = $protocol{$homeserver};
+     $protocol = 'http' if ($protocol ne 'https');
+     $request=new HTTP::Request('GET',$protocol.'://'.&hostname($homeserver).'/raw/'.$uri);
      my $response=$ua->request($request,$transferfile);
  # did it work?
      if ($response->is_error()) {
- Line 7834  sub repcopy_userfile {
+ Line 9535  sub repcopy_userfile {
  sub tokenwrapper {
      my $uri=shift;
-     $uri=~s|^http\://([^/]+)||;
+     $uri=~s|^https?\://([^/]+)||;
      $uri=~s|^/||;
      $env{'user.environment'}=~/\/([^\/]+)\.id/;
      my $token=$1;
      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.
+         my $homeserver = &homeserver($uname,$udom);
+         my $protocol = $protocol{$homeserver};
+         $protocol = 'http' if ($protocol ne 'https');
+         return $protocol.'://'.&hostname($homeserver).'/'.$uri.
                 (($uri=~/\?/)?'&':'?').'token='.$token.
                                 '&tokenissued='.$perlvar{'lonHostID'};
      } else {
- Line 7857  sub tokenwrapper {
+ Line 9561  sub tokenwrapper {
  sub getuploaded {
      my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
      $uri=~s/^\///;
-     $uri = 'http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri;
+     my $homeserver = &homeserver($cnum,$cdom);
+     my $protocol = $protocol{$homeserver};
+     $protocol = 'http' if ($protocol ne 'https');
+     $uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri;
      my $ua=new LWP::UserAgent;
      my $request=new HTTP::Request($reqtype,$uri);
      my $response=$ua->request($request);
- Line 7899  sub filelocation {
+ Line 9606  sub filelocation {
      } elsif ($file=~m{^/home/$match_username/public_html/}) {
  	# is a correct contruction space reference
          $location = $file;
+     } elsif ($file =~ m-^\Q$Apache::lonnet::perlvar{'lonTabDir'}\E/-) {
+         $location = $file;
      } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file
          my ($udom,$uname,$filename)=
    	    ($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$-);
- Line 7907  sub filelocation {
+ Line 9616  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).
+   	    $location=&propath($udom,$uname).'/userfiles/'.$filename;
-   	      '/userfiles/'.$filename;
          } else {
    	  $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
    	      $udom.'/'.$uname.'/'.$filename;
- Line 7925  sub filelocation {
+ Line 9633  sub filelocation {
          }
      }
      $location=~s://+:/:g; # remove duplicate /
-     while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
+     while ($location=~m{/\.\./}) {
+ 	if ($location =~ m{/[^/]+/\.\./}) {
+ 	    $location=~ s{/[^/]+/\.\./}{/}g;
+ 	} else {
+ 	    $location=~ s{/\.\./}{/}g;
+ 	}
+     } #remove dir/..
      while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./
      return $location;
  }
  sub hreflocation {
      my ($dir,$file)=@_;
-     unless (($file=~m-^http://-i) || ($file=~m-^/-)) {
+     unless (($file=~m-^https?\://-i) || ($file=~m-^/-)) {
  	$file=filelocation($dir,$file);
      } elsif ($file=~m-^/adm/-) {
  	$file=~s-^/adm/wrapper/-/-;
- Line 8017  sub declutter {
+ Line 9731  sub declutter {
      $thisfn=~s|^adm/wrapper/||;
      $thisfn=~s|^adm/coursedocs/showdoc/||;
      $thisfn=~s/^res\///;
-     $thisfn=~s/\?.+$//;
+     unless (($thisfn =~ /^ext/) || ($thisfn =~ /\.(page|sequence)___\d+___ext/)) {
+         $thisfn=~s/\?.+$//;
+     }
      return $thisfn;
  }
- Line 8029  sub clutter {
+ Line 9745  sub clutter {
  	|| $thisfn =~ m{^/adm/(includes|pages)} ) {
         $thisfn='/res'.$thisfn;
      }
-     if ($thisfn !~m|/adm|) {
+     if ($thisfn !~m|^/adm|) {
- 	if ($thisfn =~ m|/ext/|) {
+ 	if ($thisfn =~ m|^/ext/|) {
  	    $thisfn='/adm/wrapper'.$thisfn;
  	} else {
  	    my ($ext) = ($thisfn =~ /\.(\w+)$/);
- Line 8128  sub get_dns {
+ Line 9844  sub get_dns {
      open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
      foreach my $dns (<$config>) {
  	next if ($dns !~ /^\^(\S*)/x);
- 	$alldns{$1} = 1;
+         my $line = $1;
+         my ($host,$protocol) = split(/:/,$line);
+         if ($protocol ne 'https') {
+             $protocol = 'http';
+         }
+ 	$alldns{$host} = $protocol;
      }
      while (%alldns) {
  	my ($dns) = keys(%alldns);
- 	delete($alldns{$dns});
  	my $ua=new LWP::UserAgent;
- 	my $request=new HTTP::Request('GET',"http://$dns$url");
+ 	my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
  	my $response=$ua->request($request);
+         delete($alldns{$dns});
  	next if ($response->is_error());
  	my @content = split("\n",$response->content);
  	&Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60);
- Line 8200  sub get_dns {
+ Line 9921  sub get_dns {
  	}
  	return $domain{$name}{$what};
      }
+     sub domain_info {
+         &load_domain_tab() if (!$loaded);
+         return %domain;
+     }
  }
- Line 8210  sub get_dns {
+ Line 9937  sub get_dns {
      my %libserv;
      my $loaded;
      my %name_to_host;
+     my %internetdom;
      sub parse_hosts_tab {
  	my ($file) = @_;
- Line 8217  sub get_dns {
+ Line 9945  sub get_dns {
  	    next if ($configline =~ /^(\#|\s*$ )/x);
  	    next if ($configline =~ /^\^/);
  	    chomp($configline);
- 	    my ($id,$domain,$role,$name)=split(/:/,$configline);
+ 	    my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline);
  	    $name=~s/\s//g;
  	    if ($id && $domain && $role && $name) {
  		$hostname{$id}=$name;
  		push(@{$name_to_host{$name}}, $id);
  		$hostdom{$id}=$domain;
  		if ($role eq 'library') { $libserv{$id}=$name; }
+                 if (defined($protocol)) {
+                     if ($protocol eq 'https') {
+                         $protocol{$id} = $protocol;
+                     } else {
+                         $protocol{$id} = 'http';
+                     }
+                 } else {
+                     $protocol{$id} = 'http';
+                 }
+                 if (defined($intdom)) {
+                     $internetdom{$id} = $intdom;
+                 }
  	    }
  	}
      }
- Line 8268  sub get_dns {
+ Line 10008  sub get_dns {
  	return %name_to_host;
      }
+     sub all_host_domain {
+         &load_hosts_tab() if (!$loaded);
+         return %hostdom;
+     }
      sub is_library {
  	&load_hosts_tab() if (!$loaded);
- Line 8280  sub get_dns {
+ Line 10025  sub get_dns {
  	return %libserv;
      }
+     sub unique_library {
+         #2x reverse removes all hostnames that appear more than once
+         my %unique = reverse &all_library();
+         return reverse %unique;
+     }
      sub get_servers {
  	&load_hosts_tab() if (!$loaded);
- Line 8303  sub get_dns {
+ Line 10054  sub get_dns {
  	return %result;
      }
+     sub get_unique_servers {
+         my %unique = reverse &get_servers(@_);
+         return reverse %unique;
+     }
      sub host_domain {
  	&load_hosts_tab() if (!$loaded);
- Line 8317  sub get_dns {
+ Line 10073  sub get_dns {
  	my @uniq = grep(!$seen{$_}++, values(%hostdom));
  	return @uniq;
      }
+     sub internet_dom {
+         &load_hosts_tab() if (!$loaded);
+         my ($lonid) = @_;
+         return $internetdom{$lonid};
+     }
  }
  {
- Line 8409  sub get_dns {
+ Line 10172  sub get_dns {
  	return %iphost;
      }
+     #
+     #  Given a DNS returns the loncapa host name for that DNS
+     #
+     sub host_from_dns {
+         my ($dns) = @_;
+         my @hosts;
+         my $ip;
+         if (exists($name_to_ip{$dns})) {
+             $ip = $name_to_ip{$dns};
+         }
+         if (!$ip) {
+             $ip = gethostbyname($dns); # Initial translation to IP is in net order.
+             if (length($ip) == 4) {
+ 	        $ip   = &IO::Socket::inet_ntoa($ip);
+             }
+         }
+         if ($ip) {
+ 	    @hosts = get_hosts_from_ip($ip);
+ 	    return $hosts[0];
+         }
+         return undef;
+     }
+     sub get_internet_names {
+         my ($lonid) = @_;
+         return if ($lonid eq '');
+         my ($idnref,$cached)=
+             &Apache::lonnet::is_cached_new('internetnames',$lonid);
+         if ($cached) {
+             return $idnref;
+         }
+         my $ip = &get_host_ip($lonid);
+         my @hosts = &get_hosts_from_ip($ip);
+         my %iphost = &get_iphost();
+         my (@idns,%seen);
+         foreach my $id (@hosts) {
+             my $dom = &host_domain($id);
+             my $prim_id = &domain($dom,'primary');
+             my $prim_ip = &get_host_ip($prim_id);
+             next if ($seen{$prim_ip});
+             if (ref($iphost{$prim_ip}) eq 'ARRAY') {
+                 foreach my $id (@{$iphost{$prim_ip}}) {
+                     my $intdom = &internet_dom($id);
+                     unless (grep(/^\Q$intdom\E$/,@idns)) {
+                         push(@idns,$intdom);
+                     }
+                 }
+             }
+             $seen{$prim_ip} = 1;
+         }
+         return &Apache::lonnet::do_cache_new('internetnames',$lonid,\@idns,12*60*60);
+     }
+ }
+ sub all_loncaparevs {
+     return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10);
  }
  BEGIN {
- Line 8486  BEGIN {
+ Line 10308  BEGIN {
      close($config);
  }
+ # ---------------------------------------------------------- Read loncaparev table
+ {
+     if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") {
+         if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) {
+             while (my $configline=<$config>) {
+                 chomp($configline);
+                 my ($hostid,$loncaparev)=split(/:/,$configline);
+                 $loncaparevs{$hostid}=$loncaparev;
+             }
+             close($config);
+         }
+     }
+ }
+ # ---------------------------------------------------------- Read serverhostID table
+ {
+     if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") {
+         if (open(my $config,"<$perlvar{'lonTabDir'}/serverhomeIDs.tab")) {
+             while (my $configline=<$config>) {
+                 chomp($configline);
+                 my ($name,$id)=split(/:/,$configline);
+                 $serverhomeIDs{$name}=$id;
+             }
+             close($config);
+         }
+     }
+ }
+ {
+     my $file = $Apache::lonnet::perlvar{'lonTabDir'}.'/releaseslist.xml';
+     if (-e $file) {
+         my $parser = HTML::LCParser->new($file);
+         while (my $token = $parser->get_token()) {
+             if ($token->[0] eq 'S') {
+                 my $item = $token->[1];
+                 my $name = $token->[2]{'name'};
+                 my $value = $token->[2]{'value'};
+                 if ($item ne '' && $name ne '' && $value ne '') {
+                     my $release = $parser->get_text();
+                     $release =~ s/(^\s*|\s*$ )//gx;
+                     $needsrelease{$item.':'.$name.':'.$value} = $release;
+                 }
+             }
+         }
+     }
+ }
  # ------------- set up temporary directory
  {
      $tmpdir = $perlvar{'lonDaemons'}.'/tmp/';
- Line 8498  $memcache=new Cache::Memcached({'servers
+ Line 10367  $memcache=new Cache::Memcached({'servers
  $processmarker='_'.time.'_'.$perlvar{'lonHostID'};
  $dumpcount=0;
+ $locknum=0;
  &logtouch();
  &logthis('<font color="yellow">INFO: Read configuration</font>');
- Line 8665  when the connection is brought back up
+ Line 10535  when the connection is brought back up
  =item * B<con_failed>: unable to contact remote host and unable to save message
  for later delivery
- =item * B<error:>: an error a occured, a description of the error follows the :
+ =item * B<error:>: an error a occurred, a description of the error follows the :
  =item * B<no_such_host>: unable to fund a host associated with the user/domain
  that was requested
- Line 8680  that was requested
+ Line 10550  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()>
- B<delenv($regexp)>: removes all items from the session
+ B<delenv($delthis,$regexp)>: removes all items from the session
- environment file that matches the regular expression in $regexp. The
+ environment file that begin with $delthis. If the
- values are also delted from the current processes %env.
+ optional second arg - $regexp - is true, $delthis is treated as a
+ regular expression, otherwise \Q$delthis\E is used.
+ The values are also deleted from the current processes %env.
  =item * get_env_multiple($name)
- Line 8711  authentication scheme
+ Line 10585  authentication scheme
  =item *
  X<authenticate()>
- B<authenticate($uname,$upass,$udom)>: try to
+ B<authenticate($uname,$upass,$udom,$checkdefauth,$clientcancheckhost)>: try to
  authenticate user from domain's lib servers (first use the current
  one). C<$upass> should be the users password.
+ $checkdefauth is optional (value is 1 if a check should be made to
+    authenticate user using default authentication method, and allow
+    account creation if username does not have account in the domain).
+ $clientcancheckhost is optional (value is 1 if checking whether the
+    server can host will occur on the client side in lonauth.pm).
  =item *
  X<homeserver()>
- Line 8786  and course level
+ Line 10665  and course level
  =item *
- plaintext($short) : return value in %prp hash (rolesplain.tab); plain text
+ plaintext($short,$type,$cid,$forcedefault) : return value in %prp hash
- explanation of a user role term
+ (rolesplain.tab); plain text explanation of a user role term.
+ $type is Course (default) or Community.
+ If $forcedefault evaluates to true, text returned will be default
+ text for $type. Otherwise, if this is a course, the text returned
+ will be a custom name for the role (if defined in the course's
+ environment).  If no custom name is defined the default is returned.
  =item *
- get_my_roles($uname,$udom,$context,$types,$roles,$roledoms) :
+ get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec) :
  All arguments are optional. Returns a hash of a roles, either for
  co-author/assistant author roles for a user's Construction Space
  (default), or if $context is 'userroles', roles for the user himself,
- In the hash, keys are set to colon-sparated $uname,$udom,and $role,
+ In the hash, keys are set to colon-separated $uname,$udom,$role, and
- and value is set to colon-separated start and end times for the role.
+ (optionally) if $withsec is true, a fourth colon-separated item - $section.
- If no username and domain are specified, will default to current
+ For each key, value is set to colon-separated start and end times for
- user/domain. Types, roles, and roledoms are references to arrays,
+ the role.  If no username and domain are specified, will default to
+ current user/domain. Types, roles, and roledoms are references to arrays
  of role statuses (active, future or previous), roles
  (e.g., cc,in, st etc.) and domains of the roles which can be used
  to restrict the list of roles reported. If no array ref is
- Line 8812  provided for types, will default to retu
+ Line 10697  provided for types, will default to retu
  =item *
- assignrole($udom,$uname,$url,$role,$end,$start) : assign role; give a role to a
+ assignrole($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,$context) : assign role; give a role to a
  user for the level given by URL.  Optional start and end dates (leave empty
  string or zero for "no date")
- Line 8829  modifyuserauth($udom,$uname,$umode,$upas
+ Line 10714  modifyuserauth($udom,$uname,$umode,$upas
  =item *
- modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) :
+ modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last, $gene,
- modify user
+            $forceid,$desiredhome,$email,$inststatus,$candelete) :
+ will update user information (firstname,middlename,lastname,generation,
+ permanentemail), and if forceid is true, student/employee ID also.
+ A user's institutional affiliation(s) can also be updated.
+ User information fields will not be overwritten with empty entries
+ unless the field is included in the $candelete array reference.
+ This array is included when a single user is modified via "Manage Users",
+ or when Autoupdate.pl is run by cron in a domain.
  =item *
  modifystudent
- modify a students enrollment and identification information.
+ modify a student's enrollment and identification information.
  The course id is resolved based on the current users environment.
  This means the envoking user must be a course coordinator or otherwise
  associated with a course.
- Line 8848  Inputs:
+ Line 10741  Inputs:
  =over 4
- =item B<$udom> Students loncapa domain
+ =item B<$udom> Student's loncapa domain
- =item B<$uname> Students loncapa login name
+ =item B<$uname> Student's loncapa login name
- =item B<$uid> Students id/student number
+ =item B<$uid> Student/Employee ID
- =item B<$umode> Students authentication mode
+ =item B<$umode> Student's authentication mode
- =item B<$upass> Students password
+ =item B<$upass> Student's password
- =item B<$first> Students first name
+ =item B<$first> Student's first name
- =item B<$middle> Students middle name
+ =item B<$middle> Student's middle name
- =item B<$last> Students last name
+ =item B<$last> Student's last name
- =item B<$gene> Students generation
+ =item B<$gene> Student's generation
- =item B<$usec> Students section in course
+ =item B<$usec> Student's section in course
  =item B<$end> Unix time of the roles expiration
- Line 8876  Inputs:
+ Line 10769  Inputs:
  =item B<$desiredhome> server to use as home server for student
+ =item B<$email> Student's permanent e-mail address
+ =item B<$type> Type of enrollment (auto or manual)
+ =item B<$locktype> boolean - enrollment type locked to prevent Autoenroll.pl changing manual to auto
+ =item B<$cid> courseID - needed if a course role is assigned by a user whose current role is DC
+ =item B<$selfenroll> boolean - 1 if user role change occurred via self-enrollment
+ =item B<$context> role change context (shown in User Management Logs display in a course)
+ =item B<$inststatus> institutional status of user - : separated string of escaped status types
  =back
  =item *
- Line 8909  Inputs:
+ Line 10816  Inputs:
  =item $start
+ =item $type
+ =item $locktype
+ =item $cid
+ =item $selfenroll
+ =item $context
  =back
- Line 8967  database) for a course
+ Line 10884  database) for a course
  =item *
- createcourse($udom,$description,$url) : make/modify course
+ createcourse($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner,$crstype,$cnum) : make course
+ =item *
+ generate_coursenum($udom,$crstype) : get a unique (unused) course number in domain $udom for course type $crstype (Course or Community).
  =back
- Line 9217  Returns:
+ Line 11138  Returns:
   'key_exists: <key>' -> failed to anything out of $storehash, as at
                          least <key> already existed in the db (other
                          requested keys may also already exist)
-  'error: <msg>' -> unable to tie the DB or other erorr occured
+  'error: <msg>' -> unable to tie the DB or other error occurred
   'con_lost' -> unable to contact request server
   'refused' -> action was not allowed by remote machine
- Line 9245  put_dom($namespace,$storehash,$udom,$uho
+ Line 11166  put_dom($namespace,$storehash,$udom,$uho
  domain level either on specified domain server ($uhome) or primary domain
  server ($udom and $uhome are optional)
+ =item *
+ get_domain_defaults($target_domain) : returns hash with defaults for
+ authentication and language in the domain. Keys are: auth_def, auth_arg_def,
+ lang_def; corresponsing values are authentication type (internal, krb4, krb5,
+ or localauth), initial password or a kerberos realm, language (e.g., en-us).
+ Values are retrieved from cache (if current), or from domain's configuration.db
+ (if available), or lastly from values in lonTabs/dns_domain,tab,
+ or lonTabs/domain.tab.
+ %domdefaults = &get_auth_defaults($target_domain);
  =back
  =head2 Network Status Functions
- Line 9259  dirlist($uri) : return directory list ba
+ Line 11192  dirlist($uri) : return directory list ba
  spareserver() : find server with least workload from spare.tab
+ =item *
+ host_from_dns($dns) : Returns the loncapa hostname corresponding to a DNS name or undef
+ if there is no corresponding loncapa host.
  =back
  =head2 Apache Request
  =over 4

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>

Removed from v.1.921
changed lines
	Added in v.1.1056.4.6