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.833 and 1.1056.4.14

-version 1.833, 2007/02/18 01:51:20
+version 1.1056.4.14, 2010/11/11 21:57:35
  Line 27
  #
  ###
- package Apache::lonnet;
+ =pod
- use strict;
- use LWP::UserAgent();
- use HTTP::Headers;
- use HTTP::Date;
- # use Date::Parse;
- use vars
- qw(%perlvar %hostname %badServerCache %iphost %spareid %hostdom
-    %libserv %pr %prp $memcache %packagetab
-    %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount
-    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf
-    %domaindescription %domain_auth_def %domain_auth_arg_def
-    %domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary
-    $tmpdir $_64bit %env);
- use IO::Socket;
+ =head1 NAME
- use GDBM_File;
- use HTML::LCParser;
- use HTML::Parser;
- use Fcntl qw(:flock);
- use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);
- use Time::HiRes qw( gettimeofday tv_interval );
- use Cache::Memcached;
- use Digest::MD5;
- use Math::Random;
- use LONCAPA qw(:DEFAULT :match);
- use LONCAPA::Configuration;
- my $readit;
+ Apache::lonnet.pm
- my $max_connection_retries = 10;     # Or some such value.
- require Exporter;
+ =head1 SYNOPSIS
- our @ISA = qw (Exporter);
+ This file is an interface to the lonc processes of
- our @EXPORT = qw(%env);
+ 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.
- =pod
+ This is part of the LearningOnline Network with CAPA project
+ described at http://www.lon-capa.org.
  =head1 Package Variables
- Line 86  delayed.
+ Line 68  delayed.
  =cut
+ package Apache::lonnet;
+ use strict;
+ use LWP::UserAgent();
+ use HTTP::Date;
+ use Image::Magick;
+ use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
+             $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease);
+ my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
+     %userrolehash, $processmarker, $dumpcount, %coursedombuf,
+     %coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf,
+     %courseownerbuf, %coursetypebuf,$locknum);
+ use IO::Socket;
+ use GDBM_File;
+ use HTML::LCParser;
+ use Fcntl qw(:flock);
+ use Storable qw(thaw nfreeze);
+ use Time::HiRes qw( gettimeofday tv_interval );
+ use Cache::Memcached;
+ use Digest::MD5;
+ use Math::Random;
+ use File::MMagic;
+ use LONCAPA qw(:DEFAULT :match);
+ use LONCAPA::Configuration;
+ use File::Copy;
+ my $readit;
+ my $max_connection_retries = 10;     # Or some such value.
+ require Exporter;
+ our @ISA = qw (Exporter);
+ our @EXPORT = qw(%env);
  # --------------------------------------------------------------------- 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 128  sub logthis {
+ Line 149  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 146  sub logperm {
+ Line 168  sub logperm {
      return 1;
  }
+ sub create_connection {
+     my ($hostname,$lonid) = @_;
+     my $client=IO::Socket::UNIX->new(Peer    => $perlvar{'lonSockCreate'},
+ 				     Type    => SOCK_STREAM,
+ 				     Timeout => 10);
+     return 0 if (!$client);
+     print $client (join(':',$hostname,$lonid,&machine_ids($hostname))."\n");
+     my $result = <$client>;
+     chomp($result);
+     return 1 if ($result eq 'done');
+     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 =~ /^[\'\"]?([\w.\-]+)[\'\"]?$/) {
+                 $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(4);
+                     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*([\w.\-]+)<\/p>/) {
+                             $loncaparev = $1;
+                         }
+                     }
+                 } else {
+                     $loncaparev = $loncaparevs{$lonhost};
+                 }
+             } elsif ($answer =~ /^[\'\"]?([\w.\-]+)[\'\"]?$/) {
+                 $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 {
      my ($cmd,$server)=@_;
-     my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};
+     my $peerfile="$perlvar{'lonSockDir'}/".&hostname($server);
      #
      #  With loncnew process trimming, there's a timing hole between lonc server
      #  process exit and the master server picking up the listen on the AF_UNIX
- Line 170  sub subreply {
+ Line 306  sub subreply {
  	$client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
  				      Type    => SOCK_STREAM,
  				      Timeout => 10);
- 	if($client) {
+ 	if ($client) {
  	    last;		# Connected!
+ 	} else {
+ 	    &create_connection(&hostname($server),$server);
  	}
- 	sleep(1);		# Try again later if failed connection.
+         sleep(1);		# Try again later if failed connection.
      }
      my $answer;
      if ($client) {
- Line 189  sub subreply {
+ Line 327  sub subreply {
  sub reply {
      my ($cmd,$server)=@_;
-     unless (defined($hostname{$server})) { return 'no_such_host'; }
+     unless (defined(&hostname($server))) { return 'no_such_host'; }
      my $answer=subreply($cmd,$server);
      if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
         &logthis("<font color=\"blue\">WARNING:".
- Line 201  sub reply {
+ Line 339  sub reply {
  # ----------------------------------------------------------- Send USR1 to lonc
  sub reconlonc {
-     my $peerfile=shift;
+     my ($lonid) = @_;
-     &logthis("Trying to reconnect for $peerfile");
+     my $hostname = &hostname($lonid);
+     if ($lonid) {
+ 	my $peerfile="$perlvar{'lonSockDir'}/$hostname";
+ 	if ($hostname && -e $peerfile) {
+ 	    &logthis("Trying to reconnect lonc for $lonid ($hostname)");
+ 	    my $client=IO::Socket::UNIX->new(Peer    => $peerfile,
+ 					     Type    => SOCK_STREAM,
+ 					     Timeout => 10);
+ 	    if ($client) {
+ 		print $client ("reset_retries\n");
+ 		my $answer=<$client>;
+ 		#reset just this one.
+ 	    }
+ 	}
+ 	return;
+     }
+     &logthis("Trying to reconnect lonc");
      my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
      if (open(my $fh,"<$loncfile")) {
  	my $loncpid=<$fh>;
- Line 211  sub reconlonc {
+ Line 366  sub reconlonc {
  	    &logthis("lonc at pid $loncpid responding, sending USR1");
              kill USR1 => $loncpid;
              sleep 1;
-             if (-e "$peerfile") { return; }
+          } else {
-             &logthis("$peerfile still not there, give it another try");
-             sleep 5;
-             if (-e "$peerfile") { return; }
-             &logthis(
-   "<font color=\"blue\">WARNING: $peerfile still not there, giving up</font>");
-         } else {
  	    &logthis(
                 "<font color=\"blue\">WARNING:".
                 " lonc at pid $loncpid not responding, giving up</font>");
          }
      } else {
-      &logthis('<font color="blue">WARNING: lonc not running, giving up</font>');
+ 	&logthis('<font color="blue">WARNING: lonc not running, giving up</font>');
      }
  }
- Line 231  sub reconlonc {
+ Line 380  sub reconlonc {
  sub critical {
      my ($cmd,$server)=@_;
-     unless ($hostname{$server}) {
+     unless (&hostname($server)) {
          &logthis("<font color=\"blue\">WARNING:".
                 " Critical message to unknown server ($server)</font>");
          return 'no_such_host';
- Line 296  sub convert_and_load_session_env {
+ Line 445  sub convert_and_load_session_env {
      my ($lonidsdir,$handle)=@_;
      my @profile;
      {
- 	open(my $idf,"$lonidsdir/$handle.id");
+ 	my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
+ 	if (!$opened) {
+ 	    return 0;
+ 	}
  	flock($idf,LOCK_SH);
  	@profile=<$idf>;
  	close($idf);
- Line 335  sub transfer_profile_to_env {
+ Line 487  sub transfer_profile_to_env {
      my $convert;
      {
-     	open(my $idf,"$lonidsdir/$handle.id");
+     	my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
+ 	if (!$opened) {
+ 	    return;
+ 	}
  	flock($idf,LOCK_SH);
  	if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",
  		&GDBM_READER(),0640)) {
- Line 367  sub transfer_profile_to_env {
+ Line 522  sub transfer_profile_to_env {
      }
  }
+ # ---------------------------------------------------- Check for valid session
+ sub check_for_valid_session {
+     my ($r) = @_;
+     my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
+     my $lonid=$cookies{'lonID'};
+     return undef if (!$lonid);
+     my $handle=&LONCAPA::clean_handle($lonid->value);
+     my $lonidsdir=$r->dir_config('lonIDsDir');
+     return undef if (!-e "$lonidsdir/$handle.id");
+     my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
+     return undef if (!$opened);
+     flock($idf,LOCK_SH);
+     my %disk_env;
+     if (!tie(%disk_env,'GDBM_File',"$lonidsdir/$handle.id",
+ 	    &GDBM_READER(),0640)) {
+ 	return undef;
+     }
+     if (!defined($disk_env{'user.name'})
+ 	|| !defined($disk_env{'user.domain'})) {
+ 	return undef;
+     }
+     return $handle;
+ }
  sub timed_flock {
      my ($file,$lock_type) = @_;
      my $failed=0;
- Line 390  sub timed_flock {
+ Line 573  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);
          }
-     }
-     open(my $env_file,$env{'user.environment'});
-     if (&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);
          return 'error';
      }
-     open(my $env_file,$env{'user.environment'});
+     my $opened = open(my $env_file,'+<',$env{'user.environment'});
-     if (&timed_flock($env_file,LOCK_EX)
+     if ($opened
+ 	&& &timed_flock($env_file,LOCK_EX)
  	&&
  	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 452  sub get_env_multiple {
+ Line 656  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 461  sub userload {
+ Line 709  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 508  sub spareserver {
+ Line 757  sub spareserver {
      if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
      my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent
                                                       :  $userloadpercent;
+     my ($uint_dom,$remotesessions);
+     if ($env{'user.domain'}) {
+         my $uprimary_id = &Apache::lonnet::domain($env{'user.domain'},'primary');
+         $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);
+         my %udomdefaults = &Apache::lonnet::get_domain_defaults($env{'user.domain'});
+         $remotesessions = $udomdefaults{'remotesessions'};
+     }
      foreach my $try_server (@{ $spareid{'primary'} }) {
+         if ($uint_dom) {
+             next unless (&spare_can_host($env{'user.domain'},$uint_dom,
+                                          $remotesessions,$try_server));
+         }
  	($spare_server, $lowest_load) =
  	    &compare_server_load($try_server, $spare_server, $lowest_load);
      }
- Line 518  sub spareserver {
+ Line 777  sub spareserver {
      if (!$found_server) {
  	foreach my $try_server (@{ $spareid{'default'} }) {
+             if ($uint_dom) {
+                 next unless (&spare_can_host($env{'user.domain'},$uint_dom,
+                                              $remotesessions,$try_server));
+             }
  	    ($spare_server, $lowest_load) =
  		&compare_server_load($try_server, $spare_server, $lowest_load);
  	}
      }
      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 536  sub compare_server_load {
+ Line 808  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 558  sub compare_server_load {
+ Line 830  sub compare_server_load {
      }
      return ($spare_server,$lowest_load);
  }
+ # --------------------------- ask offload servers if user already has a session
+ sub find_existing_session {
+     my ($udom,$uname) = @_;
+     foreach my $try_server (@{ $spareid{'primary'} },
+ 			    @{ $spareid{'default'} }) {
+ 	return $try_server if (&has_user_session($try_server, $udom, $uname));
+     }
+     return;
+ }
+ # -------------------------------- ask if server already has a session for user
+ sub has_user_session {
+     my ($lonid,$udom,$uname) = @_;
+     my $result = &reply(join(':','userhassession',
+ 			     map {&escape($_)} ($udom,$uname)),$lonid);
+     return 1 if ($result eq 'ok');
+     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 589  sub changepass {
+ Line 904  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 612  sub queryauthenticate {
+ Line 930  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);
+     my $uhome=&homeserver($uname,$udom,1);
-     if (!$uhome) {
+     my $newhome;
- 	&logthis("User $uname at $udom is unknown in authenticate");
+     if ((!$uhome) || ($uhome eq 'no_host')) {
- 	return 'no_host';
+ # Maybe the machine was offline and only re-appeared again recently?
+         &reconlonc();
+ # One more
+ 	$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';
+         }
      }
-     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 633  sub authenticate {
+ Line 971  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;
+ }
+ sub spare_can_host {
+     my ($udom,$uint_dom,$remotesessions,$try_server)=@_;
+     my $canhost=1;
+     my @intdoms;
+     my $internet_names = &Apache::lonnet::get_internet_names($try_server);
+     if (ref($internet_names) eq 'ARRAY') {
+         @intdoms = @{$internet_names};
+     }
+     unless (grep(/^\Q$uint_dom\E$/,@intdoms)) {
+         my $serverhomeID = &Apache::lonnet::get_server_homeID($try_server);
+         my $serverhomedom = &Apache::lonnet::host_domain($serverhomeID);
+         my %defdomdefaults = &Apache::lonnet::get_domain_defaults($serverhomedom);
+         my $remoterev = &Apache::lonnet::get_server_loncaparev(undef,$try_server);
+         $canhost = &can_host_session($udom,$try_server,$remoterev,
+                                      $remotesessions,
+                                      $defdomdefaults{'hostedsessions'});
+     }
+     return $canhost;
+ }
  # ---------------------- Find the homebase for a user from domain's lib servers
  my %homecache;
- Line 641  sub homeserver {
+ Line 1057  sub homeserver {
      my $index="$uname:$udom";
      if (exists($homecache{$index})) { return $homecache{$index}; }
-     my $tryserver;
-     foreach $tryserver (keys %libserv) {
+     my %servers = &get_servers($udom,'library');
+     foreach my $tryserver (keys(%servers)) {
          next if ($ignoreBadCache ne 'true' &&
  		 exists($badServerCache{$tryserver}));
- 	if ($hostdom{$tryserver} eq $udom) {
-            my $answer=reply("home:$udom:$uname",$tryserver);
+ 	my $answer=reply("home:$udom:$uname",$tryserver);
-            if ($answer eq 'found') {
+ 	if ($answer eq 'found') {
- 	       return $homecache{$index}=$tryserver;
+ 	    delete($badServerCache{$tryserver});
-            } elsif ($answer eq 'no_host') {
+ 	    return $homecache{$index}=$tryserver;
- 	       $badServerCache{$tryserver}=1;
+ 	} elsif ($answer eq 'no_host') {
-            }
+ 	    $badServerCache{$tryserver}=1;
-        }
+ 	}
      }
      return 'no_host';
  }
- Line 663  sub idget {
+ Line 1080  sub idget {
      my ($udom,@ids)=@_;
      my %returnhash=();
-     my $tryserver;
+     my %servers = &get_servers($udom,'library');
-     foreach $tryserver (keys %libserv) {
+     foreach my $tryserver (keys(%servers)) {
-        if ($hostdom{$tryserver} eq $udom) {
+ 	my $idlist=join('&',@ids);
- 	  my $idlist=join('&',@ids);
+ 	$idlist=~tr/A-Z/a-z/;
-           $idlist=~tr/A-Z/a-z/;
+ 	my $reply=&reply("idget:$udom:".$idlist,$tryserver);
- 	  my $reply=&reply("idget:$udom:".$idlist,$tryserver);
+ 	my @answer=();
-           my @answer=();
+ 	if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {
-           if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {
+ 	    @answer=split(/\&/,$reply);
- 	      @answer=split(/\&/,$reply);
+ 	}                    ;
-           }                    ;
+ 	my $i;
-           my $i;
+ 	for ($i=0;$i<=$#ids;$i++) {
-           for ($i=0;$i<=$#ids;$i++) {
+ 	    if ($answer[$i]) {
-               if ($answer[$i]) {
+ 		$returnhash{$ids[$i]}=$answer[$i];
- 		  $returnhash{$ids[$i]}=$answer[$i];
+ 	    }
-               }
+ 	}
-           }
+     }
-        }
-     }
      return %returnhash;
  }
- Line 719  sub idput {
+ Line 1134  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)=@_;
+     my ($namespace,$storearr,$udom,$uhome)=@_;
      my $items='';
      foreach my $item (@$storearr) {
          $items.=&escape($item).'&';
      }
      $items=~s/\&$//;
-     if (!$udom) { $udom=$env{'user.domain'}; }
+     if (!$udom) {
-     if (exists($domain_primary{$udom})) {
+         $udom=$env{'user.domain'};
-         my $uhome=$domain_primary{$udom};
+         if (defined(&domain($udom,'primary'))) {
+             $uhome=&domain($udom,'primary');
+         } else {
+             undef($uhome);
+         }
+     } else {
+         if (!$uhome) {
+             if (defined(&domain($udom,'primary'))) {
+                 $uhome=&domain($udom,'primary');
+             }
+         }
+     }
+     if ($udom && $uhome && ($uhome ne 'no_host')) {
          my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
+         my %returnhash;
+         if ($rep eq '' || $rep =~ /^error: 2 /) {
+             return %returnhash;
+         }
          my @pairs=split(/\&/,$rep);
          if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {
              return @pairs;
          }
-         my %returnhash=();
          my $i=0;
          foreach my $item (@$storearr) {
              $returnhash{$item}=&thaw_unescape($pairs[$i]);
- Line 744  sub get_dom {
+ Line 1188  sub get_dom {
          }
          return %returnhash;
      } else {
-         &logthis("get_dom failed - no primary domain server for $udom");
+         &logthis("get_dom failed - no homeserver and/or domain ($udom) ($uhome)");
      }
  }
  # -------------------------------------------- put items in domain db files
  sub put_dom {
-     my ($namespace,$storehash,$udom)=@_;
+     my ($namespace,$storehash,$udom,$uhome)=@_;
-     if (!$udom) { $udom=$env{'user.domain'}; }
+     if (!$udom) {
-     if (exists($domain_primary{$udom})) {
+         $udom=$env{'user.domain'};
-         my $uhome=$domain_primary{$udom};
+         if (defined(&domain($udom,'primary'))) {
+             $uhome=&domain($udom,'primary');
+         } else {
+             undef($uhome);
+         }
+     } else {
+         if (!$uhome) {
+             if (defined(&domain($udom,'primary'))) {
+                 $uhome=&domain($udom,'primary');
+             }
+         }
+     }
+     if ($udom && $uhome && ($uhome ne 'no_host')) {
          my $items='';
          foreach my $item (keys(%$storehash)) {
              $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
- Line 762  sub put_dom {
+ Line 1218  sub put_dom {
          $items=~s/\&$//;
          return &reply("putdom:$udom:$namespace:$items",$uhome);
      } else {
-         &logthis("put_dom failed - no primary domain server for $udom");
+         &logthis("put_dom failed - no homeserver and/or domain");
+     }
+ }
+ # --------------------- 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);
+     my %domdefs = &Apache::lonnet::get_domain_defaults($udom);
+     if ((ref($domdefs{'inststatustypes'}) eq 'HASH') &&
+         (ref($domdefs{'inststatusorder'}) eq 'ARRAY')) {
+         %returnhash = %{$domdefs{'inststatustypes'}};
+         @order = @{$domdefs{'inststatusorder'}};
+     } else {
+         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);
+ }
+ sub is_domainimage {
+     my ($url) = @_;
+     if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+-) {
+         if (&domain($1) ne '') {
+             return '1';
+         }
+     }
+     return;
+ }
+ sub inst_directory_query {
+     my ($srch) = @_;
+     my $udom = $srch->{'srchdomain'};
+     my %results;
+     my $homeserver = &domain($udom,'primary');
+     my $outcome;
+     if ($homeserver ne '') {
+ 	my $queryid=&reply("querysend:instdirsearch:".
+ 			   &escape($srch->{'srchby'}).':'.
+ 			   &escape($srch->{'srchterm'}).':'.
+ 			   &escape($srch->{'srchtype'}),$homeserver);
+ 	my $host=&hostname($homeserver);
+ 	if ($queryid !~/^\Q$host\E\_/) {
+ 	    &logthis('instituional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom);
+ 	    return;
+ 	}
+ 	my $response = &get_query_reply($queryid);
+ 	my $maxtries = 5;
+ 	my $tries = 1;
+ 	while (($response=~/^timeout/) && ($tries < $maxtries)) {
+ 	    $response = &get_query_reply($queryid);
+ 	    $tries ++;
+ 	}
+         if (!&error($response) && $response ne 'refused') {
+             if ($response eq 'unavailable') {
+                 $outcome = $response;
+             } else {
+                 $outcome = 'ok';
+                 my @matches = split(/\n/,$response);
+                 foreach my $match (@matches) {
+                     my ($key,$value) = split(/=/,$match);
+                     $results{&unescape($key).':'.$udom} = &thaw_unescape($value);
+                 }
+             }
+         }
      }
+     return ($outcome,%results);
+ }
+ sub usersearch {
+     my ($srch) = @_;
+     my $dom = $srch->{'srchdomain'};
+     my %results;
+     my %libserv = &all_library();
+     my $query = 'usersearch';
+     foreach my $tryserver (keys(%libserv)) {
+         if (&host_domain($tryserver) eq $dom) {
+             my $host=&hostname($tryserver);
+             my $queryid=
+                 &reply("querysend:".&escape($query).':'.
+                        &escape($srch->{'srchby'}).':'.
+                        &escape($srch->{'srchtype'}).':'.
+                        &escape($srch->{'srchterm'}),$tryserver);
+             if ($queryid !~/^\Q$host\E\_/) {
+                 &logthis('usersearch: invalid queryid: '.$queryid.' for host: '.$host.'in domain '.$dom.' and server: '.$tryserver);
+                 next;
+             }
+             my $reply = &get_query_reply($queryid);
+             my $maxtries = 1;
+             my $tries = 1;
+             while (($reply=~/^timeout/) && ($tries < $maxtries)) {
+                 $reply = &get_query_reply($queryid);
+                 $tries ++;
+             }
+             if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
+                 &logthis('usersrch error: '.$reply.' for '.$dom.' - searching for : '.$srch->{'srchterm'}.' by '.$srch->{'srchby'}.' ('.$srch->{'srchtype'}.') -  maxtries: '.$maxtries.' tries: '.$tries);
+             } else {
+                 my @matches;
+                 if ($reply =~ /\n/) {
+                     @matches = split(/\n/,$reply);
+                 } else {
+                     @matches = split(/\&/,$reply);
+                 }
+                 foreach my $match (@matches) {
+                     my ($uname,$udom,%userhash);
+                     foreach my $entry (split(/:/,$match)) {
+                         my ($key,$value) =
+                             map {&unescape($_);} split(/=/,$entry);
+                         $userhash{$key} = $value;
+                         if ($key eq 'username') {
+                             $uname = $value;
+                         } elsif ($key eq 'domain') {
+                             $udom = $value;
+                         }
+                     }
+                     $results{$uname.':'.$udom} = \%userhash;
+                 }
+             }
+         }
+     }
+     return %results;
+ }
+ sub get_instuser {
+     my ($udom,$uname,$id) = @_;
+     my $homeserver = &domain($udom,'primary');
+     my ($outcome,%results);
+     if ($homeserver ne '') {
+         my $queryid=&reply("querysend:getinstuser:".&escape($uname).':'.
+                            &escape($id).':'.&escape($udom),$homeserver);
+         my $host=&hostname($homeserver);
+         if ($queryid !~/^\Q$host\E\_/) {
+             &logthis('get_instuser invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom);
+             return;
+         }
+         my $response = &get_query_reply($queryid);
+         my $maxtries = 5;
+         my $tries = 1;
+         while (($response=~/^timeout/) && ($tries < $maxtries)) {
+             $response = &get_query_reply($queryid);
+             $tries ++;
+         }
+         if (!&error($response) && $response ne 'refused') {
+             if ($response eq 'unavailable') {
+                 $outcome = $response;
+             } else {
+                 $outcome = 'ok';
+                 my @matches = split(/\n/,$response);
+                 foreach my $match (@matches) {
+                     my ($key,$value) = split(/=/,$match);
+                     $results{&unescape($key)} = &thaw_unescape($value);
+                 }
+             }
+         }
+     }
+     my %userinfo;
+     if (ref($results{$uname}) eq 'HASH') {
+         %userinfo = %{$results{$uname}};
+     }
+     return ($outcome,%userinfo);
+ }
+ sub inst_rulecheck {
+     my ($udom,$uname,$id,$item,$rules) = @_;
+     my %returnhash;
+     if ($udom ne '') {
+         if (ref($rules) eq 'ARRAY') {
+             @{$rules} = map {&escape($_);} (@{$rules});
+             my $rulestr = join(':',@{$rules});
+             my $homeserver=&domain($udom,'primary');
+             if (($homeserver ne '') && ($homeserver ne 'no_host')) {
+                 my $response;
+                 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) {
+                         my ($key,$value)=split(/=/,$item,2);
+                         $key = &unescape($key);
+                         next if ($key =~ /^error: 2 /);
+                         $returnhash{$key}=&thaw_unescape($value);
+                     }
+                 }
+             }
+         }
+     }
+     return %returnhash;
+ }
+ sub inst_userrules {
+     my ($udom,$check) = @_;
+     my (%ruleshash,@ruleorder);
+     if ($udom ne '') {
+         my $homeserver=&domain($udom,'primary');
+         if (($homeserver ne '') && ($homeserver ne 'no_host')) {
+             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);
+                 foreach my $item (@pairs) {
+                     my ($key,$value)=split(/=/,$item,2);
+                     $key = &unescape($key);
+                     next if ($key =~ /^error: 2 /);
+                     $ruleshash{$key}=&thaw_unescape($value);
+                 }
+                 my @esc_order = split(/\&/,$orderitems);
+                 foreach my $item (@esc_order) {
+                     push(@ruleorder,&unescape($item));
+                 }
+             }
+         }
+     }
+     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
- Line 798  sub assign_access_key {
+ Line 1610  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 946  sub getsection {
+ Line 1758  sub getsection {
      # If there is a role which has expired, return it.
      #
      $courseid = &courseid_to_courseurl($courseid);
-     my %roleshash = &dump('roles',$udom,$unam,$courseid);
+     my $extra = &freeze_escape({'skipcheck' => 1});
+     my %roleshash = &dump('roles',$udom,$unam,$courseid,undef,$extra);
      foreach my $key (keys(%roleshash)) {
          next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/);
          my $section=$1;
- Line 990  my %remembered;
+ Line 1803  my %remembered;
  my %accessed;
  my $kicks=0;
  my $hits=0;
+ sub make_key {
+     my ($name,$id) = @_;
+     if (length($id) > 65
+ 	&& length(&escape($id)) > 200) {
+ 	$id=length($id).':'.&Digest::MD5::md5_hex($id);
+     }
+     return &escape($name.':'.$id);
+ }
  sub devalidate_cache_new {
      my ($name,$id,$debug) = @_;
      if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }
-     $id=&escape($name.':'.$id);
+     $id=&make_key($name,$id);
      $memcache->delete($id);
      delete($remembered{$id});
      delete($accessed{$id});
- Line 1001  sub devalidate_cache_new {
+ Line 1823  sub devalidate_cache_new {
  sub is_cached_new {
      my ($name,$id,$debug) = @_;
-     $id=&escape($name.':'.$id);
+     $id=&make_key($name,$id);
      if (exists($remembered{$id})) {
  	if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }
  	$accessed{$id}=[&gettimeofday()];
- Line 1024  sub is_cached_new {
+ Line 1846  sub is_cached_new {
  sub do_cache_new {
      my ($name,$id,$value,$time,$debug) = @_;
-     $id=&escape($name.':'.$id);
+     $id=&make_key($name,$id);
      my $setvalue=$value;
      if (!defined($setvalue)) {
  	$setvalue='__undef__';
- Line 1033  sub do_cache_new {
+ Line 1855  sub do_cache_new {
  	$time=600;
      }
      if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }
-     $memcache->set($id,$setvalue,$time);
+     my $result = $memcache->set($id,$setvalue,$time);
+     if (! $result) {
+ 	&logthis("caching of id -> $id  failed");
+ 	$memcache->disconnect_all();
+     }
      # need to make a copy of $value
-     #&make_room($id,$value,$debug);
+     &make_room($id,$value,$debug);
      return $value;
  }
  sub make_room {
      my ($id,$value,$debug)=@_;
-     $remembered{$id}=$value;
+     $remembered{$id}= (ref($value)) ? &Storable::dclone($value)
+                                     : $value;
      if ($to_remember<0) { return; }
      $accessed{$id}=[&gettimeofday()];
      if (scalar(keys(%remembered)) <= $to_remember) { return; }
- Line 1070  sub purge_remembered {
+ Line 1898  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 1267  sub ssi_body {
+ Line 2105  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 1286  sub absolute_url {
+ Line 2135  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 1306  sub ssi {
+ Line 2163  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 1314  sub externalssi {
+ Line 2175  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 1327  sub allowuploaded {
+ Line 2192  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 1388  sub process_coursefile {
+ Line 2253  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 1467  sub clean_filename {
+ Line 2336  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"}
- #                    the desired filenam is in $env{"form.$formname.filename"}
+ #                    the desired filename is in $env{"form.$formname.filename"}
- #        $coursedoc - if true up to the current course
+ #        $context - possible values: coursedoc, existingfile, overwrite,
- #                     if false
+ #                                    canceloverwrite, or ''.
+ #                   if 'coursedoc': upload to the current course
+ #                   if 'existingfile': write file to tmp/overwrites directory
+ #                   if 'canceloverwrite': delete file written to tmp/overwrites directory
+ #                   $context is passed as argument to &finishuserfileupload
  #        $subdir - directory in userfile to store the file into
- #        $parser, $allfiles, $codebase - unknown
+ #        $parser - instruction to parse file for objects ($parser = parse)
- #
+ #        $allfiles - reference to hash for embedded objects
+ #        $codebase - reference to hash for codebase of java objects
+ #        $desuname - username for permanent storage of uploaded file
+ #        $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)=@_;
+     my ($formname,$context,$subdir,$parser,$allfiles,$codebase,$destuname,
+         $destudom,$thumbwidth,$thumbheight,$resizewidth,$resizeheight)=@_;
      if (!defined($subdir)) { $subdir='unknown'; }
      my $fname=$env{'form.'.$formname.'.filename'};
      $fname=&clean_filename($fname);
- # See if there is anything left
+     # See if there is anything left
      unless ($fname) { return 'error: no uploaded file'; }
      chop($env{'form.'.$formname});
-     if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { #files uploaded to help request form are handled differently
+     # Files uploaded to help request form, or uploaded to "create course" page are handled differently
+     if ((($formname eq 'screenshot') && ($subdir eq 'helprequests')) ||
+         (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) ||
+          ($context eq 'existingfile') || ($context eq 'canceloverwrite')) {
          my $now = time;
-         my $filepath = 'tmp/helprequests/'.$now;
+         my $filepath;
-         my @parts=split(/\//,$filepath);
+         if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) {
-         my $fullpath = $perlvar{'lonDaemons'};
+              $filepath = 'tmp/helprequests/'.$now;
-         for (my $i=0;$i<@parts;$i++) {
+         } elsif (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) {
-             $fullpath .= '/'.$parts[$i];
+              $filepath = 'tmp/addcourse/'.$destudom.'/web/'.$env{'user.name'}.
-             if ((-e $fullpath)!=1) {
+                          '_'.$env{'user.domain'}.'/pending';
-                 mkdir($fullpath,0777);
+         } elsif (($context eq 'existingfile') || ($context eq 'canceloverwrite')) {
+             my ($docuname,$docudom);
+             if ($destudom) {
+                 $docudom = $destudom;
+             } else {
+                 $docudom = $env{'user.domain'};
+             }
+             if ($destuname) {
+                 $docuname = $destuname;
+             } else {
+                 $docuname = $env{'user.name'};
+             }
+             if (exists($env{'form.group'})) {
+                 $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
+                 $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
+             }
+             $filepath = 'tmp/overwrites/'.$docudom.'/'.$docuname.'/'.$subdir;
+             if ($context eq 'canceloverwrite') {
+                 my $tempfile =  $perlvar{'lonDaemons'}.'/'.$filepath.'/'.$fname;
+                 if (-e  $tempfile) {
+                     my @info = stat($tempfile);
+                     if ($info[9] eq $env{'form.timestamp'}) {
+                         unlink($tempfile);
+                     }
+                 }
+                 return;
              }
          }
-         open(my $fh,'>'.$fullpath.'/'.$fname);
+         # Create the directory if not present
-         print $fh $env{'form.'.$formname};
-         close($fh);
-         return $fullpath.'/'.$fname;
-     } elsif (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) { #files uploaded to create course page are handled differently
-         my $filepath = 'tmp/addcourse/'.$destudom.'/web/'.$env{'user.name'}.
-                        '_'.$env{'user.domain'}.'/pending';
          my @parts=split(/\//,$filepath);
          my $fullpath = $perlvar{'lonDaemons'};
          for (my $i=0;$i<@parts;$i++) {
- Line 1517  sub userfileupload {
+ Line 2457  sub userfileupload {
          open(my $fh,'>'.$fullpath.'/'.$fname);
          print $fh $env{'form.'.$formname};
          close($fh);
-         return $fullpath.'/'.$fname;
+         if ($context eq 'existingfile') {
+             my @info = stat($fullpath.'/'.$fname);
+             return ($fullpath.'/'.$fname,$info[9]);
+         } else {
+             return $fullpath.'/'.$fname;
+         }
      }
+     if ($subdir eq 'scantron') {
- # Create the directory if not present
+         $fname = 'scantron_orig_'.$fname;
-     $fname="$subdir/$fname";
+     } else {
-     if ($coursedoc) {
+         $fname="$subdir/$fname";
+     }
+     if ($context eq '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);
+ 					 $codebase,$thumbwidth,$thumbheight,
+                                          $resizewidth,$resizeheight,$context);
          } else {
              $fname=$env{'form.folder'}.'/'.$fname;
              return &process_coursefile('uploaddoc',$docuname,$docudom,
- Line 1538  sub userfileupload {
+ Line 2486  sub userfileupload {
      } elsif (defined($destuname)) {
          my $docuname=$destuname;
          my $docudom=$destudom;
- 	return &finishuserfileupload($docuname,$docudom,$formname,
+ 	return &finishuserfileupload($docuname,$docudom,$formname,$fname,
- 				     $fname,$parser,$allfiles,$codebase);
+ 				     $parser,$allfiles,$codebase,
+                                      $thumbwidth,$thumbheight,
+                                      $resizewidth,$resizeheight,$context);
      } else {
          my $docuname=$env{'user.name'};
          my $docudom=$env{'user.domain'};
- Line 1548  sub userfileupload {
+ Line 2497  sub userfileupload {
              $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
              $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
          }
- 	return &finishuserfileupload($docuname,$docudom,$formname,
+ 	return &finishuserfileupload($docuname,$docudom,$formname,$fname,
- 				     $fname,$parser,$allfiles,$codebase);
+ 				     $parser,$allfiles,$codebase,
+                                      $thumbwidth,$thumbheight,
+                                      $resizewidth,$resizeheight,$context);
      }
  }
  sub finishuserfileupload {
-     my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase) = @_;
+     my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase,
+         $thumbwidth,$thumbheight,$resizewidth,$resizeheight,$context) = @_;
      my $path=$docudom.'/'.$docuname.'/';
      my $filepath=$perlvar{'lonDocRoot'};
-     my ($fnamepath,$file);
+     my ($fnamepath,$file,$fetchthumb);
      $file=$fname;
      if ($fname=~m|/|) {
          ($fnamepath,$file) = ($fname =~ m|^(.*)/([^/]+)$|);
- Line 1571  sub finishuserfileupload {
+ Line 2524  sub finishuserfileupload {
  	    mkdir($filepath,0777);
          }
      }
  # Save the file
      {
  	if (!open(FH,'>'.$filepath.'/'.$file)) {
- Line 1578  sub finishuserfileupload {
+ Line 2532  sub finishuserfileupload {
  	    print STDERR ('Failed to create '.$filepath.'/'.$file."\n");
  	    return '/adm/notfound.html';
  	}
- 	if (!print FH ($env{'form.'.$formname})) {
+         if ($context eq 'overwrite') {
+             my $source =  $perlvar{'lonDaemons'}.'/tmp/overwrites/'.$docudom.'/'.$docuname.'/'.$fname;
+             my $target = $filepath.'/'.$file;
+             if (-e $source) {
+                 my @info = stat($source);
+                 if ($info[9] eq $env{'form.timestamp'}) {
+                     unless (&File::Copy::move($source,$target)) {
+                         &logthis('Failed to overwrite '.$filepath.'/'.$file);
+                         return "Moving from $source failed";
+                     }
+                 } else {
+                     return "Temporary file: $source had unexpected date/time for last modification";
+                 }
+             } else {
+                 return "Temporary file: $source missing";
+             }
+ 	} elsif (!print FH ($env{'form.'.$formname})) {
  	    &logthis('Failed to write to '.$filepath.'/'.$file);
  	    print STDERR ('Failed to write to '.$filepath.'/'.$file."\n");
  	    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+$/)) {
+         my $input = $filepath.'/'.$file;
+         my $output = $filepath.'/'.'tn-'.$file;
+         my $thumbsize = $thumbwidth.'x'.$thumbheight;
+         system("convert -sample $thumbsize $input $output");
+         if (-e $filepath.'/'.'tn-'.$file) {
+             $fetchthumb  = 1;
+         }
+     }
  # Notify homeserver to grep it
  #
      my $docuhome=&homeserver($docuname,$docudom);
      my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
      if ($fetchresult eq 'ok') {
+         if ($fetchthumb) {
+             my $thumbresult= &reply('fetchuserfile:'.$path.'tn-'.$file,$docuhome);
+             if ($thumbresult ne 'ok') {
+                 &logthis('Failed to transfer '.$path.'tn-'.$file.' to host '.
+                          $docuhome.': '.$thumbresult);
+             }
+         }
  #
  # Return the URL to it
          return '/uploaded/'.$path.$file;
- Line 1605  sub finishuserfileupload {
+ Line 2603  sub finishuserfileupload {
          &logthis('Failed to transfer '.$path.$file.' to host '.$docuhome.
  		 ': '.$fetchresult);
          return '/adm/notfound.html';
      }
  }
  sub extract_embedded_items {
-     my ($filepath,$file,$allfiles,$codebase,$content) = @_;
+     my ($fullpath,$allfiles,$codebase,$content) = @_;
      my @state = ();
      my %javafiles = (
                        codebase => '',
- Line 1624  sub extract_embedded_items {
+ Line 2622  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') {
  	    my ($tagname, $attr) = ($t->[1],$t->[2]);
- 	    push (@state, $tagname);
+ 	    push(@state, $tagname);
              if (lc($tagname) eq 'allow') {
                  &add_filetype($allfiles,$attr->{'src'},'src');
              }
  	    if (lc($tagname) eq 'img') {
  		&add_filetype($allfiles,$attr->{'src'},'src');
  	    }
+ 	    if (lc($tagname) eq 'a') {
+ 		&add_filetype($allfiles,$attr->{'href'},'href');
+ 	    }
              if (lc($tagname) eq 'script') {
                  if ($attr->{'archive'} =~ /\.jar$/i) {
                      &add_filetype($allfiles,$attr->{'archive'},'archive');
- Line 1717  sub add_filetype {
+ Line 2718  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 1792  sub flushcourselogs {
+ Line 2793  sub flushcourselogs {
  # times and course titles for all courseids
  #
      my %courseidbuffer=();
-     foreach my $crsid (keys %courselogs) {
+     foreach my $crsid (keys(%courselogs)) {
          if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'.
  		          &escape($courselogs{$crsid}),
  		          $coursehombuf{$crsid}) eq 'ok') {
- Line 1805  sub flushcourselogs {
+ Line 2806  sub flushcourselogs {
                 delete $courselogs{$crsid};
              }
          }
-         if ($courseidbuffer{$coursehombuf{$crsid}}) {
+         $courseidbuffer{$coursehombuf{$crsid}}{$crsid} = {
-            $courseidbuffer{$coursehombuf{$crsid}}.='&'.
+             'description' => $coursedescrbuf{$crsid},
- 			 &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
+             'inst_code'    => $courseinstcodebuf{$crsid},
-                          ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});
+             'type'        => $coursetypebuf{$crsid},
-         } else {
+             'owner'       => $courseownerbuf{$crsid},
-            $courseidbuffer{$coursehombuf{$crsid}}=
+         };
- 			 &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).
-                          ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});
-         }
      }
  #
  # Write course id database (reverse lookup) to homeserver of courses
  # Is used in pickcourse
  #
-     foreach my $crsid (keys(%courseidbuffer)) {
+     foreach my $crs_home (keys(%courseidbuffer)) {
-         &courseidput($hostdom{$crsid},$courseidbuffer{$crsid},$crsid);
+         my $response = &courseidput(&host_domain($crs_home),
+                                     $courseidbuffer{$crs_home},
+                                     $crs_home,'timeonly');
      }
  #
  # File accesses
- Line 1875  sub flushcourselogs {
+ Line 2875  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;
+         my ($role,$uname,$udom,$runame,$rudom,$rsec)=split(/:/,$entry);
          if ($domrolebuffer{$rudom}) {
              $domrolebuffer{$rudom}.='&'.&escape($entry).
                        '='.&escape($domainrolehash{$entry});
- Line 1887  sub flushcourselogs {
+ Line 2887  sub flushcourselogs {
          delete $domainrolehash{$entry};
      }
      foreach my $dom (keys(%domrolebuffer)) {
-         foreach my $tryserver (keys %libserv) {
+ 	my %servers = &get_servers($dom,'library');
-             if ($hostdom{$tryserver} eq $dom) {
+ 	foreach my $tryserver (keys(%servers)) {
-                 unless (&reply('domroleput:'.$dom.':'.
+ 	    unless (&reply('domroleput:'.$dom.':'.
-                   $domrolebuffer{$dom},$tryserver) eq 'ok') {
+ 			   $domrolebuffer{$dom},$tryserver) eq 'ok') {
-                     &logthis('Put of domain roles failed for '.$dom.' and  '.$tryserver);
+ 		&logthis('Put of domain roles failed for '.$dom.' and  '.$tryserver);
-                 }
+ 	    }
-             }
          }
      }
      $dumpcount++;
- Line 1936  sub courseacclog {
+ Line 2935  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 1976  sub userrolelog {
+ Line 2980  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}
                      =$tend.':'.$tstart;
      }
+     if (($env{'request.role'} =~ /dc\./) &&
+ 	(($trole=~/^au/) || ($trole=~/^in/) ||
+ 	 ($trole=~/^cc/) || ($trole=~/^ep/) ||
+ 	 ($trole=~/^cr/) || ($trole=~/^ta/) ||
+          ($trole=~/^co/))) {
+        $userrolehash
+          {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}
+                     =$tend.':'.$tstart;
+     }
      if (($trole=~/^dc/) || ($trole=~/^ad/) ||
          ($trole=~/^li/) || ($trole=~/^li/) ||
          ($trole=~/^au/) || ($trole=~/^dg/) ||
- Line 1993  sub userrolelog {
+ Line 3006  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,$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') {
+         my $extra = &freeze_escape({'skipcheck' => 1});
+         %dumphash = &dump('roles',$udom,$uname,'.',undef,$extra);
+     } 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 ($tend,$tstart)=split(/\:/,$dumphash{$entry});
+         my ($role,$tend,$tstart);
+         if ($context eq 'userroles') {
+ 	    ($role,$tend,$tstart)=split(/_/,$dumphash{$entry});
+         } else {
+             ($tend,$tstart)=split(/\:/,$dumphash{$entry});
+         }
          if (($tstart) && ($tstart<0)) { next; }
          my $status = 'active';
-         if (($tend) && ($tend<$now)) {
+         if (($tend) && ($tend<=$now)) {
              $status = 'previous';
          }
          if (($tstart) && ($now<$tstart)) {
- Line 2053  sub get_my_roles {
+ Line 3150  sub get_my_roles {
                  next;
              }
          }
-         my ($role,$username,$domain,$section)=split(/\:/,$entry);
+         my ($rolecode,$username,$domain,$section,$area);
+         if ($context eq 'userroles') {
+             ($area,$rolecode) = split(/_/,$entry);
+             (undef,$domain,$username,$section) = split(/\//,$area);
+         } else {
+             ($role,$username,$domain,$section) = split(/\:/,$entry);
+         }
          if (ref($roledoms) eq 'ARRAY') {
              if (!grep(/^\Q$domain\E$/,@{$roledoms})) {
                  next;
- Line 2061  sub get_my_roles {
+ Line 3164  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;
+                 }
              }
          }
- 	$returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
+         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;
+                     }
+                 }
+             }
+         }
+         if ($withsec) {
+             $returnhash{$username.':'.$domain.':'.$role.':'.$section} =
+                 $tstart.':'.$tend;
+         } else {
+             $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
+         }
      }
      return %returnhash;
  }
- Line 2075  sub get_my_roles {
+ Line 3218  sub get_my_roles {
  sub postannounce {
      my ($server,$text)=@_;
-     unless (&allowed('psa',$hostdom{$server})) { return 'refused'; }
+     unless (&allowed('psa',&host_domain($server))) { return 'refused'; }
      unless ($text=~/\w/) { $text=''; }
      return &reply('setannounce:'.&escape($text),$server);
  }
- Line 2103  sub getannounce {
+ Line 3246  sub getannounce {
  #
  sub courseidput {
-     my ($domain,$what,$coursehome)=@_;
+     my ($domain,$storehash,$coursehome,$caller) = @_;
-     return &reply('courseidput:'.$domain.':'.$what,$coursehome);
+     return unless (ref($storehash) eq 'HASH');
+     my $outcome;
+     if ($caller eq 'timeonly') {
+         my $cids = '';
+         foreach my $item (keys(%$storehash)) {
+             $cids.=&escape($item).'&';
+         }
+         $cids=~s/\&$//;
+         $outcome = &reply('courseidputhash:'.$domain.':'.$caller.':'.$cids,
+                           $coursehome);
+     } else {
+         my $items = '';
+         foreach my $item (keys(%$storehash)) {
+             $items.= &escape($item).'='.
+                      &freeze_escape($$storehash{$item}).'&';
+         }
+         $items=~s/\&$//;
+         $outcome = &reply('courseidputhash:'.$domain.':'.$caller.':'.$items,
+                           $coursehome);
+     }
+     if ($outcome eq 'unknown_cmd') {
+         my $what;
+         foreach my $cid (keys(%$storehash)) {
+             $what .= &escape($cid).'=';
+             foreach my $item ('description','inst_code','owner','type') {
+                 $what .= &escape($storehash->{$cid}{$item}).':';
+             }
+             $what =~ s/\:$/&/;
+         }
+         $what =~ s/\&$//;
+         return &reply('courseidput:'.$domain.':'.$what,$coursehome);
+     } else {
+         return $outcome;
+     }
  }
  sub courseiddump {
-     my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;
+     my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
-     my %returnhash=();
+         $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
-     unless ($domfilter) { $domfilter=''; }
+         $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,
-     foreach my $tryserver (keys %libserv) {
+         $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner)=@_;
-         if ( ($hostidflag == 1 && grep/^$tryserver$/,@{$hostidref}) || (!defined($hostidflag)) ) {
+     my $as_hash = 1;
- 	    if ((!$domfilter) || ($hostdom{$tryserver} eq $domfilter)) {
+     my %returnhash;
- 	        foreach my $line (
+     if (!$domfilter) { $domfilter=''; }
-                  split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.
+     my %libserv = &all_library();
- 			       $sincefilter.':'.&escape($descfilter).':'.
+     foreach my $tryserver (keys(%libserv)) {
-                                &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter).':'.&escape($regexp_ok),
+         if ( (  $hostidflag == 1
-                                $tryserver))) {
+ 	        && grep(/^\Q$tryserver\E$/,@{$hostidref}) )
- 		    my ($key,$value)=split(/\=/,$line,2);
+ 	     || (!defined($hostidflag)) ) {
-                     if (($key) && ($value)) {
- 		        $returnhash{&unescape($key)}=$value;
+ 	    if (($domfilter eq '') ||
+ 		(&host_domain($tryserver) eq $domfilter)) {
+                 my $rep =
+                   &reply('courseiddump:'.&host_domain($tryserver).':'.
+                          $sincefilter.':'.&escape($descfilter).':'.
+                          &escape($instcodefilter).':'.&escape($ownerfilter).
+                          ':'.&escape($coursefilter).':'.&escape($typefilter).
+                          ':'.&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);
+                     $key = &unescape($key);
+                     next if ($key =~ /^error: 2 /);
+                     my $result = &thaw_unescape($value);
+                     if (ref($result) eq 'HASH') {
+                         $returnhash{$key}=$result;
+                     } else {
+                         my @responses = split(/:/,$value);
+                         my @items = ('description','inst_code','owner','type');
+                         for (my $i=0; $i<@responses; $i++) {
+                             $returnhash{$key}{$items[$i]} = &unescape($responses[$i]);
+                         }
                      }
                  }
              }
- Line 2130  sub courseiddump {
+ Line 3333  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 2143  sub dcmailput {
+ Line 3389  sub dcmailput {
  sub dcmaildump {
      my ($dom,$startdate,$enddate,$senders) = @_;
      my %returnhash=();
-     if (exists($domain_primary{$dom})) {
+     if (defined(&domain($dom,'primary'))) {
          my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'.
                                                           &escape($enddate).':';
  	my @esc_senders=map { &escape($_)} @$senders;
  	$cmd.=&escape(join('&',@esc_senders));
- 	foreach my $line (split(/\&/,&reply($cmd,$domain_primary{$dom}))) {
+ 	foreach my $line (split(/\&/,&reply($cmd,&domain($dom,'primary')))) {
              my ($key,$value) = split(/\=/,$line,2);
              if (($key) && ($value)) {
                  $returnhash{&unescape($key)} = &unescape($value);
- Line 2161  sub dcmaildump {
+ Line 3408  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 = ();
-     foreach my $tryserver (keys(%libserv)) {
-         if ($hostdom{$tryserver} eq $dom) {
+     my %servers = &get_servers($dom,'library');
-             %{$personnel{$tryserver}}=();
+     foreach my $tryserver (keys(%servers)) {
-             foreach my $line (
+ 	%{$personnel{$tryserver}}=();
-                 split(/\&/,&reply('domrolesdump:'.$dom.':'.
+ 	foreach my $line (split(/\&/,&reply('domrolesdump:'.$dom.':'.
-                    &escape($startdate).':'.&escape($enddate).':'.
+ 					    &escape($startdate).':'.
-                    &escape($rolelist), $tryserver))) {
+ 					    &escape($enddate).':'.
-                 my ($key,$value) = split(/\=/,$line,2);
+ 					    &escape($rolelist), $tryserver))) {
-                 if (($key) && ($value)) {
+ 	    my ($key,$value) = split(/\=/,$line,2);
-                     $personnel{$tryserver}{&unescape($key)} = &unescape($value);
+ 	    if (($key) && ($value)) {
-                 }
+ 		$personnel{$tryserver}{&unescape($key)} = &unescape($value);
-             }
+ 	    }
-         }
+ 	}
      }
      return %personnel;
  }
- Line 2193  sub get_first_access {
+ Line 3443  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 2206  sub set_first_access {
+ Line 3458  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 2271  sub checkin {
+ Line 3525  sub checkin {
      my $now=time;
      my ($ta,$tb,$lonhost)=split(/\*/,$token);
      $lonhost=~tr/A-Z/a-z/;
-     my $dtoken=$ta.'_'.$hostname{$lonhost}.'_'.$tb;
+     my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb;
      $dtoken=~s/\W/\_/g;
      my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
                   split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
- Line 2564  sub tmpreset {
+ Line 3818  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 2836  sub coursedescription {
+ Line 4090  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 2875  sub privileged {
+ Line 4170  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({'skipcheck' => 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 2940  sub custom_roleprivs {
+ Line 4239  sub custom_roleprivs {
      my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;
      my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
      my $homsvr=homeserver($rauthor,$rdomain);
-     if ($hostname{$homsvr} ne '') {
+     if (&hostname($homsvr) ne '') {
          my ($rdummy,$roledef)=
              &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);
          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 2994  sub standard_roleprivs {
+ Line 4296  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 3021  sub set_userprivs {
+ Line 4336  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 3042  sub set_userprivs {
+ Line 4357  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,$caller) = @_;
+     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,$caller);
+         }
+     } else {
+         &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);
+     }
+ }
+ sub set_adhoc_privileges {
+ # role can be cc or ca
+     my ($dcdom,$pickedcourse,$role,$caller) = @_;
+     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);
+     unless ($caller eq 'constructaccess' && $env{'request.course.id'}) {
+         &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 3077  sub del {
+ Line 4514  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);
  }
  # -------------------------------------------------------------- dump interface
  sub dump {
-     my ($namespace,$udomain,$uname,$regexp,$range)=@_;
+     my ($namespace,$udomain,$uname,$regexp,$range,$extra)=@_;
      if (!$udomain) { $udomain=$env{'user.domain'}; }
      if (!$uname) { $uname=$env{'user.name'}; }
      my $uhome=&homeserver($uname,$udomain);
- Line 3097  sub dump {
+ Line 4534  sub dump {
      } else {
  	$regexp='.';
      }
-     my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
+     my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range:$extra",$uhome);
      my @pairs=split(/\&/,$rep);
      my %returnhash=();
      foreach my $item (@pairs) {
- Line 3385  sub tmpget {
+ Line 4822  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 3482  sub get_portfolio_access {
+ Line 4920  sub get_portfolio_access {
              }
              if (@users > 0) {
                  foreach my $userkey (@users) {
-                     if (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) {
+                     if (ref($access_hash->{$userkey}{'users'}) eq 'ARRAY') {
-                         return 'ok';
+                         foreach my $item (@{$access_hash->{$userkey}{'users'}}) {
-                     }
+                             if (ref($item) eq 'HASH') {
+                                 if (($item->{'uname'} eq $env{'user.name'}) &&
+                                     ($item->{'udom'} eq $env{'user.domain'})) {
+                                     return 'ok';
+                                 }
+                             }
+                         }
+                     }
                  }
              }
              my %roleshash;
- Line 3494  sub get_portfolio_access {
+ Line 4939  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 3633  sub is_portfolio_file {
+ Line 5078  sub is_portfolio_file {
      return;
  }
+ sub usertools_access {
+     my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref) = @_;
+     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 {
+         if (ref($userenvref) eq 'HASH') {
+             $toolstatus = $userenvref->{$context.'.'.$tool};
+             $inststatus = $userenvref->{'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,%domdef);
+     if (ref($is_advref) eq 'HASH') {
+         $is_adv = $is_advref->{'is_adv'};
+     } else {
+         $is_adv = &is_advanced_user($udom,$uname);
+     }
+     if (ref($domdefref) eq 'HASH') {
+         %domdef = %{$domdefref};
+     } else {
+         %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) = @_;
+     if ($udom ne '' && $uname ne '') {
+         if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
+             return $env{'user.adv'};
+         }
+     }
+     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 3644  sub customaccess {
+ Line 5321  sub customaccess {
      $ucrs = &LONCAPA::clean_username($ucrs);
      my $access=0;
      foreach my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) {
- 	my ($effect,$realm,$role)=split(/\:/,$right);
+ 	my ($effect,$realm,$role,$type)=split(/\:/,$right);
-         if ($role) {
+ 	if ($type eq 'user') {
- 	   if ($role ne $urole) { next; }
+ 	    foreach my $scope (split(/\s*\,\s*/,$realm)) {
-         }
+ 		my ($tdom,$tuname)=split(m{/},$scope);
-         foreach my $scope (split(/\s*\,\s*/,$realm)) {
+ 		if ($tdom) {
-             my ($tdom,$tcrs,$tsec)=split(/\_/,$scope);
+ 		    if ($tdom ne $env{'user.domain'}) { next; }
-             if ($tdom) {
+ 		}
- 		if ($tdom ne $udom) { next; }
+ 		if ($tuname) {
-             }
+ 		    if ($tuname ne $env{'user.name'}) { next; }
-             if ($tcrs) {
+ 		}
- 		if ($tcrs ne $ucrs) { next; }
+ 		$access=($effect eq 'allow');
-             }
+ 		last;
-             if ($tsec) {
+ 	    }
- 		if ($tsec ne $usec) { next; }
+ 	} else {
-             }
+ 	    if ($role) {
-             $access=($effect eq 'allow');
+ 		if ($role ne $urole) { next; }
-             last;
+ 	    }
-         }
+ 	    foreach my $scope (split(/\s*\,\s*/,$realm)) {
- 	if ($realm eq '' && $role eq '') {
+ 		my ($tdom,$tcrs,$tsec)=split(/\_/,$scope);
-             $access=($effect eq 'allow');
+ 		if ($tdom) {
+ 		    if ($tdom ne $udom) { next; }
+ 		}
+ 		if ($tcrs) {
+ 		    if ($tcrs ne $ucrs) { next; }
+ 		}
+ 		if ($tsec) {
+ 		    if ($tsec ne $usec) { next; }
+ 		}
+ 		$access=($effect eq 'allow');
+ 		last;
+ 	    }
+ 	    if ($realm eq '' && $role eq '') {
+ 		$access=($effect eq 'allow');
+ 	    }
  	}
      }
      return $access;
- Line 3774  sub allowed {
+ Line 5465  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 3794  sub allowed {
+ Line 5536  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 3831  sub allowed {
+ Line 5575  sub allowed {
      }
  # Full access at system, domain or course-wide level? Exit.
      if ($thisallowed=~/F/) {
  	return 'F';
      }
- Line 3935  sub allowed {
+ Line 5678  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 4148  sub definerole {
+ Line 5891  sub definerole {
  sub metadata_query {
      my ($query,$custom,$customshow,$server_array)=@_;
      my %rhash;
+     my %libserv = &all_library();
      my @server_list = (defined($server_array) ? @$server_array
                                                : keys(%libserv) );
      for my $server (@server_list) {
- Line 4171  sub log_query {
+ Line 5915  sub log_query {
      my ($uname,$udom,$query,%filters)=@_;
      my $uhome=&homeserver($uname,$udom);
      if ($uhome eq 'no_host') { return 'error: no_host'; }
-     my $uhost=$hostname{$uhome};
+     my $uhost=&hostname($uhome);
      my $command=&escape(join(':',map{$_.'='.$filters{$_}} keys(%filters)));
      my $queryid=&reply("querysend:".$query.':'.$udom.':'.$uname.':'.$command,
                         $uhome);
- Line 4183  sub log_query {
+ Line 5927  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 4191  sub update_portfolio_table {
+ Line 5938  sub update_portfolio_table {
      return $reply;
  }
+ # -------------------------- Update MySQL allusers table
+ sub update_allusers_table {
+     my ($uname,$udom,$names) = @_;
+     my $homeserver = &homeserver($uname,$udom);
+     my $queryid=
+         &reply('querysend:allusers:'.&escape($uname).':'.&escape($udom).':'.
+                'lastname='.&escape($names->{'lastname'}).'%%'.
+                'firstname='.&escape($names->{'firstname'}).'%%'.
+                'middlename='.&escape($names->{'middlename'}).'%%'.
+                'generation='.&escape($names->{'generation'}).'%%'.
+                'permanentemail='.&escape($names->{'permanentemail'}).'%%'.
+                'id='.&escape($names->{'id'}),$homeserver);
+     return;
+ }
  # ------- Request retrieval of institutional classlists for course(s)
  sub fetch_enrollment_query {
- Line 4203  sub fetch_enrollment_query {
+ Line 5966  sub fetch_enrollment_query {
      } else {
          $homeserver = &homeserver($cnum,$dom);
      }
-     my $host=$hostname{$homeserver};
+     my $host=&hostname($homeserver);
      my $cmd = '';
-     foreach my $affiliate (keys %{$affiliatesref}) {
+     foreach my $affiliate (keys(%{$affiliatesref})) {
          $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
      }
      $cmd =~ s/%%$//;
- Line 4225  sub fetch_enrollment_query {
+ Line 5988  sub fetch_enrollment_query {
      if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
          &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
      } else {
-         my @responses = split/:/,$reply;
+         my @responses = split(/:/,$reply);
          if ($homeserver eq $perlvar{'lonHostID'}) {
              foreach my $line (@responses) {
                  my ($key,$value) = split(/=/,$line,2);
- Line 4268  sub get_query_reply {
+ Line 6031  sub get_query_reply {
  	sleep 2;
          if (-e $replyfile.'.end') {
  	    if (open(my $fh,$replyfile)) {
-                $reply.=<$fh>;
+ 		$reply = join('',<$fh>);
-                close($fh);
+ 		close($fh);
  	   } else { return 'error: reply_file_error'; }
             return &unescape($reply);
  	}
- Line 4300  sub courselog_query {
+ Line 6063  sub courselog_query {
  }
  sub userlog_query {
+ #
+ # possible filters:
+ # action: log check role
+ # start: timestamp
+ # end: timestamp
+ #
      my ($uname,$udom,%filters)=@_;
      return &log_query($uname,$udom,'userlog',%filters);
  }
- Line 4308  sub userlog_query {
+ Line 6077  sub userlog_query {
  sub auto_run {
      my ($cnum,$cdom) = @_;
-     my $homeserver = &homeserver($cnum,$cdom);
+     my $response = 0;
-     my $response = &reply('autorun:'.$cdom,$homeserver);
+     my $settings;
+     my %domconfig = &get_dom('configuration',['autoenroll'],$cdom);
+     if (ref($domconfig{'autoenroll'}) eq 'HASH') {
+         $settings = $domconfig{'autoenroll'};
+         if ($settings->{'run'} eq '1') {
+             $response = 1;
+         }
+     } else {
+         my $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 4338  sub auto_validate_courseID {
+ Line 6134  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) = @_;
+     my ($cnum,$cdom,$authparam,$udom) = @_;
-     my $homeserver = &homeserver($cnum,$cdom);
+     my ($homeserver,$response);
      my $create_passwd = 0;
      my $authchk = '';
-     my $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver));
+     if ($udom =~ /^$match_domain$/) {
-     if ($response eq 'refused') {
+         $homeserver = &domain($udom,'primary');
-         $authchk = 'refused';
+     }
+     if ($homeserver eq '') {
+         if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
+             $homeserver = &homeserver($cnum,$cdom);
+         }
+     }
+     if ($homeserver eq '') {
+         $authchk = 'nodomain';
      } else {
-         ($authparam,$create_passwd,$authchk) = split/:/,$response;
+         $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver));
+         if ($response eq 'refused') {
+             $authchk = 'refused';
+         } else {
+             ($authparam,$create_passwd,$authchk) = split(/:/,$response);
+         }
      }
      return ($authparam,$create_passwd,$authchk);
  }
- Line 4394  sub auto_photochoice {
+ Line 6219  sub auto_photochoice {
  sub auto_photoupdate {
      my ($affiliatesref,$dom,$cnum,$photo) = @_;
      my $homeserver = &homeserver($cnum,$dom);
-     my $host=$hostname{$homeserver};
+     my $host=&hostname($homeserver);
      my $cmd = '';
      my $maxtries = 1;
      foreach my $affiliate (keys(%{$affiliatesref})) {
- Line 4434  sub auto_instcode_format {
+ Line 6259  sub auto_instcode_format {
      my $courses = '';
      my @homeservers;
      if ($caller eq 'global') {
-         foreach my $tryserver (keys(%libserv)) {
+ 	my %servers = &get_servers($codedom,'library');
-             if ($hostdom{$tryserver} eq $codedom) {
+ 	foreach my $tryserver (keys(%servers)) {
-                 if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
+ 	    if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
-                     push(@homeservers,$tryserver);
+ 		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 {
- Line 4455  sub auto_instcode_format {
+ Line 6286  sub auto_instcode_format {
          $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);
          if ($response !~ /(con_lost|error|no_such_host|refused)/) {
              my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) =
- 		split/:/,$response;
+ 		split(/:/,$response);
              %{$codes} = (%{$codes},&str2hash($codes_str));
              push(@{$codetitles},&str2array($codetitles_str));
              %{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));
- Line 4473  sub auto_instcode_format {
+ Line 6304  sub auto_instcode_format {
  sub auto_instcode_defaults {
      my ($domain,$returnhash,$code_order) = @_;
      my @homeservers;
-     foreach my $tryserver (keys(%libserv)) {
-         if ($hostdom{$tryserver} eq $domain) {
+     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('autoinstcodedefaults:'.$domain,$server);
+         next if ($response =~ /(con_lost|error|no_such_host|refused)/);
+ 	foreach my $pair (split(/\&/,$response)) {
+ 	    my ($name,$value)=split(/\=/,$pair);
+ 	    if ($name eq 'code_order') {
+ 		@{$code_order} = split(/\&/,&unescape($value));
+ 	    } else {
+ 		$returnhash->{&unescape($name)}=&unescape($value);
+ 	    }
+ 	}
+ 	return 'ok';
+     }
+     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 $ok_response = 0;
      my $response;
-     while (@homeservers > 0 && $ok_response == 0) {
+     foreach my $server (@homeservers) {
-         my $server = shift(@homeservers);
+         $response=&reply('autopossibleinstcodes:'.$domain,$server);
-         $response=&reply('autoinstcodedefaults:'.$domain,$server);
+         next if ($response =~ /(con_lost|error|no_such_host|refused)/);
-         if ($response !~ /(con_lost|error|no_such_host|refused)/) {
+         my ($codetitlestr,$codeorderstr,$cat_title,$cat_order) =
-             foreach my $pair (split(/\&/,$response)) {
+             split(':',$response);
-                 my ($name,$value)=split(/\=/,$pair);
+         @{$codetitles} = map { &unescape($_); } (split('&',$codetitlestr));
-                 if ($name eq 'code_order') {
+         @{$code_order} = map { &unescape($_); } (split('&',$codeorderstr));
-                     @{$code_order} = split(/\&/,&unescape($value));
+         foreach my $item (split('&',$cat_title)) {
-                 } else {
+             my ($name,$value)=split('=',$item);
-                     $returnhash->{&unescape($name)}=&unescape($value);
+             $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);
              }
-             $ok_response = 1;
          }
      }
-     if ($ok_response) {
+     return %validations;
-         return 'ok';
+ }
-     } else {
-         return $response;
+ 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,$owner,$inst_class) = @_;
+     my ($cdom,$cnum,$owners,$inst_class) = @_;
      my $homeserver = &homeserver($cnum,$cdom);
+     my $ownerlist;
+     if (ref($owners) eq 'ARRAY') {
+         $ownerlist = join(',',@{$owners});
+     } else {
+         $ownerlist = $owners;
+     }
      my $response=&reply('autovalidateclass_sec:'.$inst_class.':'.
-                         &escape($owner).':'.$cdom,$homeserver);
+                         &escape($ownerlist).':'.$cdom,$homeserver);
      return $response;
  }
- Line 4556  sub toggle_coursegroup_status {
+ Line 6463  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 4607  sub get_users_groups {
+ Line 6514  sub get_users_groups {
      } else {
          $grouplist = '';
          my $courseurl = &courseid_to_courseurl($courseid);
-         my %roleshash = &dump('roles',$udom,$uname,$courseurl);
+         my $extra = &freeze_escape({'skipcheck' => 1});
+         my %roleshash = &dump('roles',$udom,$uname,$courseurl,undef,$extra);
          my $access_end = $env{'course.'.$courseid.
                                '.default_enrollment_end_date'};
          my $now = time;
- Line 4649  sub devalidate_getgroups_cache {
+ Line 6557  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 4701  sub assignrole {
+ Line 6637  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 4721  sub assignrole {
+ Line 6710  sub assignrole {
      }
      my $origstart = $start;
      my $origend = $end;
+     my $delflag;
  # actually delete
      if ($deleteflag) {
  	if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) {
- Line 4731  sub assignrole {
+ Line 6721  sub assignrole {
  # set start and finish to negative values for userrolelog
             $start=-1;
             $end=-1;
+            $delflag = 1;
          }
      }
  # send command
- Line 4739  sub assignrole {
+ Line 6730  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 4779  sub modifyuser {
+ Line 6858  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'))) {
          my $unhome='';
-         if (defined($desiredhome) && $hostdom{$desiredhome} eq $udom) {
+         if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) {
              $unhome = $desiredhome;
  	} elsif($env{'course.'.$env{'request.course.id'}.'.domain'} eq $udom) {
  	    $unhome=$env{'course.'.$env{'request.course.id'}.'.home'};
          } else { # load balancing routine for determining $unhome
-             my $tryserver;
              my $loadm=10000000;
-             foreach $tryserver (keys %libserv) {
+ 	    my %servers = &get_servers($udom,'library');
- 	       if ($hostdom{$tryserver} eq $udom) {
+ 	    foreach my $tryserver (keys(%servers)) {
-                   my $answer=reply('load',$tryserver);
+ 		my $answer=reply('load',$tryserver);
-                   if (($answer=~/\d+/) && ($answer<$loadm)) {
+ 		if (($answer=~/\d+/) && ($answer<$loadm)) {
- 		      $loadm=$answer;
+ 		    $loadm=$answer;
-                       $unhome=$tryserver;
+ 		    $unhome=$tryserver;
-                   }
+ 		}
- 	       }
  	    }
          }
          if (($unhome eq '') || ($unhome eq 'no_host')) {
- Line 4841  sub modifyuser {
+ Line 6928  sub modifyuser {
      }
  # -------------------------------------------------------------- Add names, etc
      my @tmp=&get('environment',
- 		   ['firstname','middlename','lastname','generation'],
+ 		   ['firstname','middlename','lastname','generation','id',
+                     '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;
+     }
+     if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) {
+         &Apache::lonnet::devalidate_cache_new('emailscache',$uname.':'.$udom);
+     }
+     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 4877  sub modifyuser {
+ Line 7032  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 4886  sub modifystudent {
+ Line 7042  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 4955  sub modify_student_enrollment {
+ Line 7111  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 5000  sub writecoursepref {
+ Line 7156  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 (! exists($libserv{$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
-     &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).
+     my $now = time;
-                  ':'.&escape($inst_code).':'.&escape($course_owner).':'.
+     my $newcourse = {
-                   &escape($crstype),$uhome);
+                     $udom.'_'.$uname => {
-     &flushcourselogs();
+                                      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');
  # set toplevel url
      my $topurl=$url;
      unless ($nonstandard) {
- Line 5061  ENDINITMAP
+ Line 7264  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,
- Line 5076  sub is_course {
+ Line 7319  sub is_course {
      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 5113  sub is_locked {
+ Line 7397  sub is_locked {
      my ($file_name, $domain, $user) = @_;
      my @check;
      my $is_locked;
-     push @check, $file_name;
+     push(@check,$file_name);
      my %locked = &get('file_permissions',\@check,
  		      $env{'user.domain'},$env{'user.name'});
      my ($tmp)=keys(%locked);
- Line 5130  sub is_locked {
+ Line 7414  sub is_locked {
      } else {
          $is_locked = 'false';
      }
+     return $is_locked;
  }
  sub declutter_portfile {
- Line 5159  sub save_selected_files {
+ Line 7444  sub save_selected_files {
      my ($user, $path, @files) = @_;
      my $filename = $user."savedfiles";
      my @other_files = &files_not_in_path($user, $path);
-     open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
+     open (OUT, '>'.$tmpdir.$filename);
      foreach my $file (@files) {
          print (OUT $env{'form.currentpath'}.$file."\n");
      }
- Line 5346  sub modify_access_controls {
+ Line 7631  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 5522  sub unmark_as_readonly {
+ Line 7805  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 5554  sub dirlist {
+ Line 7856  sub dirlist {
                  @listing_results = map { &unescape($_); } split(/:/,$listing);
              }
              return @listing_results;
-         } elsif(!defined($alternateDirectoryRoot)) {
+         } elsif(!$alternateRoot) {
              my %allusers;
-             foreach my $tryserver (keys(%libserv)) {
+ 	    my %servers = &get_servers($udom,'library');
-                 if($hostdom{$tryserver} eq $udom) {
+  	    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') {
-                     if ($listing eq 'unknown_cmd') {
+ 		    $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.
-                         $listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.
+ 				      $udom, $tryserver);
- 					  $udom, $tryserver);
+                 } else {
-                         @listing_results = split(/:/,$listing);
+                     @listing_results = map { &unescape($_); } split(/:/,$listing);
-                     } else {
-                         @listing_results =
-                             map { &unescape($_); } split(/:/,$listing);
-                     }
-                     if ($listing_results[0] ne 'no_such_dir' &&
-                         $listing_results[0] ne 'empty'       &&
-                         $listing_results[0] ne 'con_lost') {
-                         foreach my $line (@listing_results) {
-                             my ($entry) = split(/&/,$line,2);
-                             $allusers{$entry} = 1;
-                         }
-                     }
                  }
+ 		if ($listing eq 'unknown_cmd') {
+ 		    $listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.
+ 				      $udom, $tryserver);
+ 		    @listing_results = split(/:/,$listing);
+ 		} else {
+ 		    @listing_results =
+ 			map { &unescape($_); } split(/:/,$listing);
+ 		}
+ 		if ($listing_results[0] ne 'no_such_dir' &&
+ 		    $listing_results[0] ne 'empty'       &&
+ 		    $listing_results[0] ne 'con_lost') {
+ 		    foreach my $line (@listing_results) {
+ 			my ($entry) = split(/&/,$line,2);
+ 			$allusers{$entry} = 1;
+ 		    }
+ 		}
              }
              my $alluserstr='';
              foreach my $user (sort(keys(%allusers))) {
- Line 5588  sub dirlist {
+ Line 7894  sub dirlist {
          } else {
              return ('missing user name');
          }
-     } elsif(!defined($alternateDirectoryRoot)) {
+     } elsif(!defined($getpropath)) {
-         my $tryserver;
+         my @all_domains = sort(&all_domains());
-         my %alldom=();
+         foreach my $domain (@all_domains) {
-         foreach $tryserver (keys(%libserv)) {
+             $domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain';
-             $alldom{$hostdom{$tryserver}}=1;
-         }
-         my $alldomstr='';
-         foreach my $domain (sort(keys(%alldom))) {
-             $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain:';
          }
-         $alldomstr=~s/:$//;
+         return @all_domains;
-         return split(/:/,$alldomstr);
      } else {
          return ('missing domain');
      }
- Line 5610  sub dirlist {
+ Line 7910  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 5640  sub stat_file {
+ Line 7930  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 5657  sub stat_file {
+ Line 7946  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 5691  sub directcondval {
+ Line 7983  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 5758  sub devalidatecourseresdata {
+ Line 8050  sub devalidatecourseresdata {
  # --------------------------------------------------- Course Resourcedata Query
+ #
+ #  Parameters:
+ #      $coursenum    - Number of the course.
+ #      $coursedomain - Domain at which the course was created.
+ #  Returns:
+ #     A hash of the course parameters along (I think) with timestamps
+ #     and version info.
  sub get_courseresdata {
      my ($coursenum,$coursedomain)=@_;
- Line 5816  sub get_userresdata {
+ Line 8115  sub get_userresdata {
      }
      return $tmp;
  }
+ #----------------------------------------------- resdata - return resource data
+ #  Purpose:
+ #    Return resource data for either users or for a course.
+ #  Parameters:
+ #     $name      - Course/user name.
+ #     $domain    - Name of the domain the user/course is registered on.
+ #     $type      - Type of thing $name is (must be 'course' or 'user'
+ #     @which     - Array of names of resources desired.
+ #  Returns:
+ #     The value of the first reasource in @which that is found in the
+ #     resource hash.
+ #  Exceptional Conditions:
+ #     If the $type passed in is not valid (not the string 'course' or
+ #     'user', an undefined  reference is returned.
+ #     If none of the resources are found, an undef is returned
  sub resdata {
      my ($name,$domain,$type,@which)=@_;
      my $result;
- Line 5827  sub resdata {
+ Line 8140  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 5856  sub EXT_cache_status {
+ Line 8169  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 5994  sub EXT {
+ Line 8307  sub EXT {
  	    my ($map) = &decode_symb($symbparm);
  	    return &symbread($map);
  	}
+ 	if ($space eq 'filename') {
+ 	    if ($symbparm) {
+ 		return &clutter((&decode_symb($symbparm))[2]);
+ 	    }
+ 	    return &hreflocation('',$env{'request.filename'});
+ 	}
  	my ($section, $group, @groups);
  	my ($courselevelm,$courselevel);
- Line 6034  sub EXT {
+ Line 8353  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 6062  sub EXT {
+ Line 8384  sub EXT {
  		$thisparm=$parmhash{$symbparm};
  		untie(%parmhash);
  	    }
- 	    if ($thisparm) { return $thisparm; }
+ 	    if ($thisparm) { return &get_reply([$thisparm,'resource']); }
  	}
  # ------------------------------------------ fourth, look in resource metadata
- Line 6075  sub EXT {
+ Line 8397  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 6094  sub EXT {
+ Line 8417  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 6129  sub EXT {
+ Line 8451  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 6163  sub packages_tab_default {
+ Line 8497  sub packages_tab_default {
  	    $do_default=1;
  	} elsif ($pack_type eq 'extension') {
  	    push(@extension,[$package,$pack_type,$pack_part]);
- 	} else {
+ 	} elsif ($pack_part eq $part || $pack_type eq 'part') {
+ 	    # only look at packages defaults for packages that this id is
  	    push(@specifics,[$package,$pack_type,$pack_part]);
  	}
      }
- Line 6229  sub metadata {
+ Line 8564  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 =~ /^\*uploaded\/.+\.sequence$/) ) {
- 	($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 6251  sub metadata {
+ Line 8589  sub metadata {
  #	if (! exists($metacache{$uri})) {
  #	    $metacache{$uri}={};
  #	}
+ 	my $cachetime = 60*60;
          if ($liburi) {
  	    $liburi=&declutter($liburi);
              $filename=$liburi;
- Line 6261  sub metadata {
+ Line 8600  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 6351  sub metadata {
+ Line 8696  sub metadata {
  			    }
  			}
  		    } else {
  			if (defined($token->[2]->{'name'})) {
  			    $unikey.='_'.$token->[2]->{'name'};
  			}
- Line 6366  sub metadata {
+ Line 8710  sub metadata {
  		 # only ws inside the tag, and not in default, so use default
  		 # as value
  			    $metaentry{':'.$unikey}=$default;
- 			} else {
+ 			} elsif ( $internaltext =~ /\S/ ) {
- 		  # either something interesting inside the tag or default
+ 		  # something interesting inside the tag
-                   # uninteresting
  			    $metaentry{':'.$unikey}=$internaltext;
+ 			} else {
+ 		  # no interesting values, don't set a default
  			}
  # end of not-a-package not-a-library import
  		    }
- Line 6379  sub metadata {
+ Line 8724  sub metadata {
  	    }
  	}
  	my ($extension) = ($uri =~ /\.(\w+)$/);
+ 	$extension = lc($extension);
+ 	if ($extension eq 'htm') { $extension='html'; }
  	foreach my $key (keys(%packagetab)) {
  	    #no specific packages #how's our extension
  	    if ($key!~/^extension_\Q$extension\E&/) { next; }
  	    &metadata_create_package_def($uri,$key,'extension_'.$extension,
  					 \%metathesekeys);
  	}
- 	if (!exists($metaentry{':packages'})) {
+ 	if (!exists($metaentry{':packages'})
+ 	    || $packagetab{"import_defaults&extension_$extension"}) {
  	    foreach my $key (keys(%packagetab)) {
  		#no specific packages well let's get default then
  		if ($key!~/^default&/) { next; }
- Line 6422  sub metadata {
+ Line 8772  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 6491  sub devalidate_title_cache {
+ Line 8841  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 6504  sub gettitle {
+ Line 8859  sub gettitle {
  	}
  	my ($map,$resid,$url)=&decode_symb($symb);
  	my $title='';
- 	my %bighash;
+ 	if (!$map && $resid == 0 && $url =~/default\.sequence$/) {
- 	if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
+ 	    $title = $env{'course.'.$env{'request.course.id'}.'.description'};
- 		&GDBM_READER(),0640)) {
+ 	} else {
- 	    my $mapid=$bighash{'map_pc_'.&clutter($map)};
+ 	    if (tie(my %bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
- 	    $title=$bighash{'title_'.$mapid.'.'.$resid};
+ 		    &GDBM_READER(),0640)) {
- 	    untie %bighash;
+ 		my $mapid=$bighash{'map_pc_'.&clutter($map)};
+ 		$title=$bighash{'title_'.$mapid.'.'.$resid};
+ 		untie(%bighash);
+ 	    }
  	}
  	$title=~s/\&colon\;/\:/gs;
  	if ($title) {
- Line 6554  sub symblist {
+ Line 8912  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 6591  sub symbverify {
+ Line 8949  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 6599  sub symbverify {
+ Line 8960  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 6717  sub symbread {
+ Line 9081  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 6769  sub symbread {
+ Line 9133  sub symbread {
  	    return $env{$cache_str}=$syval;
          }
      }
-     &appenv('request.ambiguous' => $thisfn);
+     &appenv({'request.ambiguous' => $thisfn});
      return $env{$cache_str}='';
  }
- Line 6881  sub getCODE {
+ Line 9245  sub getCODE {
  sub rndseed {
      my ($symb,$courseid,$domain,$username)=@_;
      my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();
-     if (!$symb) {
+     if (!defined($symb)) {
  	unless ($symb=$wsymb) { return time; }
      }
      if (!$courseid) { $courseid=$wcourseid; }
- Line 7085  sub setup_random_from_rndseed {
+ Line 9448  sub setup_random_from_rndseed {
  }
  sub latest_receipt_algorithm_id {
-     return 'receipt2';
+     return 'receipt3';
  }
  sub recunique {
      my $fucourseid=shift;
      my $unique;
-     if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') {
+     if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' ||
+ 	$env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) {
  	$unique=$env{"course.$fucourseid.internal.encseed"};
      } else {
  	$unique=$perlvar{'lonReceipt'};
- Line 7102  sub recunique {
+ Line 9466  sub recunique {
  sub recprefix {
      my $fucourseid=shift;
      my $prefix;
-     if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') {
+     if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2'||
+ 	$env{"course.$fucourseid.receiptalg"} eq 'receipt3' ) {
  	$prefix=$env{"course.$fucourseid.internal.encpref"};
      } else {
  	$prefix=$perlvar{'lonHostID'};
- Line 7112  sub recprefix {
+ Line 9477  sub recprefix {
  sub ireceipt {
      my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_;
+     my $return =&recprefix($fucourseid).'-';
+     if ($env{"course.$fucourseid.receiptalg"} eq 'receipt3' ||
+ 	$env{'request.state'} eq 'construct') {
+ 	$return .= (&digest("$funame,$fudom,$fucourseid,$fusymb,$part")%10000);
+ 	return $return;
+     }
      my $cuname=unpack("%32C*",$funame);
      my $cudom=unpack("%32C*",$fudom);
      my $cucourseid=unpack("%32C*",$fucourseid);
      my $cusymb=unpack("%32C*",$fusymb);
      my $cunique=&recunique($fucourseid);
      my $cpart=unpack("%32S*",$part);
-     my $return =&recprefix($fucourseid).'-';
+     if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2') {
-     if ($env{"course.$fucourseid.receiptalg"} eq 'receipt2' ||
- 	$env{'request.state'} eq 'construct') {
  	#&logthis("doing receipt2  using parts $cpart, uname $cuname and udom $cudom gets  ".($cpart%$cuname)." and ".($cpart%$cudom));
  	$return.= ($cunique%$cuname+
- Line 7252  sub repcopy_userfile {
+ Line 9625  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 7267  sub repcopy_userfile {
+ Line 9643  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 7290  sub tokenwrapper {
+ Line 9669  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 7325  sub filelocation {
+ Line 9707  sub filelocation {
  	$file=~s-^/adm/wrapper/-/-;
  	$file=~s-^/adm/coursedocs/showdoc/-/-;
      }
      if ($file=~m:^/~:) { # is a contruction space reference
          $location = $file;
          $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
      } 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 7339  sub filelocation {
+ Line 9724  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;
          }
+     } elsif ($file =~ m-^/adm/-) {
+ 	$location = $perlvar{'lonDocRoot'}.'/'.$file;
      } else {
          $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
          $file=~s:^/res/:/:;
- Line 7355  sub filelocation {
+ Line 9741  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 7376  sub hreflocation {
+ Line 9768  sub hreflocation {
  	$file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/
  	    -/uploaded/$1/$2/-x;
      }
+     if ($file=~ m{^/userfiles/}) {
+ 	$file =~ s{^/userfiles/}{/uploaded/};
+     }
      return $file;
  }
  sub current_machine_domains {
-     my $hostname=$hostname{$perlvar{'lonHostID'}};
+     return &machine_domains(&hostname($perlvar{'lonHostID'}));
+ }
+ sub machine_domains {
+     my ($hostname) = @_;
      my @domains;
+     my %hostname = &all_hostnames();
      while( my($id, $name) = each(%hostname)) {
  #	&logthis("-$id-$name-$hostname-");
  	if ($hostname eq $name) {
- 	    push(@domains,$hostdom{$id});
+ 	    push(@domains,&host_domain($id));
  	}
      }
      return @domains;
  }
  sub current_machine_ids {
-     my $hostname=$hostname{$perlvar{'lonHostID'}};
+     return &machine_ids(&hostname($perlvar{'lonHostID'}));
+ }
+ sub machine_ids {
+     my ($hostname) = @_;
+     $hostname ||= &hostname($perlvar{'lonHostID'});
      my @ids;
-     while( my($id, $name) = each(%hostname)) {
+     my %name_to_host = &all_names();
- #	&logthis("-$id-$name-$hostname-");
+     if (ref($name_to_host{$hostname}) eq 'ARRAY') {
- 	if ($hostname eq $name) {
+ 	return @{ $name_to_host{$hostname} };
- 	    push(@ids,$id);
- 	}
      }
-     return @ids;
+     return;
  }
  sub additional_machine_domains {
- Line 7436  sub declutter {
+ Line 9839  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 7444  sub declutter {
+ Line 9849  sub declutter {
  sub clutter {
      my $thisfn='/'.&declutter(shift);
-     unless ($thisfn=~/^\/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)\//) {
+     if ($thisfn !~ m{^/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)/}
+ 	|| $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 7513  sub correct_line_ends {
+ Line 9919  sub correct_line_ends {
  sub goodbye {
     &logthis("Starting Shut down");
  #not converted to using infrastruture and probably shouldn't be
-    &logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%badServerCache))));
+    &logthis(sprintf("%-20s is %s",'%badServerCache',length(&nfreeze(\%badServerCache))));
  #converted
  #   &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
-    &logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache))));
+    &logthis(sprintf("%-20s is %s",'%homecache',length(&nfreeze(\%homecache))));
- #   &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache))));
+ #   &logthis(sprintf("%-20s is %s",'%titlecache',length(&nfreeze(\%titlecache))));
- #   &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache))));
+ #   &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&nfreeze(\%courseresdatacache))));
  #1.1 only
- #   &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache))));
+ #   &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&nfreeze(\%userresdatacache))));
- #   &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache))));
+ #   &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&nfreeze(\%getsectioncache))));
- #   &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache))));
+ #   &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&nfreeze(\%courseresversioncache))));
- #   &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%resversioncache))));
+ #   &logthis(sprintf("%-20s is %s",'%resversioncache',length(&nfreeze(\%resversioncache))));
-    &logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered))));
+    &logthis(sprintf("%-20s is %s",'%remembered',length(&nfreeze(\%remembered))));
     &logthis(sprintf("%-20s is %s",'kicks',$kicks));
     &logthis(sprintf("%-20s is %s",'hits',$hits));
     &flushcourselogs();
     &logthis("Shutting down");
  }
- BEGIN {
+ sub get_dns {
- # ----------------------------------- Read loncapa.conf and loncapa_apache.conf
+     my ($url,$func,$ignore_cache) = @_;
-     unless ($readit) {
+     if (!$ignore_cache) {
- {
+ 	my ($content,$cached)=
-     my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf');
+ 	    &Apache::lonnet::is_cached_new('dns',$url);
-     %perlvar = (%perlvar,%{$configvars});
+ 	if ($cached) {
- }
+ 	    &$func($content);
+ 	    return;
+ 	}
+     }
+     my %alldns;
+     open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
+     foreach my $dns (<$config>) {
+ 	next if ($dns !~ /^\^(\S*)/x);
+         my $line = $1;
+         my ($host,$protocol) = split(/:/,$line);
+         if ($protocol ne 'https') {
+             $protocol = 'http';
+         }
+ 	$alldns{$host} = $protocol;
+     }
+     while (%alldns) {
+ 	my ($dns) = keys(%alldns);
+ 	my $ua=new LWP::UserAgent;
+ 	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);
+ 	&$func(\@content);
+ 	return;
+     }
+     close($config);
+     my $which = (split('/',$url))[3];
+     &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");
+     open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab");
+     my @content = <$config>;
+     &$func(\@content);
+     return;
+ }
  # ------------------------------------------------------------ Read domain file
  {
-     %domaindescription = ();
+     my $loaded;
-     %domain_auth_def = ();
+     my %domain;
-     %domain_auth_arg_def = ();
-     my $fh;
-     if (open($fh,"<".$Apache::lonnet::perlvar{'lonTabDir'}.'/domain.tab')) {
- 	while (my $line = <$fh>) {
-            next if ($line =~ /^(\#|\s*$)/);
- #           next if /^\#/;
-            chomp $line;
-            my ($domain, $domain_description, $def_auth, $def_auth_arg,
- 	       $def_lang, $city, $longi, $lati, $primary) = split(/:/,$line,9);
- 	   $domain_auth_def{$domain}=$def_auth;
-            $domain_auth_arg_def{$domain}=$def_auth_arg;
- 	   $domaindescription{$domain}=$domain_description;
- 	   $domain_lang_def{$domain}=$def_lang;
- 	   $domain_city{$domain}=$city;
- 	   $domain_longi{$domain}=$longi;
- 	   $domain_lati{$domain}=$lati;
-            $domain_primary{$domain}=$primary;
-  #         &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");
+     sub parse_domain_tab {
- #          &logthis("Domain.tab: $domain ".$domaindescription{$domain} );
+ 	my ($lines) = @_;
+ 	foreach my $line (@$lines) {
+ 	    next if ($line =~ /^(\#|\s*$ )/x);
+ 	    chomp($line);
+ 	    my ($name,@elements) = split(/:/,$line,9);
+ 	    my %this_domain;
+ 	    foreach my $field ('description', 'auth_def', 'auth_arg_def',
+ 			       'lang_def', 'city', 'longi', 'lati',
+ 			       'primary') {
+ 		$this_domain{$field} = shift(@elements);
+ 	    }
+ 	    $domain{$name} = \%this_domain;
  	}
      }
-     close ($fh);
+     sub reset_domain_info {
+ 	undef($loaded);
+ 	undef(%domain);
+     }
+     sub load_domain_tab {
+ 	my ($ignore_cache) = @_;
+ 	&get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache);
+ 	my $fh;
+ 	if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) {
+ 	    my @lines = <$fh>;
+ 	    &parse_domain_tab(\@lines);
+ 	}
+ 	close($fh);
+ 	$loaded = 1;
+     }
+     sub domain {
+ 	&load_domain_tab() if (!$loaded);
+ 	my ($name,$what) = @_;
+ 	return if ( !exists($domain{$name}) );
+ 	if (!$what) {
+ 	    return $domain{$name}{'description'};
+ 	}
+ 	return $domain{$name}{$what};
+     }
+     sub domain_info {
+         &load_domain_tab() if (!$loaded);
+         return %domain;
+     }
  }
  # ------------------------------------------------------------- Read hosts file
  {
-     open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
+     my %hostname;
+     my %hostdom;
+     my %libserv;
+     my $loaded;
+     my %name_to_host;
+     my %internetdom;
+     sub parse_hosts_tab {
+ 	my ($file) = @_;
+ 	foreach my $configline (@$file) {
+ 	    next if ($configline =~ /^(\#|\s*$ )/x);
+ 	    next if ($configline =~ /^\^/);
+ 	    chomp($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;
+                 }
+ 	    }
+ 	}
+     }
+     sub reset_hosts_info {
+ 	&purge_remembered();
+ 	&reset_domain_info();
+ 	&reset_hosts_ip_info();
+ 	undef(%name_to_host);
+ 	undef(%hostname);
+ 	undef(%hostdom);
+ 	undef(%libserv);
+ 	undef($loaded);
+     }
-     while (my $configline=<$config>) {
+     sub load_hosts_tab {
-        next if ($configline =~ /^(\#|\s*$)/);
+ 	my ($ignore_cache) = @_;
-        chomp($configline);
+ 	&get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache);
-        my ($id,$domain,$role,$name)=split(/:/,$configline);
+ 	open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
-        $name=~s/\s//g;
+ 	my @config = <$config>;
-        if ($id && $domain && $role && $name) {
+ 	&parse_hosts_tab(\@config);
- 	 $hostname{$id}=$name;
+ 	close($config);
- 	 $hostdom{$id}=$domain;
+ 	$loaded=1;
- 	 if ($role eq 'library') { $libserv{$id}=$name; }
+     }
-        }
+     sub hostname {
+ 	&load_hosts_tab() if (!$loaded);
+ 	my ($lonid) = @_;
+ 	return $hostname{$lonid};
+     }
+     sub all_hostnames {
+ 	&load_hosts_tab() if (!$loaded);
+ 	return %hostname;
+     }
+     sub all_names {
+ 	&load_hosts_tab() if (!$loaded);
+ 	return %name_to_host;
+     }
+     sub all_host_domain {
+         &load_hosts_tab() if (!$loaded);
+         return %hostdom;
+     }
+     sub is_library {
+ 	&load_hosts_tab() if (!$loaded);
+ 	return exists($libserv{$_[0]});
+     }
+     sub all_library {
+ 	&load_hosts_tab() if (!$loaded);
+ 	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);
+ 	my ($domain,$type) = @_;
+ 	my %possible_hosts = ($type eq 'library') ? %libserv
+ 	                                          : %hostname;
+ 	my %result;
+ 	if (ref($domain) eq 'ARRAY') {
+ 	    while ( my ($host,$hostname) = each(%possible_hosts)) {
+ 		if (grep(/^\Q$hostdom{$host}\E$/,@$domain)) {
+ 		    $result{$host} = $hostname;
+ 		}
+ 	    }
+ 	} else {
+ 	    while ( my ($host,$hostname) = each(%possible_hosts)) {
+ 		if ($hostdom{$host} eq $domain) {
+ 		    $result{$host} = $hostname;
+ 		}
+ 	    }
+ 	}
+ 	return %result;
+     }
+     sub get_unique_servers {
+         my %unique = reverse &get_servers(@_);
+         return reverse %unique;
+     }
+     sub host_domain {
+ 	&load_hosts_tab() if (!$loaded);
+ 	my ($lonid) = @_;
+ 	return $hostdom{$lonid};
+     }
+     sub all_domains {
+ 	&load_hosts_tab() if (!$loaded);
+ 	my %seen;
+ 	my @uniq = grep(!$seen{$_}++, values(%hostdom));
+ 	return @uniq;
+     }
+     sub internet_dom {
+         &load_hosts_tab() if (!$loaded);
+         my ($lonid) = @_;
+         return $internetdom{$lonid};
      }
-     close($config);
-     # FIXME: dev server don't want this, production servers _do_ want this
-     #&get_iphost();
  }
- sub get_iphost {
+ {
-     if (%iphost) { return %iphost; }
+     my %iphost;
      my %name_to_ip;
-     foreach my $id (keys(%hostname)) {
+     my %lonid_to_ip;
- 	my $name=$hostname{$id};
- 	my $ip;
+     sub get_hosts_from_ip {
- 	if (!exists($name_to_ip{$name})) {
+ 	my ($ip) = @_;
- 	    $ip = gethostbyname($name);
+ 	my %iphosts = &get_iphost();
- 	    if (!$ip || length($ip) ne 4) {
+ 	if (ref($iphosts{$ip})) {
- 		&logthis("Skipping host $id name $name no IP found");
+ 	    return @{$iphosts{$ip}};
- 		next;
+ 	}
+ 	return;
+     }
+     sub reset_hosts_ip_info {
+ 	undef(%iphost);
+ 	undef(%name_to_ip);
+ 	undef(%lonid_to_ip);
+     }
+     sub get_host_ip {
+ 	my ($lonid) = @_;
+ 	if (exists($lonid_to_ip{$lonid})) {
+ 	    return $lonid_to_ip{$lonid};
+ 	}
+ 	my $name=&hostname($lonid);
+    	my $ip = gethostbyname($name);
+ 	return if (!$ip || length($ip) ne 4);
+ 	$ip=inet_ntoa($ip);
+ 	$name_to_ip{$name}   = $ip;
+ 	$lonid_to_ip{$lonid} = $ip;
+ 	return $ip;
+     }
+     sub get_iphost {
+ 	my ($ignore_cache) = @_;
+ 	if (!$ignore_cache) {
+ 	    if (%iphost) {
+ 		return %iphost;
+ 	    }
+ 	    my ($ip_info,$cached)=
+ 		&Apache::lonnet::is_cached_new('iphost','iphost');
+ 	    if ($cached) {
+ 		%iphost      = %{$ip_info->[0]};
+ 		%name_to_ip  = %{$ip_info->[1]};
+ 		%lonid_to_ip = %{$ip_info->[2]};
+ 		return %iphost;
  	    }
- 	    $ip=inet_ntoa($ip);
- 	    $name_to_ip{$name} = $ip;
- 	} else {
- 	    $ip = $name_to_ip{$name};
  	}
- 	push(@{$iphost{$ip}},$id);
+ 	# get yesterday's info for fallback
+ 	my %old_name_to_ip;
+ 	my ($ip_info,$cached)=
+ 	    &Apache::lonnet::is_cached_new('iphost','iphost');
+ 	if ($cached) {
+ 	    %old_name_to_ip = %{$ip_info->[1]};
+ 	}
+ 	my %name_to_host = &all_names();
+ 	foreach my $name (keys(%name_to_host)) {
+ 	    my $ip;
+ 	    if (!exists($name_to_ip{$name})) {
+ 		$ip = gethostbyname($name);
+ 		if (!$ip || length($ip) ne 4) {
+ 		    if (defined($old_name_to_ip{$name})) {
+ 			$ip = $old_name_to_ip{$name};
+ 			&logthis("Can't find $name defaulting to old $ip");
+ 		    } else {
+ 			&logthis("Name $name no IP found");
+ 			next;
+ 		    }
+ 		} else {
+ 		    $ip=inet_ntoa($ip);
+ 		}
+ 		$name_to_ip{$name} = $ip;
+ 	    } else {
+ 		$ip = $name_to_ip{$name};
+ 	    }
+ 	    foreach my $id (@{ $name_to_host{$name} }) {
+ 		$lonid_to_ip{$id} = $ip;
+ 	    }
+ 	    push(@{$iphost{$ip}},@{$name_to_host{$name}});
+ 	}
+ 	&Apache::lonnet::do_cache_new('iphost','iphost',
+ 				      [\%iphost,\%name_to_ip,\%lonid_to_ip],
+*60*60);
+ 	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);
      }
-     return %iphost;
+ }
+ 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 {
+ # ----------------------------------- Read loncapa.conf and loncapa_apache.conf
+     unless ($readit) {
+ {
+     my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf');
+     %perlvar = (%perlvar,%{$configvars});
  }
  # ------------------------------------------------------ Read spare server file
  {
      open(my $config,"<$perlvar{'lonTabDir'}/spare.tab");
- Line 7676  sub get_iphost {
+ Line 10416  sub get_iphost {
      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 7688  $memcache=new Cache::Memcached({'servers
+ Line 10475  $memcache=new Cache::Memcached({'servers
  $processmarker='_'.time.'_'.$perlvar{'lonHostID'};
  $dumpcount=0;
+ $locknum=0;
  &logtouch();
  &logthis('<font color="yellow">INFO: Read configuration</font>');
- Line 7855  when the connection is brought back up
+ Line 10643  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 7870  that was requested
+ Line 10658  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 7901  authentication scheme
+ Line 10693  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 7942  X<userenvironment()>
+ Line 10739  X<userenvironment()>
  B<userenvironment($udom,$uname,@what)>: gets the values of the keys
  passed in @what from the requested user's environment, returns a hash
+ =item *
+ X<userlog_query()>
+ B<userlog_query($uname,$udom,%filters)>: retrieves data from a user's
+ activity.log file. %filters defines filters applied when parsing the
+ log file. These can be start or end timestamps, or the type of action
+ - log to look for Login or Logout events, check for Checkin or
+ Checkout, role for role selection. The response is in the form
+ timestamp1:hostid1:event1&timestamp2:hostid2:event2 where events are
+ escaped strings of the action recorded in the activity.log file.
  =back
  =head2 User Roles
- Line 7966  and course level
+ Line 10773  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,$types,$roles,$roledoms) : All arguments are optional.  Returns a hash of a user's roles, with keys set to colon-sparated $uname,$udom,and $role, and value set to colon-separated start and end times for 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 if roles reported. If no array ref is provided for types, will default to return only active roles.
+ 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-separated $uname,$udom,$role, and
+ (optionally) if $withsec is true, a fourth colon-separated item - $section.
+ For each key, value is set to colon-separated start and end times for
+ 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
+ provided for types, will default to return only active roles.
  =back
  =head2 User Modification
- Line 7980  get_my_roles($uname,$udom,$types,$roles,
+ Line 10805  get_my_roles($uname,$udom,$types,$roles,
  =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 7997  modifyuserauth($udom,$uname,$umode,$upas
+ Line 10822  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 8016  Inputs:
+ Line 10849  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 8044  Inputs:
+ Line 10877  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 8077  Inputs:
+ Line 10924  Inputs:
  =item $start
+ =item $type
+ =item $locktype
+ =item $cid
+ =item $selfenroll
+ =item $context
  =back
- Line 8114  setting for a specific $type, where $typ
+ Line 10971  setting for a specific $type, where $typ
  @what should be a list of parameters to ask about. This routine caches
  answers for 5 minutes.
+ =item *
+ get_courseresdata($courseid, $domain) : dump the entire course resource
+ data base, returning a hash that is keyed by the resource name and has
+ values that are the resource value.  I believe that the timestamps and
+ versions are also returned.
  =back
  =head2 Course Modification
- Line 8127  database) for a course
+ Line 10992  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 8377  Returns:
+ Line 11246  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 8395  critical subroutine
+ Line 11264  critical subroutine
  =item *
- get_dom($namespace,$storearr,$udomain) : returns hash with keys from array
+ get_dom($namespace,$storearr,$udom,$uhome) : returns hash with keys from
- reference filled in from namespace found in domain level on primary domain server ($udomain is optional)
+ array reference filled in from namespace found in domain level on either
+ specified domain server ($uhome) or primary domain server ($udom and $uhome are optional).
  =item *
- put_dom($namespace,$storehash,$udomain) :  stores hash in namespace at domain level on primary domain server ($udomain is optional)
+ put_dom($namespace,$storehash,$udom,$uhome) :  stores hash in namespace at
+ 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
- Line 8416  dirlist($uri) : return directory list ba
+ Line 11300  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
- Line 8558  userfileupload(): main rotine for puttin
+ Line 11449  userfileupload(): main rotine for puttin
             filename, and the contents of the file to create/modifed exist
             the filename is in $env{'form.'.$formname.'.filename'} and the
             contents of the file is located in $env{'form.'.$formname}
-  coursedoc - if true, store the file in the course of the active role
+  context - if coursedoc, store the file in the course of the active role
-              of the current user
+              of the current user;
+            if 'existingfile': store in 'overwrites' in /home/httpd/perl/tmp
+            if 'canceloverwrite': delete file in tmp/overwrites directory
   subdir - required - subdirectory to put the file in under ../userfiles/
           if undefined, it will be placed in "unknown"
- Line 8581  returns: the new clean filename
+ Line 11474  returns: the new clean filename
  =item *
- finishuserfileupload(): routine that creaes and sends the file to
+ finishuserfileupload(): routine that creates and sends the file to
  userspace, probably shouldn't be called directly
    docuname: username or courseid of destination for the file
    docudom: domain of user/course of destination for the file
    formname: same as for userfileupload()
-   fname: filename (inculding subdirectories) for the file
+   fname: filename (including subdirectories) for the file
+   parser: if 'parse', will parse (html) file to extract references to objects, links etc.
+   allfiles: reference to hash used to store objects found by parser
+   codebase: reference to hash used for codebases of java objects found by parser
+   thumbwidth: width (pixels) of thumbnail to be created for uploaded image
+   thumbheight: height (pixels) of thumbnail to be created for uploaded image
+   resizewidth: width to be used to resize image using resizeImage from ImageMagick
+   resizeheight: height to be used to resize image using resizeImage from ImageMagick
+   context: if 'overwrite', will move the uploaded file from its temporary location to
+             userfiles to facilitate overwriting a previously uploaded file with same name.
   returns either the url of the uploaded file (/uploaded/....) if successful
-  and /adm/notfound.html if unsuccessful
+  and /adm/notfound.html if unsuccessful (or an error message if context
+  was 'overwrite').
  =item *
- Line 8793  symblist($mapname,%newhash) : update sym
+ Line 11697  symblist($mapname,%newhash) : update sym
  =back
  =cut

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

Removed from v.1.833
changed lines
	Added in v.1.1056.4.14