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.1144 and 1.1172.2.146.2.9

-version 1.1144, 2011/11/07 20:05:59
+version 1.1172.2.146.2.9, 2023/01/21 00:14:13
  Line 74  use strict;
  use LWP::UserAgent();
  use HTTP::Date;
  use Image::Magick;
+ use CGI::Cookie;
- use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
+ use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $deftex
              $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease
-             %managerstab);
+             %managerstab $passwdmin);
  my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
      %userrolehash, $processmarker, $dumpcount, %coursedombuf,
- Line 89  use GDBM_File;
+ Line 90  use GDBM_File;
  use HTML::LCParser;
  use Fcntl qw(:flock);
  use Storable qw(thaw nfreeze);
- use Time::HiRes qw( gettimeofday tv_interval );
+ use Time::HiRes qw( sleep gettimeofday tv_interval );
  use Cache::Memcached;
  use Digest::MD5;
  use Math::Random;
  use File::MMagic;
+ use Net::CIDR;
+ use Sys::Hostname::FQDN();
  use LONCAPA qw(:DEFAULT :match);
  use LONCAPA::Configuration;
+ use LONCAPA::lonmetadata;
+ use LONCAPA::Lond;
+ use LONCAPA::transliterate;
  use File::Copy;
  my $readit;
- my $max_connection_retries = 10;     # Or some such value.
+ my $max_connection_retries = 20;     # Or some such value.
  require Exporter;
  our @ISA = qw (Exporter);
  our @EXPORT = qw(%env);
+ # ------------------------------------ Logging (parameters, docs, slots, roles)
- # --------------------------------------------------------------------- Logging
  {
      my $logid;
-     sub instructor_log {
+     sub write_log {
- 	my ($hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_;
+ 	my ($context,$hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_;
-         if (($cnum eq '') || ($cdom eq '')) {
+         if ($context eq 'course') {
-             $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
+             if (($cnum eq '') || ($cdom eq '')) {
-             $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
+                 $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
+                 $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
+             }
          }
- 	$logid++;
+ 	$logid ++;
          my $now = time();
  	my $id=$now.'00000'.$$.'00000'.$logid;
- 	return &Apache::lonnet::put('nohist_'.$hash_name,
+         my $ip = &get_requestor_ip();
- 				    { $id => {
+         my $logentry = {
- 					'exe_uname' => $env{'user.name'},
+                          $id => {
- 					'exe_udom'  => $env{'user.domain'},
+                                   'exe_uname' => $env{'user.name'},
- 					'exe_time'  => $now,
+                                   'exe_udom'  => $env{'user.domain'},
- 					'exe_ip'    => $ENV{'REMOTE_ADDR'},
+                                   'exe_time'  => $now,
- 					'delflag'   => $delflag,
+                                   'exe_ip'    => $ip,
- 					'logentry'  => $storehash,
+                                   'delflag'   => $delflag,
- 					'uname'     => $uname,
+                                   'logentry'  => $storehash,
- 					'udom'      => $udom,
+                                   'uname'     => $uname,
- 				    }
+                                   'udom'      => $udom,
- 				  },$cdom,$cnum);
+                                 }
+                        };
+         return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum);
      }
  }
  sub logtouch {
      my $execdir=$perlvar{'lonDaemons'};
      unless (-e "$execdir/logs/lonnet.log") {
- 	open(my $fh,">>$execdir/logs/lonnet.log");
+ 	open(my $fh,">>","$execdir/logs/lonnet.log");
  	close $fh;
      }
      my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];
- Line 150  sub logthis {
+ Line 159  sub logthis {
      my $execdir=$perlvar{'lonDaemons'};
      my $now=time;
      my $local=localtime($now);
-     if (open(my $fh,">>$execdir/logs/lonnet.log")) {
+     if (open(my $fh,">>","$execdir/logs/lonnet.log")) {
  	my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string.
  	print $fh $logstring;
  	close($fh);
- Line 163  sub logperm {
+ Line 172  sub logperm {
      my $execdir=$perlvar{'lonDaemons'};
      my $now=time;
      my $local=localtime($now);
-     if (open(my $fh,">>$execdir/logs/lonnet.perm.log")) {
+     if (open(my $fh,">>","$execdir/logs/lonnet.perm.log")) {
  	print $fh "$now:$message:$local\n";
  	close($fh);
      }
- Line 257  sub get_server_loncaparev {
+ Line 266  sub get_server_loncaparev {
                  if ($caller eq 'loncron') {
                      my $ua=new LWP::UserAgent;
                      $ua->timeout(4);
+                     my $hostname = &hostname($lonhost);
                      my $protocol = $protocol{$lonhost};
                      $protocol = 'http' if ($protocol ne 'https');
-                     my $url = $protocol.'://'.&hostname($lonhost).'/adm/about.html';
+                     my $url = $protocol.'://'.$hostname.'/adm/about.html';
                      my $request=new HTTP::Request('GET',$url);
                      my $response=$ua->request($request);
                      unless ($response->is_error()) {
- Line 348  sub get_remote_globals {
+ Line 358  sub get_remote_globals {
  }
  sub remote_devalidate_cache {
-     my ($lonhost,$name,$id) = @_;
+     my ($lonhost,$cachekeys) = @_;
-     my $response = &reply('devalidatecache:'.&escape($name).':'.&escape($id),$lonhost);
+     my $items;
-     return $response;
+     return unless (ref($cachekeys) eq 'ARRAY');
+     my $cachestr = join('&',@{$cachekeys});
+     return &reply('devalidatecache:'.&escape($cachestr),$lonhost);
  }
  # -------------------------------------------------- Non-critical communication
- Line 364  sub subreply {
+ Line 376  sub subreply {
      my $lockfile=$peerfile.".lock";
      while (-e $lockfile) {	# Need to wait for the lockfile to disappear.
- 	sleep(1);
+ 	sleep(0.1);
      }
      # At this point, either a loncnew parent is listening or an old lonc
      # or loncnew child is listening so we can connect or everything's dead.
- Line 382  sub subreply {
+ Line 394  sub subreply {
  	} else {
  	    &create_connection(&hostname($server),$server);
  	}
-         sleep(1);		# Try again later if failed connection.
+         sleep(0.1);		# Try again later if failed connection.
      }
      my $answer;
      if ($client) {
- Line 401  sub reply {
+ Line 413  sub reply {
      unless (defined(&hostname($server))) { return 'no_such_host'; }
      my $answer=subreply($cmd,$server);
      if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
-        &logthis("<font color=\"blue\">WARNING:".
+         my $logged = $cmd;
-                 " $cmd to $server returned $answer</font>");
+         if ($cmd =~ /^encrypt:([^:]+):/) {
+             my $subcmd = $1;
+             if (($subcmd eq 'auth') || ($subcmd eq 'passwd') ||
+                 ($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') ||
+                 ($subcmd eq 'putdom') || ($subcmd eq 'autoexportgrades')) {
+                 (undef,undef,my @rest) = split(/:/,$cmd);
+                 if (($subcmd eq 'auth') || ($subcmd eq 'putdom')) {
+                     splice(@rest,2,1,'Hidden');
+                 } elsif ($subcmd eq 'passwd') {
+                     splice(@rest,2,2,('Hidden','Hidden'));
+                 } elsif (($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') ||
+                          ($subcmd eq 'autoexportgrades')) {
+                     splice(@rest,3,1,'Hidden');
+                 }
+                 $logged = join(':',('encrypt:'.$subcmd,@rest));
+             }
+         }
+         &logthis("<font color=\"blue\">WARNING:".
+                  " $logged to $server returned $answer</font>");
      }
      return $answer;
  }
- Line 411  sub reply {
+ Line 441  sub reply {
  sub reconlonc {
      my ($lonid) = @_;
-     my $hostname = &hostname($lonid);
      if ($lonid) {
+         my $hostname = &hostname($lonid);
  	my $peerfile="$perlvar{'lonSockDir'}/$hostname";
  	if ($hostname && -e $peerfile) {
  	    &logthis("Trying to reconnect lonc for $lonid ($hostname)");
- Line 430  sub reconlonc {
+ Line 460  sub reconlonc {
      &logthis("Trying to reconnect lonc");
      my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
-     if (open(my $fh,"<$loncfile")) {
+     if (open(my $fh,"<",$loncfile)) {
  	my $loncpid=<$fh>;
          chomp($loncpid);
          if (kill 0 => $loncpid) {
- Line 458  sub critical {
+ Line 488  sub critical {
      }
      my $answer=reply($cmd,$server);
      if ($answer eq 'con_lost') {
- 	&reconlonc("$perlvar{'lonSockDir'}/$server");
+ 	&reconlonc($server);
  	my $answer=reply($cmd,$server);
          if ($answer eq 'con_lost') {
              my $now=time;
- Line 470  sub critical {
+ Line 500  sub critical {
              $dumpcount++;
              {
  		my $dfh;
- 		if (open($dfh,">$dfilename")) {
+ 		if (open($dfh,">",$dfilename)) {
  		    print $dfh "$cmd\n";
  		    close($dfh);
  		}
              }
-             sleep 2;
+             sleep 1;
              my $wcmd='';
              {
  		my $dfh;
- 		if (open($dfh,"<$dfilename")) {
+ 		if (open($dfh,"<",$dfilename)) {
  		    $wcmd=<$dfh>;
  		    close($dfh);
  		}
- Line 595  sub transfer_profile_to_env {
+ Line 625  sub transfer_profile_to_env {
  # ---------------------------------------------------- Check for valid session
  sub check_for_valid_session {
-     my ($r) = @_;
+     my ($r,$name,$userhashref,$domref) = @_;
      my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
-     my $lonid=$cookies{'lonID'};
+     my ($lonidsdir,$linkname,$pubname,$secure,$lonid);
+     if ($name eq 'lonDAV') {
+         $lonidsdir=$r->dir_config('lonDAVsessDir');
+     } else {
+         $lonidsdir=$r->dir_config('lonIDsDir');
+         if ($name eq '') {
+             $name = 'lonID';
+         }
+     }
+     if ($name eq 'lonID') {
+         $secure = 'lonSID';
+         $linkname = 'lonLinkID';
+         $pubname = 'lonPubID';
+         if (exists($cookies{$secure})) {
+             $lonid=$cookies{$secure};
+         } elsif (exists($cookies{$name})) {
+             $lonid=$cookies{$name};
+         } elsif ((exists($cookies{$linkname})) && ($ENV{'SERVER_PORT'} != 443)) {
+             $lonid=$cookies{$linkname};
+         } elsif (exists($cookies{$pubname})) {
+             $lonid=$cookies{$pubname};
+         }
+     } else {
+         $lonid=$cookies{$name};
+     }
      return undef if (!$lonid);
      my $handle=&LONCAPA::clean_handle($lonid->value);
-     my $lonidsdir=$r->dir_config('lonIDsDir');
+     if (-l "$lonidsdir/$handle.id") {
-     return undef if (!-e "$lonidsdir/$handle.id");
+         my $link = readlink("$lonidsdir/$handle.id");
+         if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) {
+             $handle = $1;
+         }
+     }
+     if (!-e "$lonidsdir/$handle.id") {
+         if ((ref($domref)) && ($name eq 'lonID') &&
+             ($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) {
+             my ($possuname,$possudom,$possuhome) = ($1,$2,$3);
+             if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) {
+                 $$domref = $possudom;
+             }
+         }
+         return undef;
+     }
      my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
      return undef if (!$opened);
- Line 616  sub check_for_valid_session {
+ Line 684  sub check_for_valid_session {
      if (!defined($disk_env{'user.name'})
  	|| !defined($disk_env{'user.domain'})) {
+         untie(%disk_env);
  	return undef;
      }
+     if (ref($userhashref) eq 'HASH') {
+         $userhashref->{'name'} = $disk_env{'user.name'};
+         $userhashref->{'domain'} = $disk_env{'user.domain'};
+         if ($disk_env{'request.role'}) {
+             $userhashref->{'role'} = $disk_env{'request.role'};
+         }
+     }
+     untie(%disk_env);
      return $handle;
  }
- Line 641  sub timed_flock {
+ Line 720  sub timed_flock {
      }
  }
+ sub get_sessionfile_vars {
+     my ($handle,$lonidsdir,$storearr) = @_;
+     my %returnhash;
+     unless (ref($storearr) eq 'ARRAY') {
+         return %returnhash;
+     }
+     if (-l "$lonidsdir/$handle.id") {
+         my $link = readlink("$lonidsdir/$handle.id");
+         if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) {
+             $handle = $1;
+         }
+     }
+     if ((-e "$lonidsdir/$handle.id") &&
+         ($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) {
+         my ($possuname,$possudom,$possuhome) = ($1,$2,$3);
+         if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) {
+             if (open(my $idf,'+<',"$lonidsdir/$handle.id")) {
+                 flock($idf,LOCK_SH);
+                 if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",
+                         &GDBM_READER(),0640)) {
+                     foreach my $item (@{$storearr}) {
+                         $returnhash{$item} = $disk_env{$item};
+                     }
+                     untie(%disk_env);
+                 }
+             }
+         }
+     }
+     return %returnhash;
+ }
  # ---------------------------------------------------------- Append Environment
  sub appenv {
- Line 651  sub appenv {
+ Line 761  sub appenv {
  	    if (($key =~ /^user\.role/) || ($key =~ /^user\.priv/)) {
                  $refused = 1;
                  if (ref($roles) eq 'ARRAY') {
-                     my ($type,$role) = ($key =~ /^user\.(role|priv)\.([^.]+)\./);
+                     my ($type,$role) = ($key =~ m{^user\.(role|priv)\.(.+?)\./});
                      if (grep(/^\Q$role\E$/,@{$roles})) {
                          $refused = 0;
                      }
- Line 666  sub appenv {
+ Line 776  sub appenv {
                  $env{$key}=$newenv->{$key};
              }
          }
-         my $opened = open(my $env_file,'+<',$env{'user.environment'});
+         my $lonids = $perlvar{'lonIDsDir'};
-         if ($opened
+         if ($env{'user.environment'} =~ m{^\Q$lonids/\E$match_username\_\d+\_$match_domain\_[\w\-.]+\.id$}) {
- 	    && &timed_flock($env_file,LOCK_EX)
+             my $opened = open(my $env_file,'+<',$env{'user.environment'});
- 	    &&
+             if ($opened
- 	    tie(my %disk_env,'GDBM_File',$env{'user.environment'},
+ 	        && &timed_flock($env_file,LOCK_EX)
- 	        (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
+ 	        &&
- 	    while (my ($key,$value) = each(%{$newenv})) {
+ 	        tie(my %disk_env,'GDBM_File',$env{'user.environment'},
- 	        $disk_env{$key} = $value;
+ 	            (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
- 	    }
+ 	        while (my ($key,$value) = each(%{$newenv})) {
- 	    untie(%disk_env);
+ 	            $disk_env{$key} = $value;
+ 	        }
+ 	        untie(%disk_env);
+             }
          }
      }
      return 'ok';
- Line 791  sub userload {
+ Line 904  sub userload {
  	while ($filename=readdir(LONIDS)) {
  	    next if ($filename eq '.' || $filename eq '..');
  	    next if ($filename =~ /publicuser_\d+\.id/);
+             next if ($filename =~ /^[a-f0-9]+_linked\.id$/);
  	    my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
  	    if ($curtime-$mtime < 1800) { $numusers++; }
  	}
- Line 808  sub userload {
+ Line 922  sub userload {
  # ------------------------------ Find server with least workload from spare.tab
  sub spareserver {
-     my ($loadpercent,$userloadpercent,$want_server_name,$udom) = @_;
+     my ($r,$loadpercent,$userloadpercent,$want_server_name,$udom) = @_;
      my $spare_server;
      if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
      my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent
- Line 824  sub spareserver {
+ Line 938  sub spareserver {
      if (ref($spareshash) eq 'HASH') {
          if (ref($spareshash->{'primary'}) eq 'ARRAY') {
              foreach my $try_server (@{ $spareshash->{'primary'} }) {
-                 if ($uint_dom) {
+                 next unless (&spare_can_host($udom,$uint_dom,$remotesessions,
-                     next unless (&spare_can_host($udom,$uint_dom,$remotesessions,
+                                              $try_server));
-                                                  $try_server));
-                 }
  	        ($spare_server, $lowest_load) =
  	            &compare_server_load($try_server, $spare_server, $lowest_load);
              }
- Line 838  sub spareserver {
+ Line 950  sub spareserver {
          if (!$found_server) {
              if (ref($spareshash->{'default'}) eq 'ARRAY') {
  	        foreach my $try_server (@{ $spareshash->{'default'} }) {
-                     if ($uint_dom) {
+                     next unless (&spare_can_host($udom,$uint_dom,
-                         next unless (&spare_can_host($udom,$uint_dom,
+                                                  $remotesessions,$try_server));
-                                                      $remotesessions,$try_server));
-                     }
  	            ($spare_server, $lowest_load) =
  		        &compare_server_load($try_server, $spare_server, $lowest_load);
                  }
- Line 850  sub spareserver {
+ Line 960  sub spareserver {
      }
      if (!$want_server_name) {
-         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)) {
+                 my $protocol = 'http';
+                 if ($protocol{$spare_server} eq 'https') {
+                     $protocol = $protocol{$spare_server};
+                 }
+                 my $alias = &Apache::lonnet::use_proxy_alias($r,$spare_server);
+                 $hostname = $alias if ($alias ne '');
  	        $spare_server = $protocol.'://'.$hostname;
              }
          }
- Line 865  sub spareserver {
+ Line 977  sub spareserver {
  }
  sub compare_server_load {
-     my ($try_server, $spare_server, $lowest_load) = @_;
+     my ($try_server, $spare_server, $lowest_load, $required) = @_;
+     if ($required) {
+         my ($reqdmajor,$reqdminor) = ($required =~ /^(\d+)\.(\d+)$/);
+         my $remoterev = &get_server_loncaparev(undef,$try_server);
+         my ($major,$minor) = ($remoterev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
+         if (($major eq '' && $minor eq '') ||
+             (($reqdmajor > $major) || (($reqdmajor == $major) && ($reqdminor > $minor)))) {
+             return ($spare_server,$lowest_load);
+         }
+     }
      my $loadans     = &reply('load',    $try_server);
      my $userloadans = &reply('userload',$try_server);
- Line 913  sub find_existing_session {
+ Line 1035  sub find_existing_session {
      return;
  }
+ # check if user's browser sent load balancer cookie and server still has session
+ # and is not overloaded.
+ sub check_for_balancer_cookie {
+     my ($r,$update_mtime) = @_;
+     my ($otherserver,$cookie);
+     my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
+     if (exists($cookies{'balanceID'})) {
+         my $balid = $cookies{'balanceID'};
+         $cookie=&LONCAPA::clean_handle($balid->value);
+         my $balancedir=$r->dir_config('lonBalanceDir');
+         if ((-d $balancedir) && (-e "$balancedir/$cookie.id")) {
+             if ($cookie =~ /^($match_domain)_($match_username)_[a-f0-9]+$/) {
+                 my ($possudom,$possuname) = ($1,$2);
+                 my $has_session = 0;
+                 if ((&domain($possudom) ne '') &&
+                     (&homeserver($possuname,$possudom) ne 'no_host')) {
+                     my $try_server;
+                     my $opened = open(my $idf,'+<',"$balancedir/$cookie.id");
+                     if ($opened) {
+                         flock($idf,LOCK_SH);
+                         while (my $line = <$idf>) {
+                             chomp($line);
+                             if (&hostname($line) ne '') {
+                                 $try_server = $line;
+                                 last;
+                             }
+                         }
+                         close($idf);
+                         if (($try_server) &&
+                             (&has_user_session($try_server,$possudom,$possuname))) {
+                             my $lowest_load = 30000;
+                             ($otherserver,$lowest_load) =
+                                 &compare_server_load($try_server,undef,$lowest_load);
+                             if ($otherserver ne '' && $lowest_load < 100) {
+                                 $has_session = 1;
+                             } else {
+                                 undef($otherserver);
+                             }
+                         }
+                     }
+                 }
+                 if ($has_session) {
+                     if ($update_mtime) {
+                         my $atime = my $mtime = time;
+                         utime($atime,$mtime,"$balancedir/$cookie.id");
+                     }
+                 } else {
+                     unlink("$balancedir/$cookie.id");
+                 }
+             }
+         }
+     }
+     return ($otherserver,$cookie);
+ }
+ sub updatebalcookie {
+     my ($cookie,$balancer,$lastentry)=@_;
+     if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) {
+         my ($udom,$uname) = ($1,$2);
+         my $uprimary_id = &domain($udom,'primary');
+         my $uintdom = &internet_dom($uprimary_id);
+         my $intdom = &internet_dom($balancer);
+         my $serverhomedom = &host_domain($balancer);
+         if (($uintdom ne '') && ($uintdom eq $intdom)) {
+             return &reply('updatebalcookie:'.&escape($cookie).':'.&escape($lastentry),$balancer);
+         }
+     }
+     return;
+ }
+ sub delbalcookie {
+     my ($cookie,$balancer) =@_;
+     if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) {
+         my ($udom,$uname) = ($1,$2);
+         my $uprimary_id = &domain($udom,'primary');
+         my $uintdom = &internet_dom($uprimary_id);
+         my $intdom = &internet_dom($balancer);
+         my $serverhomedom = &host_domain($balancer);
+         if (($uintdom ne '') && ($uintdom eq $intdom)) {
+             return &reply('delbalcookie:'.&escape($cookie),$balancer);
+         }
+     }
+ }
  # -------------------------------- ask if server already has a session for user
  sub has_user_session {
      my ($lonid,$udom,$uname) = @_;
- Line 926  sub has_user_session {
+ Line 1132  sub has_user_session {
  # --------- determine least loaded server in a user's domain which allows login
  sub choose_server {
-     my ($udom,$checkloginvia) = @_;
+     my ($udom,$checkloginvia,$required,$skiploadbal) = @_;
      my %domconfhash = &Apache::loncommon::get_domainconf($udom);
      my %servers = &get_servers($udom);
      my $lowest_load = 30000;
-     my ($login_host,$hostname,$portal_path);
+     my ($login_host,$hostname,$portal_path,$isredirect,$balancers);
+     if ($skiploadbal) {
+         ($balancers,my $cached)=&is_cached_new('loadbalancing',$udom);
+         unless (defined($cached)) {
+             my $cachetime = 60*60*24;
+             my %domconfig =
+                 &Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom);
+             if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
+                 $balancers = &do_cache_new('loadbalancing',$udom,$domconfig{'loadbalancing'},
+                                            $cachetime);
+             }
+         }
+     }
      foreach my $lonhost (keys(%servers)) {
          my $loginvia;
+         if ($skiploadbal) {
+             if (ref($balancers) eq 'HASH') {
+                 next if (exists($balancers->{$lonhost}));
+             }
+         }
          if ($checkloginvia) {
              $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};
              if ($loginvia) {
                  my ($server,$path) = split(/:/,$loginvia);
                  ($login_host, $lowest_load) =
-                     &compare_server_load($server, $login_host, $lowest_load);
+                     &compare_server_load($server, $login_host, $lowest_load, $required);
                  if ($login_host eq $server) {
                      $portal_path = $path;
+                     $isredirect = 1;
                  }
              } else {
                  ($login_host, $lowest_load) =
-                     &compare_server_load($lonhost, $login_host, $lowest_load);
+                     &compare_server_load($lonhost, $login_host, $lowest_load, $required);
                  if ($login_host eq $lonhost) {
                      $portal_path = '';
+                     $isredirect = '';
                  }
              }
          } else {
              ($login_host, $lowest_load) =
-                 &compare_server_load($lonhost, $login_host, $lowest_load);
+                 &compare_server_load($lonhost, $login_host, $lowest_load, $required);
          }
      }
      if ($login_host ne '') {
          $hostname = &hostname($login_host);
      }
-     return ($login_host,$hostname,$portal_path);
+     return ($login_host,$hostname,$portal_path,$isredirect,$lowest_load);
+ }
+ sub get_course_sessions {
+     my ($cnum,$cdom,$lastactivity) = @_;
+     my %servers = &internet_dom_servers($cdom);
+     my %returnhash;
+     foreach my $server (sort(keys(%servers))) {
+         my $rep = &reply("coursesessions:$cdom:$cnum:$lastactivity",$server);
+         my @pairs=split(/\&/,$rep);
+         unless (($rep eq 'unknown_cmd') || ($rep =~ /^error/)) {
+             foreach my $item (@pairs) {
+                 my ($key,$value)=split(/=/,$item,2);
+                 $key = &unescape($key);
+                 next if ($key =~ /^error: 2 /);
+                 if (exists($returnhash{$key})) {
+                     next if ($value < $returnhash{$key});
+                 }
+                 $returnhash{$key}=$value;
+             }
+         }
+     }
+     return %returnhash;
  }
  # --------------------------------------------- Try to change a user's password
- Line 995  sub changepass {
+ Line 1242  sub changepass {
      } 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.");
+     } elsif ($answer =~ "^prioruse") {
+        &logthis("$server refused to change $uname in $udom password because ".
+                 "the password had been used before");
      }
      return $answer;
  }
- Line 1004  sub changepass {
+ Line 1254  sub changepass {
  sub queryauthenticate {
      my ($uname,$udom)=@_;
      my $uhome=&homeserver($uname,$udom);
-     if (!$uhome) {
+     if ((!$uhome) || ($uhome eq 'no_host')) {
  	&logthis("User $uname at $udom is unknown when looking for authentication mechanism");
  	return 'no_host';
      }
- Line 1053  sub authenticate {
+ Line 1303  sub authenticate {
      }
      if ($answer eq 'non_authorized') {
  	&logthis("User $uname at $udom rejected by $uhome");
  	return 'no_host';
      }
      &logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
      return 'no_host';
  }
+ sub can_switchserver {
+     my ($udom,$home) = @_;
+     my ($canswitch,@intdoms);
+     my $internet_names = &get_internet_names($home);
+     if (ref($internet_names) eq 'ARRAY') {
+         @intdoms = @{$internet_names};
+     }
+     my $uint_dom = &internet_dom(&domain($udom,'primary'));
+     if ($uint_dom ne '' && grep(/^\Q$uint_dom\E$/,@intdoms)) {
+         $canswitch = 1;
+     } else {
+          my $serverhomeID = &get_server_homeID(&hostname($home));
+          my $serverhomedom = &host_domain($serverhomeID);
+          my %defdomdefaults = &get_domain_defaults($serverhomedom);
+          my %udomdefaults = &get_domain_defaults($udom);
+          my $remoterev = &get_server_loncaparev('',$home);
+          $canswitch = &can_host_session($udom,$home,$remoterev,
+                                         $udomdefaults{'remotesessions'},
+                                         $defdomdefaults{'hostedsessions'});
+     }
+     return $canswitch;
+ }
  sub can_host_session {
      my ($udom,$lonhost,$remoterev,$remotesessions,$hostedsessions) = @_;
      my $canhost = 1;
- Line 1124  sub can_host_session {
+ Line 1397  sub can_host_session {
  sub spare_can_host {
      my ($udom,$uint_dom,$remotesessions,$try_server)=@_;
      my $canhost=1;
-     my @intdoms;
+     my $try_server_hostname = &hostname($try_server);
-     my $internet_names = &Apache::lonnet::get_internet_names($try_server);
+     my $serverhomeID = &get_server_homeID($try_server_hostname);
-     if (ref($internet_names) eq 'ARRAY') {
+     my $serverhomedom = &host_domain($serverhomeID);
-         @intdoms = @{$internet_names};
+     my %defdomdefaults = &get_domain_defaults($serverhomedom);
+     if (ref($defdomdefaults{'offloadnow'}) eq 'HASH') {
+         if ($defdomdefaults{'offloadnow'}{$try_server}) {
+             $canhost = 0;
+         }
      }
-     unless (grep(/^\Q$uint_dom\E$/,@intdoms)) {
+     if ($canhost) {
-         my $serverhomeID = &Apache::lonnet::get_server_homeID($try_server);
+         if (ref($defdomdefaults{'offloadoth'}) eq 'HASH') {
-         my $serverhomedom = &Apache::lonnet::host_domain($serverhomeID);
+             if ($defdomdefaults{'offloadoth'}{$try_server}) {
-         my %defdomdefaults = &Apache::lonnet::get_domain_defaults($serverhomedom);
+                 unless (&shared_institution($udom,$try_server)) {
-         my $remoterev = &Apache::lonnet::get_server_loncaparev(undef,$try_server);
+                     $canhost = 0;
-         $canhost = &can_host_session($udom,$try_server,$remoterev,
+                 }
-                                      $remotesessions,
+             }
-                                      $defdomdefaults{'hostedsessions'});
+         }
+     }
+     if (($canhost) && ($uint_dom)) {
+         my @intdoms;
+         my $internet_names = &get_internet_names($try_server);
+         if (ref($internet_names) eq 'ARRAY') {
+             @intdoms = @{$internet_names};
+         }
+         unless (grep(/^\Q$uint_dom\E$/,@intdoms)) {
+             my $remoterev = &get_server_loncaparev(undef,$try_server);
+             $canhost = &can_host_session($udom,$try_server,$remoterev,
+                                          $remotesessions,
+                                          $defdomdefaults{'hostedsessions'});
+         }
      }
      return $canhost;
  }
- Line 1221  sub get_lonbalancer_config {
+ Line 1511  sub get_lonbalancer_config {
  }
  sub check_loadbalancing {
-     my ($uname,$udom) = @_;
+     my ($uname,$udom,$caller) = @_;
-     my ($is_balancer,$dom_in_use,$homeintdom,$rule_in_effect,
+     my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom,
-         $offloadto,$otherserver);
+         $rule_in_effect,$offloadto,$otherserver,$setcookie);
      my $lonhost = $perlvar{'lonHostID'};
+     my @hosts = &current_machine_ids();
      my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
      my $uintdom = &Apache::lonnet::internet_dom($uprimary_id);
      my $intdom = &Apache::lonnet::internet_dom($lonhost);
      my $serverhomedom = &host_domain($lonhost);
+     my $domneedscache;
      my $cachetime = 60*60*24;
      if (($uintdom ne '') && ($uintdom eq $intdom)) {
- Line 1244  sub check_loadbalancing {
+ Line 1535  sub check_loadbalancing {
              &Apache::lonnet::get_dom('configuration',['loadbalancing'],$dom_in_use);
          if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
              $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime);
+         } else {
+             $domneedscache = $dom_in_use;
          }
      }
      if (ref($result) eq 'HASH') {
-         my $currbalancer = $result->{'lonhost'};
+         ($is_balancer,$currtargets,$currrules,$setcookie) =
-         my $currtargets = $result->{'targets'};
+             &check_balancer_result($result,@hosts);
-         my $currrules = $result->{'rules'};
-         if ($currbalancer ne '') {
-             my @hosts = &current_machine_ids();
-             if (grep(/^\Q$currbalancer\E$/,@hosts)) {
-                 $is_balancer = 1;
-             }
-         }
          if ($is_balancer) {
              if (ref($currrules) eq 'HASH') {
                  if ($homeintdom) {
- Line 1304  sub check_loadbalancing {
+ Line 1590  sub check_loadbalancing {
              }
          }
      } elsif (($homeintdom) && ($udom ne $serverhomedom)) {
-         my ($result,$cached)=&is_cached_new('loadbalancing',$serverhomedom);
+         ($result,$cached)=&is_cached_new('loadbalancing',$serverhomedom);
          unless (defined($cached)) {
              my %domconfig =
                  &Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom);
              if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
-                 $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime);
+                 $result = &do_cache_new('loadbalancing',$serverhomedom,$domconfig{'loadbalancing'},$cachetime);
+             } else {
+                 $domneedscache = $serverhomedom;
              }
          }
          if (ref($result) eq 'HASH') {
-             my $currbalancer = $result->{'lonhost'};
+             ($is_balancer,$currtargets,$currrules,$setcookie) =
-             my $currtargets = $result->{'targets'};
+                 &check_balancer_result($result,@hosts);
-             my $currrules = $result->{'rules'};
+             if ($is_balancer) {
-             if ($currbalancer eq $lonhost) {
-                 $is_balancer = 1;
                  if (ref($currrules) eq 'HASH') {
                      if ($currrules->{'_LC_internetdom'} ne '') {
                          $rule_in_effect = $currrules->{'_LC_internetdom'};
- Line 1332  sub check_loadbalancing {
+ Line 1617  sub check_loadbalancing {
                  $is_balancer = 1;
                  $offloadto = &this_host_spares($dom_in_use);
              }
+             unless (defined($cached)) {
+                 $domneedscache = $serverhomedom;
+             }
          }
      } else {
          if ($perlvar{'lonBalancer'} eq 'yes') {
              $is_balancer = 1;
              $offloadto = &this_host_spares($dom_in_use);
          }
+         unless (defined($cached)) {
+             $domneedscache = $serverhomedom;
+         }
      }
-     my $lowest_load = 30000;
+     if ($domneedscache) {
-     if (ref($offloadto) eq 'HASH') {
+         &do_cache_new('loadbalancing',$domneedscache,$is_balancer,$cachetime);
-         if (ref($offloadto->{'primary'}) eq 'ARRAY') {
+     }
-             foreach my $try_server (@{$offloadto->{'primary'}}) {
+     if (($is_balancer) && ($caller ne 'switchserver')) {
-                 ($otherserver,$lowest_load) =
+         my $lowest_load = 30000;
-                     &compare_server_load($try_server,$otherserver,$lowest_load);
+         if (ref($offloadto) eq 'HASH') {
+             if (ref($offloadto->{'primary'}) eq 'ARRAY') {
+                 foreach my $try_server (@{$offloadto->{'primary'}}) {
+                     ($otherserver,$lowest_load) =
+                         &compare_server_load($try_server,$otherserver,$lowest_load);
+                 }
              }
-         }
+             my $found_server = ($otherserver ne '' && $lowest_load < 100);
-         my $found_server = ($otherserver ne '' && $lowest_load < 100);
-         if (!$found_server) {
+             if (!$found_server) {
-             if (ref($offloadto->{'default'}) eq 'ARRAY') {
+                 if (ref($offloadto->{'default'}) eq 'ARRAY') {
-                 foreach my $try_server (@{$offloadto->{'default'}}) {
+                     foreach my $try_server (@{$offloadto->{'default'}}) {
+                         ($otherserver,$lowest_load) =
+                             &compare_server_load($try_server,$otherserver,$lowest_load);
+                     }
+                 }
+             }
+         } elsif (ref($offloadto) eq 'ARRAY') {
+             if (@{$offloadto} == 1) {
+                 $otherserver = $offloadto->[0];
+             } elsif (@{$offloadto} > 1) {
+                 foreach my $try_server (@{$offloadto}) {
                      ($otherserver,$lowest_load) =
                          &compare_server_load($try_server,$otherserver,$lowest_load);
                  }
              }
          }
-     } elsif (ref($offloadto) eq 'ARRAY') {
+         unless ($caller eq 'login') {
-         if (@{$offloadto} == 1) {
+             if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) {
-             $otherserver = $offloadto->[0];
+                 $is_balancer = 0;
-         } elsif (@{$offloadto} > 1) {
+                 if ($uname ne '' && $udom ne '') {
-             foreach my $try_server (@{$offloadto}) {
+                     if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {
-                 ($otherserver,$lowest_load) =
+                         &appenv({'user.loadbalexempt'     => $lonhost,
-                     &compare_server_load($try_server,$otherserver,$lowest_load);
+                                  'user.loadbalcheck.time' => time});
+                     }
+                 }
+             }
+         }
+     }
+     if (($is_balancer) && (!$homeintdom)) {
+         undef($setcookie);
+     }
+     return ($is_balancer,$otherserver,$setcookie);
+ }
+ sub check_balancer_result {
+     my ($result,@hosts) = @_;
+     my ($is_balancer,$currtargets,$currrules,$setcookie);
+     if (ref($result) eq 'HASH') {
+         if ($result->{'lonhost'} ne '') {
+             my $currbalancer = $result->{'lonhost'};
+             if (grep(/^\Q$currbalancer\E$/,@hosts)) {
+                 $is_balancer = 1;
+                 $currtargets = $result->{'targets'};
+                 $currrules = $result->{'rules'};
+             }
+         } else {
+             foreach my $key (keys(%{$result})) {
+                 if (($key ne '') && (grep(/^\Q$key\E$/,@hosts)) &&
+                     (ref($result->{$key}) eq 'HASH')) {
+                     $is_balancer = 1;
+                     $currrules = $result->{$key}{'rules'};
+                     $currtargets = $result->{$key}{'targets'};
+                     $setcookie = $result->{$key}{'cookie'};
+                     last;
+                 }
              }
          }
      }
-     return ($is_balancer,$otherserver);
+     return ($is_balancer,$currtargets,$currrules,$setcookie);
  }
  sub get_loadbalancer_targets {
      my ($rule_in_effect,$currtargets,$uname,$udom) = @_;
      my $offloadto;
-     if ($rule_in_effect eq '') {
+     if ($rule_in_effect eq 'none') {
+         return [$perlvar{'lonHostID'}];
+     } elsif ($rule_in_effect eq '') {
          $offloadto = $currtargets;
      } else {
          if ($rule_in_effect eq 'homeserver') {
- Line 1391  sub get_loadbalancer_targets {
+ Line 1730  sub get_loadbalancer_targets {
                      }
                  }
              } else {
-                 my %servers = &dom_servers($udom);
+                 my %servers = &internet_dom_servers($udom);
                  my ($remotebalancer,$remotetargets) = &get_lonbalancer_config(\%servers);
                  if (&hostname($remotebalancer) ne '') {
                      $offloadto = [$remotebalancer];
- Line 1470  sub idget {
+ Line 1809  sub idget {
      my %servers = &get_servers($udom,'library');
      foreach my $tryserver (keys(%servers)) {
- 	my $idlist=join('&',@ids);
+ 	my $idlist=join('&', map { &escape($_); } @ids);
  	$idlist=~tr/A-Z/a-z/;
  	my $reply=&reply("idget:$udom:".$idlist,$tryserver);
  	my @answer=();
- Line 1480  sub idget {
+ Line 1819  sub idget {
  	my $i;
  	for ($i=0;$i<=$#ids;$i++) {
  	    if ($answer[$i]) {
- 		$returnhash{$ids[$i]}=$answer[$i];
+ 		$returnhash{$ids[$i]}=&unescape($answer[$i]);
  	    }
  	}
      }
- Line 1522  sub idput {
+ Line 1861  sub idput {
      }
  }
- # ------------------------------dump from db file owned by domainconfig user
+ # ---------------------------------------- Delete unwanted IDs from ids.db file
- sub dump_dom {
-     my ($namespace,$udom,$regexp,$range)=@_;
+ sub iddel {
-     if (!$udom) {
+     my ($udom,$idshashref,$uhome)=@_;
-         $udom=$env{'user.domain'};
+     my %result=();
+     unless (ref($idshashref) eq 'HASH') {
+         return %result;
      }
-     my %returnhash;
+     my %servers=();
-     if ($udom) {
+     while (my ($id,$uname) = each(%{$idshashref})) {
-         my $uname = &get_domainconfiguser($udom);
+         my $uhom;
-         %returnhash = &dump($namespace,$udom,$uname,$regexp,$range);
+         if ($uhome) {
+             $uhom = $uhome;
+         } else {
+             $uhom=&homeserver($uname,$udom);
+         }
+         if ($uhom ne 'no_host') {
+             if ($servers{$uhom}) {
+                 $servers{$uhom}.='&'.&escape($id);
+             } else {
+                 $servers{$uhom}=&escape($id);
+             }
+         }
      }
-     return %returnhash;
+     foreach my $server (keys(%servers)) {
+         $result{$server} = &critical('iddel:'.$udom.':'.$servers{$server},$uhome);
+     }
+     return %result;
+ }
+ # ------------------------------dump from db file owned by domainconfig user
+ sub dump_dom {
+     my ($namespace, $udom, $regexp) = @_;
+     $udom ||= $env{'user.domain'};
+     return () unless $udom;
+     return &dump($namespace, $udom, &get_domainconfiguser($udom), $regexp);
  }
  # ------------------------------------------ get items from domain db files
  sub get_dom {
-     my ($namespace,$storearr,$udom,$uhome)=@_;
+     my ($namespace,$storearr,$udom,$uhome,$encrypt)=@_;
+     return if ($udom eq 'public');
      my $items='';
      foreach my $item (@$storearr) {
          $items.=&escape($item).'&';
- Line 1547  sub get_dom {
+ Line 1914  sub get_dom {
      $items=~s/\&$//;
      if (!$udom) {
          $udom=$env{'user.domain'};
+         return if ($udom eq 'public');
          if (defined(&domain($udom,'primary'))) {
              $uhome=&domain($udom,'primary');
          } else {
- Line 1560  sub get_dom {
+ Line 1928  sub get_dom {
          }
      }
      if ($udom && $uhome && ($uhome ne 'no_host')) {
-         my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
+         my $rep;
+         if (grep { $_ eq $uhome } &current_machine_ids()) {
+             # domain information is hosted on this machine
+             $rep = &LONCAPA::Lond::get_dom("getdom:$udom:$namespace:$items");
+         } else {
+             if ($encrypt) {
+                 $rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome);
+             } else {
+                 $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
+             }
+         }
          my %returnhash;
          if ($rep eq '' || $rep =~ /^error: 2 /) {
              return %returnhash;
- Line 1583  sub get_dom {
+ Line 1961  sub get_dom {
  # -------------------------------------------- put items in domain db files
  sub put_dom {
-     my ($namespace,$storehash,$udom,$uhome)=@_;
+     my ($namespace,$storehash,$udom,$uhome,$encrypt)=@_;
      if (!$udom) {
          $udom=$env{'user.domain'};
          if (defined(&domain($udom,'primary'))) {
- Line 1604  sub put_dom {
+ Line 1982  sub put_dom {
              $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
          }
          $items=~s/\&$//;
-         return &reply("putdom:$udom:$namespace:$items",$uhome);
+         if ($encrypt) {
+             return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome);
+         } else {
+             return &reply("putdom:$udom:$namespace:$items",$uhome);
+         }
      } else {
          &logthis("put_dom failed - no homeserver and/or domain");
      }
- Line 1638  sub del_dom {
+ Line 2020  sub del_dom {
      }
  }
+ sub store_dom {
+     my ($storehash,$id,$namespace,$dom,$home,$encrypt) = @_;
+     $$storehash{'ip'}=&get_requestor_ip();
+     $$storehash{'host'}=$perlvar{'lonHostID'};
+     my $namevalue='';
+     foreach my $key (keys(%{$storehash})) {
+         $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
+     }
+     $namevalue=~s/\&$//;
+     if (grep { $_ eq $home } current_machine_ids()) {
+         return LONCAPA::Lond::store_dom("storedom:$dom:$namespace:$id:$namevalue");
+     } else {
+         if ($namespace eq 'private') {
+             return 'refused';
+         } elsif ($encrypt) {
+             return reply("encrypt:storedom:$dom:$namespace:$id:$namevalue",$home);
+         } else {
+             return reply("storedom:$dom:$namespace:$id:$namevalue",$home);
+         }
+     }
+ }
+ sub restore_dom {
+     my ($id,$namespace,$dom,$home,$encrypt) = @_;
+     my $answer;
+     if (grep { $_ eq $home } current_machine_ids()) {
+         $answer = LONCAPA::Lond::restore_dom("restoredom:$dom:$namespace:$id");
+     } elsif ($namespace ne 'private') {
+         if ($encrypt) {
+             $answer=&reply("encrypt:restoredom:$dom:$namespace:$id",$home);
+         } else {
+             $answer=&reply("restoredom:$dom:$namespace:$id",$home);
+         }
+     }
+     my %returnhash=();
+     unless (($answer eq '') || ($answer eq 'con_lost') || ($answer eq 'refused') ||
+             ($answer eq 'unknown_cmd') || ($answer eq 'rejected')) {
+         foreach my $line (split(/\&/,$answer)) {
+             my ($name,$value)=split(/\=/,$line);
+             $returnhash{&unescape($name)}=&thaw_unescape($value);
+         }
+         my $version;
+         for ($version=1;$version<=$returnhash{'version'};$version++) {
+             foreach my $item (split(/\:/,$returnhash{$version.':keys'})) {
+                 $returnhash{$item}=$returnhash{$version.':'.$item};
+             }
+         }
+     }
+     return %returnhash;
+ }
  # ----------------------------------construct domainconfig user for a domain
  sub get_domainconfiguser {
      my ($udom) = @_;
- Line 1650  sub retrieve_inst_usertypes {
+ Line 2083  sub retrieve_inst_usertypes {
      my %domdefs = &Apache::lonnet::get_domain_defaults($udom);
      if ((ref($domdefs{'inststatustypes'}) eq 'HASH') &&
          (ref($domdefs{'inststatusorder'}) eq 'ARRAY')) {
-         %returnhash = %{$domdefs{'inststatustypes'}};
+         return ($domdefs{'inststatustypes'},$domdefs{'inststatusorder'});
-         @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");
+                 &logthis("retrieve_inst_usertypes failed - $rep returned from $uhome in domain: $udom");
                  return (\%returnhash,\@order);
              }
              my ($hashitems,$orderitems) = split(/:/,$rep);
- Line 1673  sub retrieve_inst_usertypes {
+ Line 2105  sub retrieve_inst_usertypes {
                  push(@order,&unescape($item));
              }
          } else {
-             &logthis("get_dom failed - no primary domain server for $udom");
+             &logthis("retrieve_inst_usertypes failed - no primary domain server for $udom");
          }
+         return (\%returnhash,\@order);
      }
-     return (\%returnhash,\@order);
  }
  sub is_domainimage {
      my ($url) = @_;
-     if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+-) {
+     if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo|login)/+[^/]-) {
          if (&domain($1) ne '') {
              return '1';
          }
- Line 1696  sub inst_directory_query {
+ Line 2128  sub inst_directory_query {
      my $homeserver = &domain($udom,'primary');
      my $outcome;
      if ($homeserver ne '') {
+         unless ($homeserver eq $perlvar{'lonHostID'}) {
+             if ($srch->{'srchby'} eq 'email') {
+                 my $lcrev = &get_server_loncaparev($udom,$homeserver);
+                 my ($major,$minor,$subver) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.(\d+)[\w.\-]+\'?$/);
+                 if (($major eq '' && $minor eq '') || ($major < 2) ||
+                     (($major == 2) && ($minor < 11)) ||
+                     (($major == 2) && ($minor == 11) && ($subver < 3))) {
+                     return;
+                 }
+             }
+         }
  	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);
+ 	    &logthis('institutional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.' in domain '.$udom);
  	    return;
  	}
  	my $response = &get_query_reply($queryid);
- Line 1737  sub usersearch {
+ Line 2180  sub usersearch {
      my $query = 'usersearch';
      foreach my $tryserver (keys(%libserv)) {
          if (&host_domain($tryserver) eq $dom) {
+             unless ($tryserver eq $perlvar{'lonHostID'}) {
+                 if ($srch->{'srchby'} eq 'email') {
+                     my $lcrev = &get_server_loncaparev($dom,$tryserver);
+                     my ($major,$minor,$subver) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.(\d+)[\w.\-]+\'?$/);
+                     next if (($major eq '' && $minor eq '') || ($major < 2) ||
+                              (($major == 2) && ($minor < 11)) ||
+                              (($major == 2) && ($minor == 11) && ($subver < 3)));
+                 }
+             }
              my $host=&hostname($tryserver);
              my $queryid=
                  &reply("querysend:".&escape($query).':'.
- Line 1822  sub get_instuser {
+ Line 2274  sub get_instuser {
      return ($outcome,%userinfo);
  }
+ sub get_multiple_instusers {
+     my ($udom,$users,$caller) = @_;
+     my ($outcome,$results);
+     if (ref($users) eq 'HASH') {
+         my $count = keys(%{$users});
+         my $requested = &freeze_escape($users);
+         my $homeserver = &domain($udom,'primary');
+         if ($homeserver ne '') {
+             my $queryid=&reply('querysend:getmultinstusers:::'.$caller.'='.$requested,$homeserver);
+             my $host=&hostname($homeserver);
+             if ($queryid !~/^\Q$host\E\_/) {
+                 &logthis('get_multiple_instusers invalid queryid: '.$queryid.
+                          ' for host: '.$homeserver.'in domain '.$udom);
+                 return ($outcome,$results);
+             }
+             my $response = &get_query_reply($queryid);
+             my $maxtries = 5;
+             if ($count > 100) {
+                 $maxtries = 1+int($count/20);
+             }
+             my $tries = 1;
+             while (($response=~/^timeout/) && ($tries <= $maxtries)) {
+                 $response = &get_query_reply($queryid);
+                 $tries ++;
+             }
+             if ($response eq '') {
+                 $results = {};
+                 foreach my $key (keys(%{$users})) {
+                     my ($uname,$id);
+                     if ($caller eq 'id') {
+                         $id = $key;
+                     } else {
+                         $uname = $key;
+                     }
+                     my ($resp,%info) = &get_instuser($udom,$uname,$id);
+                     $outcome = $resp;
+                     if ($resp eq 'ok') {
+                         %{$results} = (%{$results}, %info);
+                     } else {
+                         last;
+                     }
+                 }
+             } elsif(!&error($response) && ($response ne 'refused')) {
+                 if (($response eq 'unavailable') || ($response eq 'invalid') || ($response eq 'timeout')) {
+                     $outcome = $response;
+                 } else {
+                     ($outcome,my $userdata) = split(/=/,$response,2);
+                     if ($outcome eq 'ok') {
+                         $results = &thaw_unescape($userdata);
+                     }
+                 }
+             }
+         }
+     }
+     return ($outcome,$results);
+ }
  sub inst_rulecheck {
      my ($udom,$uname,$id,$item,$rules) = @_;
      my %returnhash;
- Line 1840  sub inst_rulecheck {
+ Line 2349  sub inst_rulecheck {
                      $response=&unescape(&reply('instidrulecheck:'.&escape($udom).
                                                ':'.&escape($id).':'.$rulestr,
                                                $homeserver));
+                 } elsif ($item eq 'unamemap') {
+                     $response=&unescape(&reply('instunamemapcheck:'.
+                                                &escape($udom).':'.&escape($uname).
+                                               ':'.$rulestr,$homeserver));
                  } elsif ($item eq 'selfcreate') {
                      $response=&unescape(&reply('instselfcreatecheck:'.
                                                 &escape($udom).':'.&escape($uname).
- Line 1873  sub inst_userrules {
+ Line 2386  sub inst_userrules {
              } elsif ($check eq 'email') {
                  $response=&reply('instemailrules:'.&escape($udom),
                                   $homeserver);
+             } elsif ($check eq 'unamemap') {
+                 $response=&reply('unamemaprules:'.&escape($udom),
+                                  $homeserver);
              } else {
                  $response=&reply('instuserrules:'.&escape($udom),
                                   $homeserver);
- Line 1901  sub inst_userrules {
+ Line 2417  sub inst_userrules {
  # ------------- Get Authentication, Language and User Tools Defaults for Domain
  sub get_domain_defaults {
-     my ($domain) = @_;
+     my ($domain,$ignore_cache) = @_;
+     return if (($domain eq '') || ($domain eq 'public'));
      my $cachetime = 60*60*24;
-     my ($result,$cached)=&is_cached_new('domdefaults',$domain);
+     unless ($ignore_cache) {
-     if (defined($cached)) {
+         my ($result,$cached)=&is_cached_new('domdefaults',$domain);
-         if (ref($result) eq 'HASH') {
+         if (defined($cached)) {
-             return %{$result};
+             if (ref($result) eq 'HASH') {
+                 return %{$result};
+             }
          }
      }
      my %domdefaults;
      my %domconfig =
           &Apache::lonnet::get_dom('configuration',['defaults','quotas',
                                    'requestcourses','inststatus',
-                                   'coursedefaults','usersessions'],$domain);
+                                   'coursedefaults','usersessions',
+                                   'requestauthor','selfenrollment',
+                                   'coursecategories','autoenroll',
+                                   'helpsettings','wafproxy','ltisec'],$domain);
+     my @coursetypes = ('official','unofficial','community','textbook');
      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'};
+         $domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'};
+         $domdefaults{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'};
+         $domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'};
+         $domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'};
+         $domdefaults{'unamemap_rule'} = $domconfig{'defaults'}{'unamemap_rule'};
      } else {
          $domdefaults{'lang_def'} = &domain($domain,'lang_def');
          $domdefaults{'auth_def'} = &domain($domain,'auth_def');
- Line 1930  sub get_domain_defaults {
+ Line 2458  sub get_domain_defaults {
              $domdefaults{'defaultquota'} = $domconfig{'quotas'}{'defaultquota'};
          } else {
              $domdefaults{'defaultquota'} = $domconfig{'quotas'};
          }
-         my @usertools = ('aboutme','blog','portfolio');
+         my @usertools = ('aboutme','blog','webdav','portfolio');
          foreach my $item (@usertools) {
              if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {
                  $domdefaults{$item} = $domconfig{'quotas'}{$item};
              }
          }
+         if (ref($domconfig{'quotas'}{'authorquota'}) eq 'HASH') {
+             $domdefaults{'authorquota'} = $domconfig{'quotas'}{'authorquota'};
+         }
      }
      if (ref($domconfig{'requestcourses'}) eq 'HASH') {
-         foreach my $item ('official','unofficial','community') {
+         foreach my $item ('official','unofficial','community','textbook') {
              $domdefaults{$item} = $domconfig{'requestcourses'}{$item};
          }
      }
+     if (ref($domconfig{'requestauthor'}) eq 'HASH') {
+         $domdefaults{'requestauthor'} = $domconfig{'requestauthor'};
+     }
      if (ref($domconfig{'inststatus'}) eq 'HASH') {
-         foreach my $item ('inststatustypes','inststatusorder') {
+         foreach my $item ('inststatustypes','inststatusorder','inststatusguest') {
              $domdefaults{$item} = $domconfig{'inststatus'}{$item};
          }
      }
      if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
-         foreach my $item ('canuse_pdfforms') {
+         $domdefaults{'usejsme'} = $domconfig{'coursedefaults'}{'usejsme'};
-             $domdefaults{$item} = $domconfig{'coursedefaults'}{$item};
+         $domdefaults{'inline_chem'} = $domconfig{'coursedefaults'}{'inline_chem'};
+         $domdefaults{'uselcmath'} = $domconfig{'coursedefaults'}{'uselcmath'};
+         if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') {
+             $domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'};
+         }
+         foreach my $type (@coursetypes) {
+             if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {
+                 unless ($type eq 'community') {
+                     $domdefaults{$type.'credits'} = $domconfig{'coursedefaults'}{'coursecredits'}{$type};
+                 }
+             }
+             if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {
+                 $domdefaults{$type.'quota'} = $domconfig{'coursedefaults'}{'uploadquota'}{$type};
+             }
+             if ($domdefaults{'postsubmit'} eq 'on') {
+                 if (ref($domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}) eq 'HASH') {
+                     $domdefaults{$type.'postsubtimeout'} =
+                         $domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}{$type};
+                 }
+             }
+         }
+         if (ref($domconfig{'coursedefaults'}{'canclone'}) eq 'HASH') {
+             if (ref($domconfig{'coursedefaults'}{'canclone'}{'instcode'}) eq 'ARRAY') {
+                 my @clonecodes = @{$domconfig{'coursedefaults'}{'canclone'}{'instcode'}};
+                 if (@clonecodes) {
+                     $domdefaults{'canclone'} = join('+',@clonecodes);
+                 }
+             }
+         } elsif ($domconfig{'coursedefaults'}{'canclone'}) {
+             $domdefaults{'canclone'}=$domconfig{'coursedefaults'}{'canclone'};
+         }
+         if ($domconfig{'coursedefaults'}{'texengine'}) {
+             $domdefaults{'texengine'} = $domconfig{'coursedefaults'}{'texengine'};
+         }
+         if (exists($domconfig{'coursedefaults'}{'ltiauth'})) {
+             $domdefaults{'crsltiauth'} = $domconfig{'coursedefaults'}{'ltiauth'};
          }
      }
      if (ref($domconfig{'usersessions'}) eq 'HASH') {
- Line 1960  sub get_domain_defaults {
+ Line 2529  sub get_domain_defaults {
          if (ref($domconfig{'usersessions'}{'hosted'}) eq 'HASH') {
              $domdefaults{'hostedsessions'} = $domconfig{'usersessions'}{'hosted'};
          }
+         if (ref($domconfig{'usersessions'}{'offloadnow'}) eq 'HASH') {
+             $domdefaults{'offloadnow'} = $domconfig{'usersessions'}{'offloadnow'};
+         }
+         if (ref($domconfig{'usersessions'}{'offloadoth'}) eq 'HASH') {
+             $domdefaults{'offloadoth'} = $domconfig{'usersessions'}{'offloadoth'};
+         }
+     }
+     if (ref($domconfig{'selfenrollment'}) eq 'HASH') {
+         if (ref($domconfig{'selfenrollment'}{'admin'}) eq 'HASH') {
+             my @settings = ('types','registered','enroll_dates','access_dates','section',
+                             'approval','limit');
+             foreach my $type (@coursetypes) {
+                 if (ref($domconfig{'selfenrollment'}{'admin'}{$type}) eq 'HASH') {
+                     my @mgrdc = ();
+                     foreach my $item (@settings) {
+                         if ($domconfig{'selfenrollment'}{'admin'}{$type}{$item} eq '0') {
+                             push(@mgrdc,$item);
+                         }
+                     }
+                     if (@mgrdc) {
+                         $domdefaults{$type.'selfenrolladmdc'} = join(',',@mgrdc);
+                     }
+                 }
+             }
+         }
+         if (ref($domconfig{'selfenrollment'}{'default'}) eq 'HASH') {
+             foreach my $type (@coursetypes) {
+                 if (ref($domconfig{'selfenrollment'}{'default'}{$type}) eq 'HASH') {
+                     foreach my $item (keys(%{$domconfig{'selfenrollment'}{'default'}{$type}})) {
+                         $domdefaults{$type.'selfenroll'.$item} = $domconfig{'selfenrollment'}{'default'}{$type}{$item};
+                     }
+                 }
+             }
+         }
+     }
+     if (ref($domconfig{'coursecategories'}) eq 'HASH') {
+         $domdefaults{'catauth'} = 'std';
+         $domdefaults{'catunauth'} = 'std';
+         if ($domconfig{'coursecategories'}{'auth'}) {
+             $domdefaults{'catauth'} = $domconfig{'coursecategories'}{'auth'};
+         }
+         if ($domconfig{'coursecategories'}{'unauth'}) {
+             $domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'};
+         }
+     }
+     if (ref($domconfig{'autoenroll'}) eq 'HASH') {
+         $domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'};
+         $domdefaults{'failsafe'} = $domconfig{'autoenroll'}{'failsafe'};
+     }
+     if (ref($domconfig{'helpsettings'}) eq 'HASH') {
+         $domdefaults{'submitbugs'} = $domconfig{'helpsettings'}{'submitbugs'};
+         if (ref($domconfig{'helpsettings'}{'adhoc'}) eq 'HASH') {
+             $domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'};
+         }
      }
-     &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,
+     if (ref($domconfig{'wafproxy'}) eq 'HASH') {
-                                   $cachetime);
+         foreach my $item ('ipheader','trusted','vpnint','vpnext','sslopt') {
+             if ($domconfig{'wafproxy'}{$item}) {
+                 $domdefaults{'waf_'.$item} = $domconfig{'wafproxy'}{$item};
+             }
+         }
+     }
+     if (ref($domconfig{'ltisec'}) eq 'HASH') {
+         if (ref($domconfig{'ltisec'}{'encrypt'}) eq 'HASH') {
+             $domdefaults{'linkprotenc_crs'} = $domconfig{'ltisec'}{'encrypt'}{'crs'};
+             $domdefaults{'linkprotenc_dom'} = $domconfig{'ltisec'}{'encrypt'}{'dom'};
+             $domdefaults{'ltienc_consumers'} = $domconfig{'ltisec'}{'encrypt'}{'consumers'};
+         }
+         if (ref($domconfig{'ltisec'}{'private'}) eq 'HASH') {
+             if (ref($domconfig{'ltisec'}{'private'}{'keys'}) eq 'ARRAY') {
+                 $domdefaults{'privhosts'} = $domconfig{'ltisec'}{'private'}{'keys'};
+             }
+         }
+     }
+     &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);
      return %domdefaults;
  }
+ sub get_dom_cats {
+     my ($dom) = @_;
+     return unless (&domain($dom));
+     my ($cats,$cached)=&is_cached_new('cats',$dom);
+     unless (defined($cached)) {
+         my %domconfig = &get_dom('configuration',['coursecategories'],$dom);
+         if (ref($domconfig{'coursecategories'}) eq 'HASH') {
+             if (ref($domconfig{'coursecategories'}{'cats'}) eq 'HASH') {
+                 %{$cats} = %{$domconfig{'coursecategories'}{'cats'}};
+             } else {
+                 $cats = {};
+             }
+         } else {
+             $cats = {};
+         }
+         &Apache::lonnet::do_cache_new('cats',$dom,$cats,3600);
+     }
+     return $cats;
+ }
+ sub get_dom_instcats {
+     my ($dom) = @_;
+     return unless (&domain($dom));
+     my ($instcats,$cached)=&is_cached_new('instcats',$dom);
+     unless (defined($cached)) {
+         my (%coursecodes,%codes,@codetitles,%cat_titles,%cat_order);
+         my $totcodes = &retrieve_instcodes(\%coursecodes,$dom);
+         if ($totcodes > 0) {
+             my $caller = 'global';
+             if (&auto_instcode_format($caller,$dom,\%coursecodes,\%codes,
+                                       \@codetitles,\%cat_titles,\%cat_order) eq 'ok') {
+                 $instcats = {
+                                 codes => \%codes,
+                                 codetitles => \@codetitles,
+                                 cat_titles => \%cat_titles,
+                                 cat_order => \%cat_order,
+                             };
+                 &do_cache_new('instcats',$dom,$instcats,3600);
+             }
+         }
+     }
+     return $instcats;
+ }
+ sub retrieve_instcodes {
+     my ($coursecodes,$dom) = @_;
+     my $totcodes;
+     my %courses = &courseiddump($dom,'.',1,'.','.','.',undef,undef,'Course');
+     foreach my $course (keys(%courses)) {
+         if (ref($courses{$course}) eq 'HASH') {
+             if ($courses{$course}{'inst_code'} ne '') {
+                 $$coursecodes{$course} = $courses{$course}{'inst_code'};
+                 $totcodes ++;
+             }
+         }
+     }
+     return $totcodes;
+ }
+ # --------------------------------------------- Get domain config for passwords
+ sub get_passwdconf {
+     my ($dom) = @_;
+     my (%passwdconf,$gotconf,$lookup);
+     my ($result,$cached)=&is_cached_new('passwdconf',$dom);
+     if (defined($cached)) {
+         if (ref($result) eq 'HASH') {
+             %passwdconf = %{$result};
+             $gotconf = 1;
+         }
+     }
+     unless ($gotconf) {
+         my %domconfig = &get_dom('configuration',['passwords'],$dom);
+         if (ref($domconfig{'passwords'}) eq 'HASH') {
+             %passwdconf = %{$domconfig{'passwords'}};
+         }
+         my $cachetime = 24*60*60;
+         &do_cache_new('passwdconf',$dom,\%passwdconf,$cachetime);
+     }
+     return %passwdconf;
+ }
+ sub course_portal_url {
+     my ($cnum,$cdom,$r) = @_;
+     my $chome = &homeserver($cnum,$cdom);
+     my $hostname = &hostname($chome);
+     my $protocol = $protocol{$chome};
+     $protocol = 'http' if ($protocol ne 'https');
+     my %domdefaults = &get_domain_defaults($cdom);
+     my $firsturl;
+     if ($domdefaults{'portal_def'}) {
+         $firsturl = $domdefaults{'portal_def'};
+     } else {
+         my $alias = &Apache::lonnet::use_proxy_alias($r,$chome);
+         $hostname = $alias if ($alias ne '');
+         $firsturl = $protocol.'://'.$hostname;
+     }
+     return $firsturl;
+ }
  # --------------------------------------------------- Assign a key to a student
  sub assign_access_key {
- Line 2146  sub getsection {
+ Line 2887  sub getsection {
      # If there is a role which has expired, return it.
      #
      $courseid = &courseid_to_courseurl($courseid);
-     my $extra = &freeze_escape({'skipcheck' => 1});
+     my %roleshash = &dump('roles',$udom,$unam,$courseid);
-     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 2203  sub make_key {
+ Line 2943  sub make_key {
  sub devalidate_cache_new {
      my ($name,$id,$debug) = @_;
      if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }
+     my $remembered_id=$name.':'.$id;
      $id=&make_key($name,$id);
      $memcache->delete($id);
-     delete($remembered{$id});
+     delete($remembered{$remembered_id});
-     delete($accessed{$id});
+     delete($accessed{$remembered_id});
  }
  sub is_cached_new {
      my ($name,$id,$debug) = @_;
-     $id=&make_key($name,$id);
+     my $remembered_id=$name.':'.$id; # this is to avoid make_key (which is slow) for
-     if (exists($remembered{$id})) {
+                                      # keys in %remembered hash, which persists for
- 	if ($debug) { &Apache::lonnet::logthis("Early return $id of $remembered{$id} "); }
+                                      # duration of request (no restriction on key length).
- 	$accessed{$id}=[&gettimeofday()];
+     if (exists($remembered{$remembered_id})) {
+ 	if ($debug) { &Apache::lonnet::logthis("Early return $remembered_id of $remembered{$remembered_id} "); }
+ 	$accessed{$remembered_id}=[&gettimeofday()];
  	$hits++;
- 	return ($remembered{$id},1);
+ 	return ($remembered{$remembered_id},1);
      }
+     $id=&make_key($name,$id);
      my $value = $memcache->get($id);
      if (!(defined($value))) {
  	if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }
- Line 2227  sub is_cached_new {
+ Line 2971  sub is_cached_new {
  	if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); }
  	$value=undef;
      }
-     &make_room($id,$value,$debug);
+     &make_room($remembered_id,$value,$debug);
      if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }
      return ($value,1);
  }
  sub do_cache_new {
      my ($name,$id,$value,$time,$debug) = @_;
+     my $remembered_id=$name.':'.$id;
      $id=&make_key($name,$id);
      my $setvalue=$value;
      if (!defined($setvalue)) {
- Line 2249  sub do_cache_new {
+ Line 2994  sub do_cache_new {
  	$memcache->disconnect_all();
      }
      # need to make a copy of $value
-     &make_room($id,$value,$debug);
+     &make_room($remembered_id,$value,$debug);
      return $value;
  }
  sub make_room {
-     my ($id,$value,$debug)=@_;
+     my ($remembered_id,$value,$debug)=@_;
-     $remembered{$id}= (ref($value)) ? &Storable::dclone($value)
+     $remembered{$remembered_id}= (ref($value)) ? &Storable::dclone($value)
                                      : $value;
      if ($to_remember<0) { return; }
-     $accessed{$id}=[&gettimeofday()];
+     $accessed{$remembered_id}=[&gettimeofday()];
      if (scalar(keys(%remembered)) <= $to_remember) { return; }
      my $to_kick;
      my $max_time=0;
- Line 2373  sub chatsend {
+ Line 3118  sub chatsend {
  sub getversion {
      my $fname=&clutter(shift);
-     unless ($fname=~/^\/res\//) { return -1; }
+     unless ($fname=~m{^(/adm/wrapper|)/res/}) { return -1; }
      return &currentversion(&filelocation('',$fname));
  }
- Line 2431  sub repcopy {
+ Line 3176  sub repcopy {
      $filename=~s/\/+/\//g;
      my $londocroot = $perlvar{'lonDocRoot'};
      if ($filename=~m{^\Q$londocroot/adm/\E}) { return 'ok'; }
-     if ($filename=~m{^\Q$londocroot/lonUsers/\E}) { return 'ok'; }
+     if ($filename=~m{^\Q/home/httpd/lonUsers/\E}) { return 'ok'; }
      if ($filename=~m{^\Q$londocroot/userfiles/\E} or
  	$filename=~m{^/*(uploaded|editupload)/}) {
  	return &repcopy_userfile($filename);
- Line 2497  sub repcopy {
+ Line 3242  sub repcopy {
      }
  }
+ # ------------------------------------------------- Unsubscribe from a resource
+ sub unsubscribe {
+     my ($fname) = @_;
+     my $answer;
+     if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return $answer; }
+     $fname=~s/[\n\r]//g;
+     my $author=$fname;
+     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
+     my ($udom,$uname)=split(/\//,$author);
+     my $home=homeserver($uname,$udom);
+     if ($home eq 'no_host') {
+         $answer = 'no_host';
+     } elsif (grep { $_ eq $home } &current_machine_ids()) {
+         $answer = 'home';
+     } else {
+         $answer = reply("unsub:$fname",$home);
+     }
+     return $answer;
+ }
  # ------------------------------------------------ Get server side include body
  sub ssi_body {
      my ($filelink,%form)=@_;
- Line 2525  sub ssi_body {
+ Line 3291  sub ssi_body {
  # --------------------------------------------------------- Server Side Include
  sub absolute_url {
-     my ($host_name) = @_;
+     my ($host_name,$unalias,$keep_proto) = @_;
      my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');
      if ($host_name eq '') {
  	$host_name = $ENV{'SERVER_NAME'};
      }
+     if ($unalias) {
+         my $alias = &get_proxy_alias();
+         if ($alias eq $host_name) {
+             my $lonhost = $perlvar{'lonHostID'};
+             my $hostname = &hostname($lonhost);
+             my $lcproto;
+             if (($keep_proto) || ($hostname eq '')) {
+                 $lcproto = $protocol;
+             } else {
+                 $lcproto = $protocol{$lonhost};
+                 $lcproto = 'http' if ($lcproto ne 'https');
+                 $lcproto .= '://';
+             }
+             unless ($hostname eq '') {
+                 return $lcproto.$hostname;
+             }
+         }
+     }
      return $protocol.$host_name;
  }
- Line 2546  sub absolute_url {
+ Line 3330  sub absolute_url {
  sub ssi {
      my ($fn,%form)=@_;
-     my $ua=new LWP::UserAgent;
+     my ($host,$request,$response);
-     my $request;
+     $host = &absolute_url('',1);
      $form{'no_update_last_known'}=1;
      &Apache::lonenc::check_encrypt(\$fn);
      if (%form) {
-       $request=new HTTP::Request('POST',&absolute_url().$fn);
+       $request=new HTTP::Request('POST',$host.$fn);
-       $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys(%form)));
+       $request->content(join('&',map {
+             my $name = escape($_);
+             "$name=" . ( ref($form{$_}) eq 'ARRAY'
+             ? join("&$name=", map {escape($_) } @{$form{$_}})
+             : &escape($form{$_}) );
+         } keys(%form)));
      } else {
-       $request=new HTTP::Request('GET',&absolute_url().$fn);
+       $request=new HTTP::Request('GET',$host.$fn);
      }
      $request->header(Cookie => $ENV{'HTTP_COOKIE'});
-     my $response=$ua->request($request);
+     if (($env{'request.course.id'}) &&
+         ($form{'grade_courseid'} eq $env{'request.course.id'}) &&
+         ($form{'grade_username'} ne '') && ($form{'grade_domain'} ne '') &&
+         ($form{'grade_symb'} ne '') &&
+         (&Apache::lonnet::allowed('mgr',$env{'request.course.id'}.
+                                  ($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:'')))) {
+         if (LWP::UserAgent->VERSION >= 5.834) {
+             my $ua=new LWP::UserAgent;
+             $ua->local_address('127.0.0.1');
+             $response = $ua->request($request);
+         } else {
+             {
+                 require LWP::Protocol::http;
+                 local @LWP::Protocol::http::EXTRA_SOCK_OPTS = (LocalAddr => '127.0.0.1');
+                 my $ua=new LWP::UserAgent;
+                 $response = $ua->request($request);
+                 @LWP::Protocol::http::EXTRA_SOCK_OPTS = ();
+             }
+         }
+     } else {
+         my $ua=new LWP::UserAgent;
+         $response = $ua->request($request);
+     }
      if (wantarray) {
  	return ($response->content, $response);
      } else {
- Line 2580  sub externalssi {
+ Line 3391  sub externalssi {
      }
  }
+ # If the local copy of a replicated resource is outdated, trigger a
+ # connection from the homeserver to flush the delayed queue. If no update
+ # happens, remove local copies of outdated resource (and corresponding
+ # metadata file).
+ sub remove_stale_resfile {
+     my ($url) = @_;
+     my $removed;
+     if ($url=~m{^/res/($match_domain)/($match_username)/}) {
+         my $audom = $1;
+         my $auname = $2;
+         unless (($url =~ /\.\d+\.\w+$/) || ($url =~ m{^/res/lib/templates/})) {
+             my $homeserver = &homeserver($auname,$audom);
+             unless (($homeserver eq 'no_host') ||
+                     (grep { $_ eq $homeserver } &current_machine_ids())) {
+                 my $fname = &filelocation('',$url);
+                 if (-e $fname) {
+                     my $hostname = &hostname($homeserver);
+                     if ($hostname) {
+                         my $protocol = $protocol{$homeserver};
+                         $protocol = 'http' if ($protocol ne 'https');
+                         my $uri = $protocol.'://'.$hostname.'/raw/'.&declutter($url);
+                         my $ua=new LWP::UserAgent;
+                         $ua->timeout(5);
+                         my $request=new HTTP::Request('HEAD',$uri);
+                         my $response=$ua->request($request);
+                         if ($response->is_success()) {
+                             my $remmodtime = &HTTP::Date::str2time( $response->header('Last-modified') );
+                             my $locmodtime = (stat($fname))[9];
+                             if ($locmodtime < $remmodtime) {
+                                 my $stale;
+                                 my $answer = &reply('pong',$homeserver);
+                                 if ($answer eq $homeserver.':'.$perlvar{'lonHostID'}) {
+                                     sleep(0.2);
+                                     $locmodtime = (stat($fname))[9];
+                                     if ($locmodtime < $remmodtime) {
+                                         my $posstransfer = $fname.'.in.transfer';
+                                         if ((-e $posstransfer) && ($remmodtime < (stat($posstransfer))[9])) {
+                                             $removed = 1;
+                                         } else {
+                                             $stale = 1;
+                                         }
+                                     } else {
+                                         $removed = 1;
+                                     }
+                                 } else {
+                                     $stale = 1;
+                                 }
+                                 if ($stale) {
+                                     if (unlink($fname)) {
+                                         if ($uri!~/\.meta$/) {
+                                             if (-e $fname.'.meta') {
+                                                 unlink($fname.'.meta');
+                                             }
+                                         }
+                                         my $unsubresult = &unsubscribe($fname);
+                                         unless ($unsubresult eq 'ok') {
+                                             &logthis("no unsub of $fname from $homeserver, reason: $unsubresult");
+                                         }
+                                         $removed = 1;
+                                     }
+                                 }
+                             }
+                         }
+                     }
+                 }
+             }
+         }
+     }
+     return $removed;
+ }
  # -------------------------------- Allow a /uploaded/ URI to be vouched for
  sub allowuploaded {
- Line 2593  sub allowuploaded {
+ Line 3476  sub allowuploaded {
      &Apache::lonnet::appenv(\%httpref);
  }
+ #
+ # Determine if the current user should be able to edit a particular resource,
+ # when viewing in course context.
+ # (a) When viewing resource used to determine if "Edit" item is included in
+ #     Functions.
+ # (b) When displaying folder contents in course editor, used to determine if
+ #     "Edit" link will be displayed alongside resource.
+ #
+ #  input: six args -- filename (decluttered), course number, course domain,
+ #                   url, symb (if registered) and group (if this is a group
+ #                   item -- e.g., bulletin board, group page etc.).
+ #  output: array of five scalars --
+ #          $cfile -- url for file editing if editable on current server
+ #          $home -- homeserver of resource (i.e., for author if published,
+ #                                           or course if uploaded.).
+ #          $switchserver --  1 if server switch will be needed.
+ #          $forceedit -- 1 if icon/link should be to go to edit mode
+ #          $forceview -- 1 if icon/link should be to go to view mode
+ #
+ sub can_edit_resource {
+     my ($file,$cnum,$cdom,$resurl,$symb,$group) = @_;
+     my ($cfile,$home,$switchserver,$forceedit,$forceview,$uploaded,$incourse);
+ #
+ # For aboutme pages user can only edit his/her own.
+ #
+     if ($resurl =~ m{^/?adm/($match_domain)/($match_username)/aboutme$}) {
+         my ($sdom,$sname) = ($1,$2);
+         if (($sdom eq $env{'user.domain'}) && ($sname eq $env{'user.name'})) {
+             $home = $env{'user.home'};
+             $cfile = $resurl;
+             if ($env{'form.forceedit'}) {
+                 $forceview = 1;
+             } else {
+                 $forceedit = 1;
+             }
+             return ($cfile,$home,$switchserver,$forceedit,$forceview);
+         } else {
+             return;
+         }
+     }
+     if ($env{'request.course.id'}) {
+         my $crsedit = &Apache::lonnet::allowed('mdc',$env{'request.course.id'});
+         if ($group ne '') {
+ # if this is a group homepage or group bulletin board, check group privs
+             my $allowed = 0;
+             if ($resurl =~ m{^/?adm/$cdom/$cnum/$group/smppg$}) {
+                 if ((&allowed('mdg',$env{'request.course.id'}.
+                               ($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:''))) ||
+                         (&allowed('mgh',$env{'request.course.id'}.'/'.$group)) || $crsedit) {
+                     $allowed = 1;
+                 }
+             } elsif ($resurl =~ m{^/?adm/$cdom/$cnum/\d+/bulletinboard$}) {
+                 if ((&allowed('mdg',$env{'request.course.id'}.($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:''))) ||
+                         (&allowed('cgb',$env{'request.course.id'}.'/'.$group)) || $crsedit) {
+                     $allowed = 1;
+                 }
+             }
+             if ($allowed) {
+                 $home=&homeserver($cnum,$cdom);
+                 if ($env{'form.forceedit'}) {
+                     $forceview = 1;
+                 } else {
+                     $forceedit = 1;
+                 }
+                 $cfile = $resurl;
+             } else {
+                 return;
+             }
+         } else {
+             if ($resurl =~ m{^/?adm/viewclasslist$}) {
+                 unless (&Apache::lonnet::allowed('opa',$env{'request.course.id'})) {
+                     return;
+                 }
+             } elsif (!$crsedit) {
+ #
+ # No edit allowed where CC has switched to student role.
+ #
+                 return;
+             }
+         }
+     }
+     if ($file ne '') {
+         if (($cnum =~ /$match_courseid/) && ($cdom =~ /$match_domain/)) {
+             if (&is_course_upload($file,$cnum,$cdom)) {
+                 $uploaded = 1;
+                 $incourse = 1;
+                 if ($file =~/\.(htm|html|css|js|txt)$/) {
+                     $cfile = &hreflocation('',$file);
+                     if ($env{'form.forceedit'}) {
+                         $forceview = 1;
+                     } else {
+                         $forceedit = 1;
+                     }
+                 }
+             } elsif ($resurl =~ m{^/public/$cdom/$cnum/syllabus}) {
+                 $incourse = 1;
+                 if ($env{'form.forceedit'}) {
+                     $forceview = 1;
+                 } else {
+                     $forceedit = 1;
+                 }
+                 $cfile = $resurl;
+             } elsif (($resurl ne '') && (&is_on_map($resurl))) {
+                 if ($resurl =~ m{^/adm/$match_domain/$match_username/\d+/smppg|bulletinboard$}) {
+                     $incourse = 1;
+                     if ($env{'form.forceedit'}) {
+                         $forceview = 1;
+                     } else {
+                         $forceedit = 1;
+                     }
+                     $cfile = $resurl;
+                 } elsif ($resurl eq '/res/lib/templates/simpleproblem.problem') {
+                     $incourse = 1;
+                     $cfile = $resurl.'/smpedit';
+                 } elsif ($resurl =~ m{^/adm/wrapper/ext/}) {
+                     $incourse = 1;
+                     if ($env{'form.forceedit'}) {
+                         $forceview = 1;
+                     } else {
+                         $forceedit = 1;
+                     }
+                     $cfile = $resurl;
+                 } elsif (($resurl =~ m{^/ext/}) && ($symb ne '')) {
+                     my ($map,$id,$res) = &decode_symb($symb);
+                     if ($map =~ /\.page$/) {
+                         $incourse = 1;
+                         if ($env{'form.forceedit'}) {
+                             $forceview = 1;
+                             $cfile = $map;
+                         } else {
+                             $forceedit = 1;
+                             $cfile =  '/adm/wrapper'.$resurl;
+                         }
+                     }
+                 } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) {
+                     $incourse = 1;
+                     if ($env{'form.forceedit'}) {
+                         $forceview = 1;
+                     } else {
+                         $forceedit = 1;
+                     }
+                     $cfile = $resurl;
+                 } elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
+                     $incourse = 1;
+                     if ($env{'form.forceedit'}) {
+                         $forceview = 1;
+                     } else {
+                         $forceedit = 1;
+                     }
+                     $cfile = ($resurl =~ m{^/} ? $resurl : "/$resurl");
+                 }
+             } elsif ($resurl eq '/res/lib/templates/simpleproblem.problem/smpedit') {
+                 my $template = '/res/lib/templates/simpleproblem.problem';
+                 if (&is_on_map($template)) {
+                     $incourse = 1;
+                     $forceview = 1;
+                     $cfile = $template;
+                 }
+             } elsif (($resurl =~ m{^/adm/wrapper/ext/}) && ($env{'form.folderpath'} =~ /^supplemental/)) {
+                 $incourse = 1;
+                 if ($env{'form.forceedit'}) {
+                     $forceview = 1;
+                 } else {
+                     $forceedit = 1;
+                 }
+                 $cfile = $resurl;
+             } elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($env{'form.folderpath'} =~ /^supplemental/)) {
+                 $incourse = 1;
+                 if ($env{'form.forceedit'}) {
+                     $forceview = 1;
+                 } else {
+                     $forceedit = 1;
+                 }
+                 $cfile = $resurl;
+             } elsif (($resurl eq '/adm/extresedit') && ($symb || $env{'form.folderpath'})) {
+                 $incourse = 1;
+                 $forceview = 1;
+                 if ($symb) {
+                     my ($map,$id,$res)=&decode_symb($symb);
+                     $env{'request.symb'} = $symb;
+                     $cfile = &clutter($res);
+                 } else {
+                     $cfile = $env{'form.suppurl'};
+                     my $escfile = &unescape($cfile);
+                     if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) {
+                         $cfile = '/adm/wrapper'.$escfile;
+                     } else {
+                         $escfile =~ s{^http://}{};
+                         $cfile = &escape("/adm/wrapper/ext/$escfile");
+                     }
+                 }
+             } elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
+                 if ($env{'form.forceedit'}) {
+                     $forceview = 1;
+                 } else {
+                     $forceedit = 1;
+                 }
+                 $cfile = ($resurl =~ m{^/} ? $resurl : "/$resurl");
+             }
+         }
+         if ($uploaded || $incourse) {
+             $home=&homeserver($cnum,$cdom);
+         } elsif ($file !~ m{/$}) {
+             $file=~s{^(priv/$match_domain/$match_username)}{/$1};
+             $file=~s{^($match_domain/$match_username)}{/priv/$1};
+             # Check that the user has permission to edit this resource
+             my $setpriv = 1;
+             my ($cfuname,$cfudom)=&constructaccess($file,$setpriv);
+             if (defined($cfudom)) {
+                 $home=&homeserver($cfuname,$cfudom);
+                 $cfile=$file;
+             }
+         }
+         if (($cfile ne '') && (!$incourse || $uploaded) &&
+             (($home ne '') && ($home ne 'no_host'))) {
+             my @ids=&current_machine_ids();
+             unless (grep(/^\Q$home\E$/,@ids)) {
+                 $switchserver=1;
+             }
+         }
+     }
+     return ($cfile,$home,$switchserver,$forceedit,$forceview);
+ }
+ sub is_course_upload {
+     my ($file,$cnum,$cdom) = @_;
+     my $uploadpath = &LONCAPA::propath($cdom,$cnum);
+     $uploadpath =~ s{^\/}{};
+     if (($file =~ m{^\Q$uploadpath\E/userfiles/(docs|supplemental)/}) ||
+         ($file =~ m{^userfiles/\Q$cdom\E/\Q$cnum\E/(docs|supplemental)/})) {
+         return 1;
+     }
+     return;
+ }
+ sub in_course {
+     my ($udom,$uname,$cdom,$cnum,$type,$hideprivileged) = @_;
+     if ($hideprivileged) {
+         my $skipuser;
+         my %coursehash = &coursedescription($cdom.'_'.$cnum);
+         my @possdoms = ($cdom);
+         if ($coursehash{'checkforpriv'}) {
+             push(@possdoms,split(/,/,$coursehash{'checkforpriv'}));
+         }
+         if (&privileged($uname,$udom,\@possdoms)) {
+             $skipuser = 1;
+             if ($coursehash{'nothideprivileged'}) {
+                 foreach my $item (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
+                     my $user;
+                     if ($item =~ /:/) {
+                         $user = $item;
+                     } else {
+                         $user = join(':',split(/[\@]/,$item));
+                     }
+                     if ($user eq $uname.':'.$udom) {
+                         undef($skipuser);
+                         last;
+                     }
+                 }
+             }
+             if ($skipuser) {
+                 return 0;
+             }
+         }
+     }
+     $type ||= 'any';
+     if (!defined($cdom) || !defined($cnum)) {
+         my $cid  = $env{'request.course.id'};
+         $cdom = $env{'course.'.$cid.'.domain'};
+         $cnum = $env{'course.'.$cid.'.num'};
+     }
+     my $typesref;
+     if (($type eq 'any') || ($type eq 'all')) {
+         $typesref = ['active','previous','future'];
+     } elsif ($type eq 'previous' || $type eq 'future') {
+         $typesref = [$type];
+     }
+     my %roles = &get_my_roles($uname,$udom,'userroles',
+                               $typesref,undef,[$cdom]);
+     my ($tmp) = keys(%roles);
+     return 0 if ($tmp =~ /^(con_lost|error|no_such_host)/i);
+     my @course_roles = grep(/^\Q$cnum\E:\Q$cdom\E:/, keys(%roles));
+     if (@course_roles > 0) {
+         return 1;
+     }
+     return 0;
+ }
  # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
  # input: action, courseID, current domain, intended
  #        path to file, source of file, instruction to parse file for objects,
- Line 2650  sub process_coursefile {
+ Line 3824  sub process_coursefile {
                                   $home);
              }
          } elsif ($action eq 'uploaddoc') {
-             open(my $fh,'>'.$filepath.'/'.$fname);
+             open(my $fh,'>',$filepath.'/'.$fname);
              print $fh $env{'form.'.$source};
              close($fh);
              if ($parser eq 'parse') {
- Line 2708  sub store_edited_file {
+ Line 3882  sub store_edited_file {
      ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);
      $fpath=$docudom.'/'.$docuname.'/'.$fpath;
      my $filepath = &build_filepath($fpath);
-     open(my $fh,'>'.$filepath.'/'.$fname);
+     open(my $fh,'>',$filepath.'/'.$fname);
      print $fh $content;
      close($fh);
      my $home=&homeserver($docuname,$docudom);
- Line 2733  sub clean_filename {
+ Line 3907  sub clean_filename {
      }
  # Replace spaces by underscores
      $fname=~s/\s+/\_/g;
+ # Transliterate non-ascii text to ascii
+     my $lang = &Apache::lonlocal::current_language();
+     $fname = &LONCAPA::transliterate::fname_to_ascii($fname,$lang);
  # Replace all other weird characters by nothing
      $fname=~s{[^/\w\.\-]}{}g;
  # Replace all .\d. sequences with _\d. so they no longer look like version
  # numbers
      $fname=~s/\.(\d+)(?=\.)/_$1/g;
+ # Replace three or more adjacent underscores with one for consistency
+ # with loncfile::filename_check() so complete url can be extracted by
+ # lonnet::decode_symb()
+     $fname=~s/_{3,}/_/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
- Line 2782  sub resizeImage {
+ Line 3964  sub resizeImage {
  # input: $formname - the contents of the file are in $env{"form.$formname"}
  #                    the desired filename is in $env{"form.$formname.filename"}
  #        $context - possible values: coursedoc, existingfile, overwrite,
- #                                    canceloverwrite, or ''.
+ #                                    canceloverwrite, scantron 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 - instruction to parse file for objects ($parser = parse)
+ #        $parser - instruction to parse file for objects ($parser = parse) or
+ #                  if context is 'scantron', $parser is hashref of csv column mapping
+ #                  (e.g.,{ PaperID => 0, LastName => 1, FirstName => 2, ID => 3,
+ #                          Section => 4, CODE => 5, FirstQuestion => 9 }).
  #        $allfiles - reference to hash for embedded objects
  #        $codebase - reference to hash for codebase of java objects
  #        $desuname - username for permanent storage of uploaded file
- Line 2798  sub resizeImage {
+ Line 3983  sub resizeImage {
  #        $resizewidth - width (pixels) to which to resize uploaded image
  #        $resizeheight - height (pixels) to which to resize uploaded image
  #        $mimetype - reference to scalar to accommodate mime type determined
- #                    from File::MMagic if $parser = parse.
+ #                    from File::MMagic.
  #
  # output: url of file in userspace, or error: <message>
  #             or /adm/notfound.html if failure to upload occurse
- Line 2811  sub userfileupload {
+ Line 3996  sub userfileupload {
      $fname=&clean_filename($fname);
      # See if there is anything left
      unless ($fname) { return 'error: no uploaded file'; }
+     # If filename now begins with a . prepend unix timestamp _ milliseconds
+     if ($fname =~ /^\./) {
+         my ($s,$usec) = &gettimeofday();
+         while (length($usec) < 6) {
+             $usec = '0'.$usec;
+         }
+         $fname = $s.'_'.substr($usec,0,3).$fname;
+     }
      # 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')) ||
- Line 2824  sub userfileupload {
+ Line 4017  sub userfileupload {
                           '_'.$env{'user.domain'}.'/pending';
          } elsif (($context eq 'existingfile') || ($context eq 'canceloverwrite')) {
              my ($docuname,$docudom);
-             if ($destudom) {
+             if ($destudom =~ /^$match_domain$/) {
                  $docudom = $destudom;
              } else {
                  $docudom = $env{'user.domain'};
              }
-             if ($destuname) {
+             if ($destuname =~ /^$match_username$/) {
                  $docuname = $destuname;
              } else {
                  $docuname = $env{'user.name'};
- Line 2859  sub userfileupload {
+ Line 4052  sub userfileupload {
                  mkdir($fullpath,0777);
              }
          }
-         open(my $fh,'>'.$fullpath.'/'.$fname);
+         open(my $fh,'>',$fullpath.'/'.$fname);
          print $fh $env{'form.'.$formname};
          close($fh);
          if ($context eq 'existingfile') {
- Line 2883  sub userfileupload {
+ Line 4076  sub userfileupload {
  					 $codebase,$thumbwidth,$thumbheight,
                                           $resizewidth,$resizeheight,$context,$mimetype);
          } else {
-             $fname=$env{'form.folder'}.'/'.$fname;
+             if ($env{'form.folder'}) {
+                 $fname=$env{'form.folder'}.'/'.$fname;
+             }
              return &process_coursefile('uploaddoc',$docuname,$docudom,
  				       $fname,$formname,$parser,
  				       $allfiles,$codebase,$mimetype);
- Line 2898  sub userfileupload {
+ Line 4093  sub userfileupload {
      } else {
          my $docuname=$env{'user.name'};
          my $docudom=$env{'user.domain'};
-         if (exists($env{'form.group'})) {
+         if ((exists($env{'form.group'})) || ($context eq 'syllabus')) {
              $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
              $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
          }
- Line 2932  sub finishuserfileupload {
+ Line 4127  sub finishuserfileupload {
  # Save the file
      {
- 	if (!open(FH,'>'.$filepath.'/'.$file)) {
+ 	if (!open(FH,'>',$filepath.'/'.$file)) {
  	    &logthis('Failed to create '.$filepath.'/'.$file);
  	    print STDERR ('Failed to create '.$filepath.'/'.$file."\n");
  	    return '/adm/notfound.html';
- Line 2967  sub finishuserfileupload {
+ Line 4162  sub finishuserfileupload {
              }
  	}
      }
-     if ($parser eq 'parse') {
+     if (($context eq 'coursedoc') || ($parser eq 'parse')) {
-         my $mm = new File::MMagic;
+         if (ref($mimetype)) {
-         my $type = $mm->checktype_filename($filepath.'/'.$file);
+             if ($$mimetype eq '') {
-         if ($type eq 'text/html') {
+                 my $mm = new File::MMagic;
+                 my $type = $mm->checktype_filename($filepath.'/'.$file);
+                 $$mimetype = $type;
+             }
+         }
+     }
+     if (($context ne 'scantron') && ($parser eq 'parse')) {
+         if ((ref($mimetype)) && ($$mimetype eq 'text/html')) {
              my $parse_result = &extract_embedded_items($filepath.'/'.$file,
                                                         $allfiles,$codebase);
              unless ($parse_result eq 'ok') {
- Line 2978  sub finishuserfileupload {
+ Line 4180  sub finishuserfileupload {
  	   	         ' for embedded media: '.$parse_result);
              }
          }
-         if (ref($mimetype)) {
+     } elsif (($context eq 'scantron') && (ref($parser) eq 'HASH')) {
-             $$mimetype = $type;
+         my $format = $env{'form.scantron_format'};
-         }
+         &bubblesheet_converter($docudom,$filepath.'/'.$file,$parser,$format);
      }
      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");
+         my @args = ('convert','-sample',$thumbsize,$input,$output);
+         system({$args[0]} @args);
          if (-e $filepath.'/'.'tn-'.$file) {
              $fetchthumb  = 1;
          }
- Line 3017  sub finishuserfileupload {
+ Line 4220  sub finishuserfileupload {
  sub extract_embedded_items {
      my ($fullpath,$allfiles,$codebase,$content) = @_;
      my @state = ();
+     my (%lastids,%related,%shockwave,%flashvars);
      my %javafiles = (
                        codebase => '',
                        code => '',
- Line 3043  sub extract_embedded_items {
+ Line 4247  sub extract_embedded_items {
  		&add_filetype($allfiles,$attr->{'src'},'src');
  	    }
  	    if (lc($tagname) eq 'a') {
- 		&add_filetype($allfiles,$attr->{'href'},'href');
+                 unless (($attr->{'href'} =~ /^#/) || ($attr->{'href'} eq '')) {
+ 		    &add_filetype($allfiles,$attr->{'href'},'href');
+                 }
  	    }
              if (lc($tagname) eq 'script') {
+                 my $src;
                  if ($attr->{'archive'} =~ /\.jar$/i) {
                      &add_filetype($allfiles,$attr->{'archive'},'archive');
                  } else {
-                     &add_filetype($allfiles,$attr->{'src'},'src');
+                     if ($attr->{'src'} ne '') {
+                         $src = $attr->{'src'};
+                         &add_filetype($allfiles,$src,'src');
+                     }
+                 }
+                 my $text = $p->get_trimmed_text();
+                 if ($text =~ /\Qswfobject.registerObject(\E([^\)]+)\)/) {
+                     my @swfargs = split(/,/,$1);
+                     foreach my $item (@swfargs) {
+                         $item =~ s/["']//g;
+                         $item =~ s/^\s+//;
+                         $item =~ s/\s+$//;
+                     }
+                     if (($swfargs[0] ne'') && ($swfargs[2] ne '')) {
+                         if (ref($related{$swfargs[0]}) eq 'ARRAY') {
+                             push(@{$related{$swfargs[0]}},$swfargs[2]);
+                         } else {
+                             $related{$swfargs[0]} = [$swfargs[2]];
+                         }
+                     }
                  }
              }
              if (lc($tagname) eq 'link') {
- Line 3062  sub extract_embedded_items {
+ Line 4288  sub extract_embedded_items {
  		foreach my $item (keys(%javafiles)) {
  		    $javafiles{$item} = '';
  		}
+                 if ((lc($tagname) eq 'object') && (lc($state[-2]) ne 'object')) {
+                     $lastids{lc($tagname)} = $attr->{'id'};
+                 }
  	    }
  	    if (lc($state[-2]) eq 'object' && lc($tagname) eq 'param') {
  		my $name = lc($attr->{'name'});
- Line 3071  sub extract_embedded_items {
+ Line 4300  sub extract_embedded_items {
  			last;
  		    }
  		}
+                 my $pathfrom;
  		foreach my $item (keys(%mediafiles)) {
  		    if ($name eq $item) {
- 			&add_filetype($allfiles, $attr->{'value'}, 'value');
+                         $pathfrom = $attr->{'value'};
+                         $shockwave{$lastids{lc($state[-2])}} = $pathfrom;
+ 			&add_filetype($allfiles,$pathfrom,$name);
  			last;
  		    }
  		}
+                 if ($name eq 'flashvars') {
+                     $flashvars{$lastids{lc($state[-2])}} = $attr->{'value'};
+                 }
+                 if ($pathfrom ne '') {
+                     &embedded_dependency($allfiles,\%related,$lastids{lc($state[-2])},
+                                          $pathfrom);
+                 }
  	    }
  	    if (lc($tagname) eq 'embed' || lc($tagname) eq 'applet') {
  		foreach my $item (keys(%javafiles)) {
- Line 3091  sub extract_embedded_items {
+ Line 4330  sub extract_embedded_items {
  			last;
  		    }
  		}
+                 if (lc($tagname) eq 'embed') {
+                     if (($attr->{'name'} ne '') && ($attr->{'src'} ne '')) {
+                         &embedded_dependency($allfiles,\%related,$attr->{'name'},
+                                              $attr->{'src'});
+                     }
+                 }
  	    }
+             if (lc($tagname) eq 'iframe') {
+                 my $src = $attr->{'src'} ;
+                 if (($src ne '') && ($src !~ m{^(/|https?://)})) {
+                     &add_filetype($allfiles,$src,'src');
+                 } elsif ($src =~ m{^/}) {
+                     if ($env{'request.course.id'}) {
+                         my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
+                         my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
+                         my $url = &hreflocation('',$fullpath);
+                         if ($url =~ m{^/uploaded/$cdom/$cnum/docs/(\w+/\d+)/}) {
+                             my $relpath = $1;
+                             if ($src =~ m{^/uploaded/$cdom/$cnum/docs/\Q$relpath\E/(.+)$}) {
+                                 &add_filetype($allfiles,$1,'src');
+                             }
+                         }
+                     }
+                 }
+             }
+             if ($t->[4] =~ m{/>$}) {
+                 pop(@state);
+             }
  	} elsif ($t->[0] eq 'E') {
  	    my ($tagname) = ($t->[1]);
  	    if ($javafiles{'codebase'} ne '') {
- Line 3111  sub extract_embedded_items {
+ Line 4377  sub extract_embedded_items {
  	    pop @state;
  	}
      }
+     foreach my $id (sort(keys(%flashvars))) {
+         if ($shockwave{$id} ne '') {
+             my @pairs = split(/\&/,$flashvars{$id});
+             foreach my $pair (@pairs) {
+                 my ($key,$value) = split(/\=/,$pair);
+                 if ($key eq 'thumb') {
+                     &add_filetype($allfiles,$value,$key);
+                 } elsif ($key eq 'content') {
+                     my ($path) = ($shockwave{$id} =~ m{^(.+/)[^/]+$});
+                     my ($ext) = ($value =~ /\.([^.]+)$/);
+                     if ($ext ne '') {
+                         &add_filetype($allfiles,$path.$value,$ext);
+                     }
+                 }
+             }
+         }
+     }
      return 'ok';
  }
- Line 3125  sub add_filetype {
+ Line 4408  sub add_filetype {
      }
  }
+ sub embedded_dependency {
+     my ($allfiles,$related,$identifier,$pathfrom) = @_;
+     if ((ref($allfiles) eq 'HASH') && (ref($related) eq 'HASH')) {
+         if (($identifier ne '') &&
+             (ref($related->{$identifier}) eq 'ARRAY') &&
+             ($pathfrom ne '')) {
+             my ($path) = ($pathfrom =~ m{^(.+/)[^/]+$});
+             foreach my $dep (@{$related->{$identifier}}) {
+                 &add_filetype($allfiles,$path.$dep,'object');
+             }
+         }
+     }
+     return;
+ }
+ sub bubblesheet_converter {
+     my ($cdom,$fullpath,$config,$format) = @_;
+     if ((&domain($cdom) ne '') &&
+         ($fullpath =~ m{^\Q$perlvar{'lonDocRoot'}/userfiles/$cdom/\E$match_courseid/scantron_orig}) &&
+         (-e $fullpath) && (ref($config) eq 'HASH') && ($format ne '')) {
+         my (%csvcols,%csvoptions);
+         if (ref($config->{'fields'}) eq 'HASH') {
+             %csvcols = %{$config->{'fields'}};
+         }
+         if (ref($config->{'options'}) eq 'HASH') {
+             %csvoptions = %{$config->{'options'}};
+         }
+         my %csvbynum = reverse(%csvcols);
+         my %scantronconf = &get_scantron_config($format,$cdom);
+         if (keys(%scantronconf)) {
+             my %bynum = (
+                           $scantronconf{CODEstart} => 'CODEstart',
+                           $scantronconf{IDstart}   => 'IDstart',
+                           $scantronconf{PaperID}   => 'PaperID',
+                           $scantronconf{FirstName} => 'FirstName',
+                           $scantronconf{LastName}  => 'LastName',
+                           $scantronconf{Qstart}    => 'Qstart',
+                         );
+             my @ordered;
+             foreach my $item (sort { $a <=> $b } keys(%bynum)) {
+                 push(@ordered,$bynum{$item});
+             }
+             my %mapstart = (
+                               CODEstart => 'CODE',
+                               IDstart   => 'ID',
+                               PaperID   => 'PaperID',
+                               FirstName => 'FirstName',
+                               LastName  => 'LastName',
+                               Qstart    => 'FirstQuestion',
+                            );
+             my %maplength = (
+                               CODEstart => 'CODElength',
+                               IDstart   => 'IDlength',
+                               PaperID   => 'PaperIDlength',
+                               FirstName => 'FirstNamelength',
+                               LastName  => 'LastNamelength',
+             );
+             if (open(my $fh,'<',$fullpath)) {
+                 my $output;
+                 my %lettdig = &letter_to_digits();
+                 my %diglett = reverse(%lettdig);
+                 my $numletts = scalar(keys(%lettdig));
+                 my $num = 0;
+                 while (my $line=<$fh>) {
+                     $num ++;
+                     next if (($num == 1) && ($csvoptions{'hdr'} == 1));
+                     $line =~ s{[\r\n]+$}{};
+                     my %found;
+                     my @values = split(/,/,$line,-1);
+                     my ($qstart,$record);
+                     for (my $i=0; $i<@values; $i++) {
+                         if ((($qstart ne '') && ($i > $qstart)) ||
+                             ($csvbynum{$i} eq 'FirstQuestion')) {
+                             if ($values[$i] eq '') {
+                                 $values[$i] = $scantronconf{'Qoff'};
+                             } elsif ($scantronconf{'Qon'} eq 'number') {
+                                 if ($values[$i] =~ /^[A-Ja-j]$/) {
+                                     $values[$i] = $lettdig{uc($values[$i])};
+                                 }
+                             } elsif ($scantronconf{'Qon'} eq 'letter') {
+                                 if ($values[$i] =~ /^[0-9]$/) {
+                                     $values[$i] = $diglett{$values[$i]};
+                                 }
+                             } else {
+                                 if ($values[$i] =~ /^[0-9A-Ja-j]$/) {
+                                     my $digit;
+                                     if ($values[$i] =~ /^[A-Ja-j]$/) {
+                                         $digit = $lettdig{uc($values[$i])}-1;
+                                         if ($values[$i] eq 'J') {
+                                             $digit += $numletts;
+                                         }
+                                     } elsif ($values[$i] =~ /^[0-9]$/) {
+                                         $digit = $values[$i]-1;
+                                         if ($values[$i] eq '0') {
+                                             $digit += $numletts;
+                                         }
+                                     }
+                                     my $qval='';
+                                     for (my $j=0; $j<$scantronconf{'Qlength'}; $j++) {
+                                         if ($j == $digit) {
+                                             $qval .= $scantronconf{'Qon'};
+                                         } else {
+                                             $qval .= $scantronconf{'Qoff'};
+                                         }
+                                     }
+                                     $values[$i] = $qval;
+                                 }
+                             }
+                             if (length($values[$i]) > $scantronconf{'Qlength'}) {
+                                 $values[$i] = substr($values[$i],0,$scantronconf{'Qlength'});
+                             }
+                             my $numblank = $scantronconf{'Qlength'} - length($values[$i]);
+                             if ($numblank > 0) {
+                                  $values[$i] .= ($scantronconf{'Qoff'} x $numblank);
+                             }
+                             if ($csvbynum{$i} eq 'FirstQuestion') {
+                                 $qstart = $i;
+                                 $found{$csvbynum{$i}} = $values[$i];
+                             } else {
+                                 $found{'FirstQuestion'} .= $values[$i];
+                             }
+                         } elsif (exists($csvbynum{$i})) {
+                             if ($csvoptions{'rem'}) {
+                                 $values[$i] =~ s/^\s+//;
+                             }
+                             if (($csvbynum{$i} eq 'PaperID') && ($csvoptions{'pad'})) {
+                                 while (length($values[$i]) < $scantronconf{$maplength{$csvbynum{$i}}}) {
+                                     $values[$i] = '0'.$values[$i];
+                                 }
+                             }
+                             $found{$csvbynum{$i}} = $values[$i];
+                         }
+                     }
+                     foreach my $item (@ordered) {
+                         my $currlength = 1+length($record);
+                         my $numspaces = $scantronconf{$item} - $currlength;
+                         if ($numspaces > 0) {
+                             $record .= (' ' x $numspaces);
+                         }
+                         if (($mapstart{$item} ne '') && (exists($found{$mapstart{$item}}))) {
+                             unless ($item eq 'Qstart') {
+                                 if (length($found{$mapstart{$item}}) > $scantronconf{$maplength{$item}}) {
+                                     $found{$mapstart{$item}} = substr($found{$mapstart{$item}},0,$scantronconf{$maplength{$item}});
+                                 }
+                             }
+                             $record .= $found{$mapstart{$item}};
+                         }
+                     }
+                     $output .= "$record\n";
+                 }
+                 close($fh);
+                 if ($output) {
+                     if (open(my $fh,'>',$fullpath)) {
+                         print $fh $output;
+                         close($fh);
+                     }
+                 }
+             }
+         }
+         return;
+     }
+ }
+ sub letter_to_digits {
+     my %lettdig = (
+                     A => 1,
+                     B => 2,
+                     C => 3,
+                     D => 4,
+                     E => 5,
+                     F => 6,
+                     G => 7,
+                     H => 8,
+                     I => 9,
+                     J => 0,
+                   );
+     return %lettdig;
+ }
+ sub get_scantron_config {
+     my ($which,$cdom) = @_;
+     my @lines = &get_scantronformat_file($cdom);
+     my %config;
+     #FIXME probably should move to XML it has already gotten a bit much now
+     foreach my $line (@lines) {
+         my ($name,$descrip)=split(/:/,$line);
+         if ($name ne $which ) { next; }
+         chomp($line);
+         my @config=split(/:/,$line);
+         $config{'name'}=$config[0];
+         $config{'description'}=$config[1];
+         $config{'CODElocation'}=$config[2];
+         $config{'CODEstart'}=$config[3];
+         $config{'CODElength'}=$config[4];
+         $config{'IDstart'}=$config[5];
+         $config{'IDlength'}=$config[6];
+         $config{'Qstart'}=$config[7];
+         $config{'Qlength'}=$config[8];
+         $config{'Qoff'}=$config[9];
+         $config{'Qon'}=$config[10];
+         $config{'PaperID'}=$config[11];
+         $config{'PaperIDlength'}=$config[12];
+         $config{'FirstName'}=$config[13];
+         $config{'FirstNamelength'}=$config[14];
+         $config{'LastName'}=$config[15];
+         $config{'LastNamelength'}=$config[16];
+         $config{'BubblesPerRow'}=$config[17];
+         last;
+     }
+     return %config;
+ }
+ sub get_scantronformat_file {
+     my ($cdom) = @_;
+     if ($cdom eq '') {
+         $cdom= $env{'course.'.$env{'request.course.id'}.'.domain'};
+     }
+     my %domconfig = &get_dom('configuration',['scantron'],$cdom);
+     my $gottab = 0;
+     my @lines;
+     if (ref($domconfig{'scantron'}) eq 'HASH') {
+         if ($domconfig{'scantron'}{'scantronformat'} ne '') {
+             my $formatfile = &getfile($perlvar{'lonDocRoot'}.$domconfig{'scantron'}{'scantronformat'});
+             if ($formatfile ne '-1') {
+                 @lines = split("\n",$formatfile,-1);
+                 $gottab = 1;
+             }
+         }
+     }
+     if (!$gottab) {
+         my $confname = $cdom.'-domainconfig';
+         my $default = $perlvar{'lonDocRoot'}.'/res/'.$cdom.'/'.$confname.'/default.tab';
+         my $formatfile = &getfile($default);
+         if ($formatfile ne '-1') {
+             @lines = split("\n",$formatfile,-1);
+             $gottab = 1;
+         }
+     }
+     if (!$gottab) {
+         my @domains = &current_machine_domains();
+         if (grep(/^\Q$cdom\E$/,@domains)) {
+             if (open(my $fh,'<',$perlvar{'lonTabDir'}.'/scantronformat.tab')) {
+                 @lines = <$fh>;
+                 close($fh);
+             }
+         } else {
+             if (open(my $fh,'<',$perlvar{'lonTabDir'}.'/default_scantronformat.tab')) {
+                 @lines = <$fh>;
+                 close($fh);
+             }
+         }
+         chomp(@lines);
+     }
+     return @lines;
+ }
  sub removeuploadedurl {
      my ($url)=@_;
      my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);
- Line 3242  sub flushcourselogs {
+ Line 4781  sub flushcourselogs {
              if (! defined($dom) || $dom eq '' ||
                  ! defined($name) || $name eq '') {
                  my $cid = $env{'request.course.id'};
+ #
+ # FIXME 11/29/2021
+ # Typo in rev. 1.458 (2003/12/09)??
+ # These should likely by $env{'course.'.$cid.'.domain'} and $env{'course.'.$cid.'.num'}
+ #
+ # While these ramain as  $env{'request.'.$cid.'.domain'} and $env{'request.'.$cid.'.num'}
+ # $dom and $name will always be null, so the &inc() call will default to storing this data
+ # in a nohist_accesscount.db file for the user rather than the course.
+ #
+ # That said there is a lot of noise in the data being stored.
+ # So counts for prtspool/  and adm/ etc. are recorded.
+ #
+ # A review of which items ending '___count' are written to %accesshash should likely be
+ # made before deciding whether to set these to 'course.' instead of 'request.'
+ #
+ # Under the current scheme each user receives a nohist_accesscount.db file listing
+ # accesses for things which are not published resources, regardless of course, and
+ # there is not a nohist_accesscount.db file in a course, which might log accesses from
+ # anyone in the course for things which are not published resources.
+ #
+ # For an author, nohist_accesscount.db ends up having records for other items
+ # mixed up with the legitimate access counts for the author's published resources.
+ #
                  $dom  = $env{'request.'.$cid.'.domain'};
                  $name = $env{'request.'.$cid.'.num'};
              }
- Line 3251  sub flushcourselogs {
+ Line 4813  sub flushcourselogs {
              my $result = &inc('nohist_accesscount',\%temphash,$dom,$name);
              if ($result eq 'ok') {
                  delete $accesshash{$entry};
-             } elsif ($result eq 'unknown_cmd') {
-                 # Target server has old code running on it.
-                 my %temphash=($entry => $value);
-                 if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
-                     delete $accesshash{$entry};
-                 }
              }
          } else {
              my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$});
+             if (($dom eq 'uploaded') || ($dom eq 'adm')) { next; }
              my %temphash=($entry => $accesshash{$entry});
              if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
                  delete $accesshash{$entry};
- Line 3280  sub flushcourselogs {
+ Line 4837  sub flushcourselogs {
          }
      }
  #
- # Reverse lookup of domain roles (dc, ad, li, sc, au)
+ # Reverse lookup of domain roles (dc, ad, li, sc, dh, da, au)
  #
      my %domrolebuffer = ();
      foreach my $entry (keys(%domainrolehash)) {
- Line 3295  sub flushcourselogs {
+ Line 4852  sub flushcourselogs {
          delete $domainrolehash{$entry};
      }
      foreach my $dom (keys(%domrolebuffer)) {
- 	my %servers = &get_servers($dom,'library');
+         my %servers;
+         if (defined(&domain($dom,'primary'))) {
+             my $primary=&domain($dom,'primary');
+             my $hostname=&hostname($primary);
+             $servers{$primary} = $hostname;
+         } else {
+             %servers = &get_servers($dom,'library');
+         }
  	foreach my $tryserver (keys(%servers)) {
- 	    unless (&reply('domroleput:'.$dom.':'.
+ 	    if (&reply('domroleput:'.$dom.':'.
- 			   $domrolebuffer{$dom},$tryserver) eq 'ok') {
+ 	               $domrolebuffer{$dom},$tryserver) eq 'ok') {
+ 	        last;
+ 	    } else {
  		&logthis('Put of domain roles failed for '.$dom.' and  '.$tryserver);
  	    }
          }
- Line 3347  sub courseacclog {
+ Line 4913  sub courseacclog {
                  if ($formitem =~ /^HWFILE(?:SIZE|TOOBIG)/) {
                      $what.=':'.$formitem.'='.$env{$key};
                  } elsif ($formitem !~ /^HWFILE(?:[^.]+)$/) {
-                     $what.=':'.$formitem.'='.$env{$key};
+                     if ($formitem eq 'proctorpassword') {
+                         $what.=':'.$formitem.'=' . '*' x length($env{$key});
+                     } else {
+                         $what.=':'.$formitem.'='.$env{$key};
+                     }
                  }
              }
          }
- Line 3370  sub countacc {
+ Line 4940  sub countacc {
      my $url=&declutter(shift);
      return if (! defined($url) || $url eq '');
      unless ($env{'request.course.id'}) { return ''; }
+ #
+ # Mark that this url was used in this course
+ #
      $accesshash{$env{'request.course.id'}.'___'.$url.'___course'}=1;
+ #
+ # Increase the access count for this resource in this child process
+ #
      my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';
      $accesshash{$key}++;
  }
- Line 3382  sub linklog {
+ Line 4958  sub linklog {
      $accesshash{$from.'___'.$to.'___comefrom'}=1;
      $accesshash{$to.'___'.$from.'___goto'}=1;
  }
+ sub statslog {
+     my ($symb,$part,$users,$av_attempts,$degdiff)=@_;
+     if ($users<2) { return; }
+     my %dynstore=&LONCAPA::lonmetadata::dynamic_metadata_storage({
+             'course'       => $env{'request.course.id'},
+             'sections'     => '"all"',
+             'num_students' => $users,
+             'part'         => $part,
+             'symb'         => $symb,
+             'mean_tries'   => $av_attempts,
+             'deg_of_diff'  => $degdiff});
+     foreach my $key (keys(%dynstore)) {
+         $accesshash{$key}=$dynstore{$key};
+     }
+ }
  sub userrolelog {
      my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
-     if (($trole=~/^ca/) || ($trole=~/^aa/) ||
+     if ( $trole =~ /^(ca|aa|in|cc|ep|cr|ta|co)/ ) {
-         ($trole=~/^in/) || ($trole=~/^cc/) ||
-         ($trole=~/^ep/) || ($trole=~/^cr/) ||
-         ($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\./) &&
+     if ($env{'request.role'} =~ /dc\./ && $trole =~ /^(au|in|cc|ep|cr|ta|co)/) {
- 	(($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/) ||
+     if ($trole =~ /^(dc|ad|li|au|dg|sc|dh|da)/ ) {
-         ($trole=~/^li/) || ($trole=~/^li/) ||
-         ($trole=~/^au/) || ($trole=~/^dg/) ||
-         ($trole=~/^sc/)) {
         my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
         $domainrolehash
           {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
- Line 3416  sub userrolelog {
+ Line 4998  sub userrolelog {
  sub courserolelog {
      my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_;
-     if (($trole eq 'cc') || ($trole eq 'in') ||
+     if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {
-         ($trole eq 'ep') || ($trole eq 'ad') ||
+         my $cdom = $1;
-         ($trole eq 'ta') || ($trole eq 'st') ||
+         my $cnum = $2;
-         ($trole=~/^cr/) || ($trole eq 'gr') ||
+         my $sec = $3;
-         ($trole eq 'co')) {
+         my $namespace = 'rolelog';
-         if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {
+         my %storehash = (
-             my $cdom = $1;
+                            role    => $trole,
-             my $cnum = $2;
+                            start   => $tstart,
-             my $sec = $3;
+                            end     => $tend,
-             my $namespace = 'rolelog';
+                            selfenroll => $selfenroll,
-             my %storehash = (
+                            context    => $context,
-                                role    => $trole,
+                         );
-                                start   => $tstart,
+         if ($trole eq 'gr') {
-                                end     => $tend,
+             $namespace = 'groupslog';
-                                selfenroll => $selfenroll,
+             $storehash{'group'} = $sec;
-                                context    => $context,
+         } else {
-                             );
+             $storehash{'section'} = $sec;
-             if ($trole eq 'gr') {
+         }
-                 $namespace = 'groupslog';
+         &write_log('course',$namespace,\%storehash,$delflag,$username,
-                 $storehash{'group'} = $sec;
+                    $domain,$cnum,$cdom);
-             } else {
+         if (($trole ne 'st') || ($sec ne '')) {
-                 $storehash{'section'} = $sec;
+             &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum);
-             }
-             &instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom);
-             if (($trole ne 'st') || ($sec ne '')) {
-                 &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum);
-             }
          }
      }
      return;
  }
+ sub domainrolelog {
+     my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_;
+     if ($area =~ m{^/($match_domain)/$}) {
+         my $cdom = $1;
+         my $domconfiguser = &Apache::lonnet::get_domainconfiguser($cdom);
+         my $namespace = 'rolelog';
+         my %storehash = (
+                            role    => $trole,
+                            start   => $tstart,
+                            end     => $tend,
+                            context => $context,
+                         );
+         &write_log('domain',$namespace,\%storehash,$delflag,$username,
+                    $domain,$domconfiguser,$cdom);
+     }
+     return;
+ }
+ sub coauthorrolelog {
+     my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_;
+     if ($area =~ m{^/($match_domain)/($match_username)$}) {
+         my $audom = $1;
+         my $auname = $2;
+         my $namespace = 'rolelog';
+         my %storehash = (
+                            role    => $trole,
+                            start   => $tstart,
+                            end     => $tend,
+                            context => $context,
+                         );
+         &write_log('author',$namespace,\%storehash,$delflag,$username,
+                    $domain,$auname,$audom);
+     }
+     return;
+ }
  sub get_course_adv_roles {
      my ($cid,$codes) = @_;
      $cid=$env{'request.course.id'} unless (defined($cid));
- Line 3461  sub get_course_adv_roles {
+ Line 5075  sub get_course_adv_roles {
              $nothide{$user}=1;
          }
      }
+     my @possdoms = ($coursehash{'domain'});
+     if ($coursehash{'checkforpriv'}) {
+         push(@possdoms,split(/,/,$coursehash{'checkforpriv'}));
+     }
      my %returnhash=();
      my %dumphash=
              &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
- Line 3473  sub get_course_adv_roles {
+ Line 5091  sub get_course_adv_roles {
          if (($tstart) && ($now<$tstart)) { next; }
          my ($role,$username,$domain,$section)=split(/\:/,$entry);
  	if ($username eq '' || $domain eq '') { next; }
-         unless (ref($privileged{$domain}) eq 'HASH') {
+         if ((&privileged($username,$domain,\@possdoms)) &&
-             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; }
          if ($codes) {
- Line 3515  sub get_my_roles {
+ Line 5120  sub get_my_roles {
      unless (defined($udom)) { $udom=$env{'user.domain'}; }
      my (%dumphash,%nothide);
      if ($context eq 'userroles') {
-         my $extra = &freeze_escape({'skipcheck' => 1});
+         %dumphash = &dump('roles',$udom,$uname);
-         %dumphash = &dump('roles',$udom,$uname,'.',undef,$extra);
      } else {
-         %dumphash=
+         %dumphash = &dump('nohist_userroles',$udom,$uname);
-             &dump('nohist_userroles',$udom,$uname);
          if ($hidepriv) {
              my %coursehash=&coursedescription($udom.'_'.$uname);
              foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
- Line 3537  sub get_my_roles {
+ Line 5140  sub get_my_roles {
      foreach my $entry (keys(%dumphash)) {
          my ($role,$tend,$tstart);
          if ($context eq 'userroles') {
+             next if ($entry =~ /^rolesdef/);
  	    ($role,$tend,$tstart)=split(/_/,$dumphash{$entry});
          } else {
              ($tend,$tstart)=split(/\:/,$dumphash{$entry});
- Line 3560  sub get_my_roles {
+ Line 5164  sub get_my_roles {
          }
          my ($rolecode,$username,$domain,$section,$area);
          if ($context eq 'userroles') {
-             ($area,$rolecode) = split(/_/,$entry);
+             ($area,$rolecode) = ($entry =~ /^(.+)_([^_]+)$/);
              (undef,$domain,$username,$section) = split(/\//,$area);
          } else {
              ($role,$username,$domain,$section) = split(/\:/,$entry);
- Line 3586  sub get_my_roles {
+ Line 5190  sub get_my_roles {
              }
          }
          if ($hidepriv) {
+             my @privroles = ('dc','su');
              if ($context eq 'userroles') {
-                 if ((&privileged($username,$domain)) &&
+                 next if (grep(/^\Q$role\E$/,@privroles));
-                     (!$nothide{$username.':'.$domain})) {
-                     next;
-                 }
              } else {
-                 unless (ref($privileged{$domain}) eq 'HASH') {
+                 my $possdoms = [$domain];
-                     my %dompersonnel =
+                 if (ref($roledoms) eq 'ARRAY') {
-                         &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now);
+                    push(@{$possdoms},@{$roledoms});
-                     $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 (&privileged($username,$domain,$possdoms,\@privroles)) {
                      if (!$nothide{$username.':'.$domain}) {
                          next;
                      }
- Line 3624  sub get_my_roles {
+ Line 5215  sub get_my_roles {
      return %returnhash;
  }
+ sub get_all_adhocroles {
+     my ($dom) = @_;
+     my @roles_by_num = ();
+     my %domdefaults = &get_domain_defaults($dom);
+     my (%description,%access_in_dom,%access_info);
+     if (ref($domdefaults{'adhocroles'}) eq 'HASH') {
+         my $count = 0;
+         my %domcurrent = %{$domdefaults{'adhocroles'}};
+         my %ordered;
+         foreach my $role (sort(keys(%domcurrent))) {
+             my ($order,$desc,$access_in_dom);
+             if (ref($domcurrent{$role}) eq 'HASH') {
+                 $order = $domcurrent{$role}{'order'};
+                 $desc = $domcurrent{$role}{'desc'};
+                 $access_in_dom{$role} = $domcurrent{$role}{'access'};
+                 $access_info{$role} = $domcurrent{$role}{$access_in_dom{$role}};
+             }
+             if ($order eq '') {
+                 $order = $count;
+             }
+             $ordered{$order} = $role;
+             if ($desc ne '') {
+                 $description{$role} = $desc;
+             } else {
+                 $description{$role}= $role;
+             }
+             $count++;
+         }
+         foreach my $item (sort {$a <=> $b } (keys(%ordered))) {
+             push(@roles_by_num,$ordered{$item});
+         }
+     }
+     return (\@roles_by_num,\%description,\%access_in_dom,\%access_info);
+ }
+ sub get_my_adhocroles {
+     my ($cid,$checkreg) = @_;
+     my ($cdom,$cnum,%info,@possroles,$description,$roles_by_num);
+     if ($env{'request.course.id'} eq $cid) {
+         $cdom = $env{'course.'.$cid.'.domain'};
+         $cnum = $env{'course.'.$cid.'.num'};
+         $info{'internal.coursecode'} = $env{'course.'.$cid.'.internal.coursecode'};
+     } elsif ($cid =~ /^($match_domain)_($match_courseid)$/) {
+         $cdom = $1;
+         $cnum = $2;
+         %info = &Apache::lonnet::get('environment',['internal.coursecode'],
+                                      $cdom,$cnum);
+     }
+     if (($info{'internal.coursecode'} ne '') && ($checkreg)) {
+         my $user = $env{'user.name'}.':'.$env{'user.domain'};
+         my %rosterhash = &get('classlist',[$user],$cdom,$cnum);
+         if ($rosterhash{$user} ne '') {
+             my $type = (split(/:/,$rosterhash{$user}))[5];
+             return ([],{}) if ($type eq 'auto');
+         }
+     }
+     if (($cdom ne '') && ($cnum ne ''))  {
+         if (($env{"user.role.dh./$cdom/"}) || ($env{"user.role.da./$cdom/"})) {
+             my $then=$env{'user.login.time'};
+             my $update=$env{'user.update.time'};
+             if (!$update) {
+                 $update = $then;
+             }
+             my @liveroles;
+             foreach my $role ('dh','da') {
+                 if ($env{"user.role.$role./$cdom/"}) {
+                     my ($tstart,$tend)=split(/\./,$env{"user.role.$role./$cdom/"});
+                     my $limit = $update;
+                     if ($env{'request.role'} eq "$role./$cdom/") {
+                         $limit = $then;
+                     }
+                     my $activerole = 1;
+                     if ($tstart && $tstart>$limit) { $activerole = 0; }
+                     if ($tend   && $tend  <$limit) { $activerole = 0; }
+                     if ($activerole) {
+                         push(@liveroles,$role);
+                     }
+                 }
+             }
+             if (@liveroles) {
+                 if (&homeserver($cnum,$cdom) ne 'no_host') {
+                     my ($accessref,$accessinfo,%access_in_dom);
+                     ($roles_by_num,$description,$accessref,$accessinfo) = &get_all_adhocroles($cdom);
+                     if (ref($roles_by_num) eq 'ARRAY') {
+                         if (@{$roles_by_num}) {
+                             my %settings;
+                             if ($env{'request.course.id'} eq $cid) {
+                                 foreach my $envkey (keys(%env)) {
+                                     if ($envkey =~ /^\Qcourse.$cid.\E(internal\.adhoc.+)$/) {
+                                         $settings{$1} = $env{$envkey};
+                                     }
+                                 }
+                             } else {
+                                 %settings = &dump('environment',$cdom,$cnum,'internal\.adhoc');
+                             }
+                             my %setincrs;
+                             if ($settings{'internal.adhocaccess'}) {
+                                 map { $setincrs{$_} = 1; } split(/,/,$settings{'internal.adhocaccess'});
+                             }
+                             my @statuses;
+                             if ($env{'environment.inststatus'}) {
+                                 @statuses = split(/,/,$env{'environment.inststatus'});
+                             }
+                             my $user = $env{'user.name'}.':'.$env{'user.domain'};
+                             if (ref($accessref) eq 'HASH') {
+                                 %access_in_dom = %{$accessref};
+                             }
+                             foreach my $role (@{$roles_by_num}) {
+                                 my ($curraccess,@okstatus,@personnel);
+                                 if ($setincrs{$role}) {
+                                     ($curraccess,my $rest) = split(/=/,$settings{'internal.adhoc.'.$role});
+                                     if ($curraccess eq 'status') {
+                                         @okstatus = split(/\&/,$rest);
+                                     } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) {
+                                         @personnel = split(/\&/,$rest);
+                                     }
+                                 } else {
+                                     $curraccess = $access_in_dom{$role};
+                                     if (ref($accessinfo) eq 'HASH') {
+                                         if ($curraccess eq 'status') {
+                                             if (ref($accessinfo->{$role}) eq 'ARRAY') {
+                                                 @okstatus = @{$accessinfo->{$role}};
+                                             }
+                                         } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) {
+                                             if (ref($accessinfo->{$role}) eq 'ARRAY') {
+                                                 @personnel = @{$accessinfo->{$role}};
+                                             }
+                                         }
+                                     }
+                                 }
+                                 if ($curraccess eq 'none') {
+                                     next;
+                                 } elsif ($curraccess eq 'all') {
+                                     push(@possroles,$role);
+                                 } elsif ($curraccess eq 'dh') {
+                                     if (grep(/^dh$/,@liveroles)) {
+                                         push(@possroles,$role);
+                                     } else {
+                                         next;
+                                     }
+                                 } elsif ($curraccess eq 'da') {
+                                     if (grep(/^da$/,@liveroles)) {
+                                         push(@possroles,$role);
+                                     } else {
+                                         next;
+                                     }
+                                 } elsif ($curraccess eq 'status') {
+                                     if (@okstatus) {
+                                         if (!@statuses) {
+                                             if (grep(/^default$/,@okstatus)) {
+                                                 push(@possroles,$role);
+                                             }
+                                         } else {
+                                             foreach my $status (@okstatus) {
+                                                 if (grep(/^\Q$status\E$/,@statuses)) {
+                                                     push(@possroles,$role);
+                                                     last;
+                                                 }
+                                             }
+                                         }
+                                     }
+                                 } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) {
+                                     if (grep(/^\Q$user\E$/,@personnel)) {
+                                         if ($curraccess eq 'exc') {
+                                             push(@possroles,$role);
+                                         }
+                                     } elsif ($curraccess eq 'inc') {
+                                         push(@possroles,$role);
+                                     }
+                                 }
+                             }
+                         }
+                     }
+                 }
+             }
+         }
+     }
+     unless (ref($description) eq 'HASH') {
+         if (ref($roles_by_num) eq 'ARRAY') {
+             my %desc;
+             map { $desc{$_} = $_; } (@{$roles_by_num});
+             $description = \%desc;
+         } else {
+             $description = {};
+         }
+     }
+     return (\@possroles,$description);
+ }
  # ----------------------------------------------------- Frontpage Announcements
  #
  #
- Line 3637  sub postannounce {
+ Line 5417  sub postannounce {
  sub getannounce {
-     if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) {
+     if (open(my $fh,"<",$perlvar{'lonDocRoot'}.'/announcement.txt')) {
  	my $announcement='';
  	while (my $line = <$fh>) { $announcement .= $line; }
  	close($fh);
- Line 3699  sub courseiddump {
+ Line 5479  sub courseiddump {
      my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
          $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
          $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,
-         $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner)=@_;
+         $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner,
+         $hasuniquecode,$reqcrsdom,$reqinstcode)=@_;
      my $as_hash = 1;
      my %returnhash;
      if (!$domfilter) { $domfilter=''; }
- Line 3711  sub courseiddump {
+ Line 5492  sub courseiddump {
  	    if (($domfilter eq '') ||
  		(&host_domain($tryserver) eq $domfilter)) {
-                 my $rep =
+                 my $rep;
-                   &reply('courseiddump:'.&host_domain($tryserver).':'.
+                 if (grep { $_ eq $tryserver } &current_machine_ids()) {
-                          $sincefilter.':'.&escape($descfilter).':'.
+                     $rep = &LONCAPA::Lond::dump_course_id_handler(
-                          &escape($instcodefilter).':'.&escape($ownerfilter).
+                         join(":", (&host_domain($tryserver), $sincefilter,
-                          ':'.&escape($coursefilter).':'.&escape($typefilter).
+                                 &escape($descfilter), &escape($instcodefilter),
-                          ':'.&escape($regexp_ok).':'.$as_hash.':'.
+                                 &escape($ownerfilter), &escape($coursefilter),
-                          &escape($selfenrollonly).':'.&escape($catfilter).':'.
+                                 &escape($typefilter), &escape($regexp_ok),
-                          $showhidden.':'.$caller.':'.&escape($cloner).':'.
+                                 $as_hash, &escape($selfenrollonly),
-                          &escape($cc_clone).':'.$cloneonly.':'.
+                                 &escape($catfilter), $showhidden, $caller,
-                          &escape($createdbefore).':'.&escape($createdafter).':'.
+                                 &escape($cloner), &escape($cc_clone), $cloneonly,
-                          &escape($creationcontext).':'.$domcloner,
+                                 &escape($createdbefore), &escape($createdafter),
-                          $tryserver);
+                                 &escape($creationcontext),$domcloner,$hasuniquecode,
+                                 $reqcrsdom,&escape($reqinstcode))));
+                 } else {
+                     $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.':'.$hasuniquecode.
+                              ':'.$reqcrsdom.':'.&escape($reqinstcode),$tryserver);
+                 }
                  my @pairs=split(/\&/,$rep);
                  foreach my $item (@pairs) {
                      my ($key,$value)=split(/\=/,$item,2);
- Line 3828  sub get_domain_roles {
+ Line 5624  sub get_domain_roles {
      }
      my $rolelist;
      if (ref($roles) eq 'ARRAY') {
-         $rolelist = join(':',@{$roles});
+         $rolelist = join('&',@{$roles});
      }
      my %personnel = ();
- Line 3848  sub get_domain_roles {
+ Line 5644  sub get_domain_roles {
      return %personnel;
  }
+ sub get_active_domroles {
+     my ($dom,$roles) = @_;
+     return () unless (ref($roles) eq 'ARRAY');
+     my $now = time;
+     my %dompersonnel = &get_domain_roles($dom,$roles,$now,$now);
+     my %domroles;
+     foreach my $server (keys(%dompersonnel)) {
+         foreach my $user (sort(keys(%{$dompersonnel{$server}}))) {
+             my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,$user);
+             $domroles{$uname.':'.$udom} = $dompersonnel{$server}{$user};
+         }
+     }
+     return %domroles;
+ }
  # ----------------------------------------------------------- Interval timing
+ {
+ # Caches needed for speedup of navmaps
+ # We don't want to cache this for very long at all (5 seconds at most)
+ #
+ # The user for whom we cache
+ my $cachedkey='';
+ # The cached times for this user
+ my %cachedtimes=();
+ # When this was last done
+ my $cachedtime='';
+ sub load_all_first_access {
+     my ($uname,$udom,$ignorecache)=@_;
+     if (($cachedkey eq $uname.':'.$udom) &&
+         (abs($cachedtime-time)<5) && (!$env{'form.markaccess'}) &&
+         (!$ignorecache)) {
+         return;
+     }
+     $cachedtime=time;
+     $cachedkey=$uname.':'.$udom;
+     %cachedtimes=&dump('firstaccesstimes',$udom,$uname);
+ }
  sub get_first_access {
-     my ($type,$argsymb)=@_;
+     my ($type,$argsymb,$argmap,$ignorecache)=@_;
      my ($symb,$courseid,$udom,$uname)=&whichuser();
      if ($argsymb) { $symb=$argsymb; }
      my ($map,$id,$res)=&decode_symb($symb);
+     if ($argmap) { $map = $argmap; }
      if ($type eq 'course') {
  	$res='course';
      } elsif ($type eq 'map') {
- Line 3862  sub get_first_access {
+ Line 5697  sub get_first_access {
      } else {
  	$res=$symb;
      }
-     my %times=&get('firstaccesstimes',["$courseid\0$res"],$udom,$uname);
+     &load_all_first_access($uname,$udom,$ignorecache);
-     return $times{"$courseid\0$res"};
+     return $cachedtimes{"$courseid\0$res"};
  }
  sub set_first_access {
-     my ($type)=@_;
+     my ($type,$interval)=@_;
      my ($symb,$courseid,$udom,$uname)=&whichuser();
      my ($map,$id,$res)=&decode_symb($symb);
      if ($type eq 'course') {
- Line 3877  sub set_first_access {
+ Line 5712  sub set_first_access {
      } else {
  	$res=$symb;
      }
-     my $firstaccess=&get_first_access($type,$symb);
+     $cachedkey='';
-     if (!$firstaccess) {
+     my $firstaccess=&get_first_access($type,$symb,$map);
- 	return &put('firstaccesstimes',{"$courseid\0$res"=>time},$udom,$uname);
+     if ($firstaccess) {
+         &logthis("First access time already set ($firstaccess) when attempting ".
+                  "to set new value (type: $type, extent: $res) for $uname:$udom ".
+                  "in $courseid");
+         return 'already_set';
+     } else {
+         my $start = time;
+ 	my $putres = &put('firstaccesstimes',{"$courseid\0$res"=>$start},
+                           $udom,$uname);
+         if ($putres eq 'ok') {
+             &put('timerinterval',{"$courseid\0$res"=>$interval},
+                  $udom,$uname);
+             &appenv(
+                      {
+                         'course.'.$courseid.'.firstaccess.'.$res   => $start,
+                         'course.'.$courseid.'.timerinterval.'.$res => $interval,
+                      }
+                   );
+             if (($cachedtime) && (abs($start-$cachedtime) < 5)) {
+                 $cachedtimes{"$courseid\0$res"} = $start;
+             }
+         } elsif ($putres ne 'refused') {
+             &logthis("Result: $putres when attempting to set first access time ".
+                      "(type: $type, extent: $res) for $uname:$udom in $courseid");
+         }
+         return $putres;
      }
      return 'already_set';
  }
+ }
+ sub checkout {
+     my ($symb,$tuname,$tudom,$tcrsid)=@_;
+     my $now=time;
+     my $lonhost=$perlvar{'lonHostID'};
+     my $ip = &get_requestor_ip();
+     my $infostr=&escape(
+                  'CHECKOUTTOKEN&'.
+                  $tuname.'&'.
+                  $tudom.'&'.
+                  $tcrsid.'&'.
+                  $symb.'&'.
+                  $now.'&'.$ip);
+     my $token=&reply('tmpput:'.$infostr,$lonhost);
+     if ($token=~/^error\:/) {
+         &logthis("<font color=\"blue\">WARNING: ".
+                 "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
+                  "</font>");
+         return '';
+     }
+     $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;
+     $token=~tr/a-z/A-Z/;
+     my %infohash=('resource.0.outtoken' => $token,
+                   'resource.0.checkouttime' => $now,
+                   'resource.0.outremote' => $ip);
+     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
+        return '';
+     } else {
+         &logthis("<font color=\"blue\">WARNING: ".
+                 "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
+                  "</font>");
+     }
+     if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
+                          &escape('Checkout '.$infostr.' - '.
+                                                  $token)) ne 'ok') {
+         return '';
+     } else {
+         &logthis("<font color=\"blue\">WARNING: ".
+                 "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
+                  "</font>");
+     }
+     return $token;
+ }
+ # ------------------------------------------------------------ Check in an item
+ sub checkin {
+     my $token=shift;
+     my $now=time;
+     my ($ta,$tb,$lonhost)=split(/\*/,$token);
+     $lonhost=~tr/A-Z/a-z/;
+     my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb;
+     $dtoken=~s/\W/\_/g;
+     my $ip = &get_requestor_ip();
+     my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
+                  split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
+     unless (($tuname) && ($tudom)) {
+         &logthis('Check in '.$token.' ('.$dtoken.') failed');
+         return '';
+     }
+     unless (&allowed('mgr',$tcrsid)) {
+         &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.
+                  $env{'user.name'}.' - '.$env{'user.domain'});
+         return '';
+     }
+     my %infohash=('resource.0.intoken' => $token,
+                   'resource.0.checkintime' => $now,
+                   'resource.0.inremote' => $ip);
+     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
+        return '';
+     }
+     if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
+                          &escape('Checkin - '.$token)) ne 'ok') {
+         return '';
+     }
+     return ($symb,$tuname,$tudom,$tcrsid);
+ }
  # --------------------------------------------- Set Expire Date for Spreadsheet
- Line 4138  sub tmpreset {
+ Line 6086  sub tmpreset {
    if (!$domain) { $domain=$env{'user.domain'}; }
    if (!$stuname) { $stuname=$env{'user.name'}; }
    if ($domain eq 'public' && $stuname eq 'public') {
-       $stuname=$ENV{'REMOTE_ADDR'};
+       $stuname=&get_requestor_ip();
    }
    my $path=LONCAPA::tempdir();
    my %hash;
- Line 4175  sub tmpstore {
+ Line 6123  sub tmpstore {
    if (!$domain) { $domain=$env{'user.domain'}; }
    if (!$stuname) { $stuname=$env{'user.name'}; }
    if ($domain eq 'public' && $stuname eq 'public') {
-       $stuname=$ENV{'REMOTE_ADDR'};
+       $stuname=&get_requestor_ip();
    }
    my $now=time;
    my %hash;
- Line 4219  sub tmprestore {
+ Line 6167  sub tmprestore {
    if (!$domain) { $domain=$env{'user.domain'}; }
    if (!$stuname) { $stuname=$env{'user.name'}; }
    if ($domain eq 'public' && $stuname eq 'public') {
-       $stuname=$ENV{'REMOTE_ADDR'};
+       $stuname=&get_requestor_ip();
    }
    my %returnhash;
    $namespace=~s/\//\_/g;
- Line 4254  sub tmprestore {
+ Line 6202  sub tmprestore {
  # ----------------------------------------------------------------------- Store
  sub store {
-     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
+     my ($storehash,$symb,$namespace,$domain,$stuname,$laststore) = @_;
      my $home='';
      if ($stuname) { $home=&homeserver($stuname,$domain); }
- Line 4275  sub store {
+ Line 6223  sub store {
      }
      if (!$home) { $home=$env{'user.home'}; }
-     $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};
+     $$storehash{'ip'}=&get_requestor_ip();
      $$storehash{'host'}=$perlvar{'lonHostID'};
      my $namevalue='';
- Line 4284  sub store {
+ Line 6232  sub store {
      }
      $namevalue=~s/\&$//;
      &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);
-     return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
+     return reply("store:$domain:$stuname:$namespace:$symb:$namevalue:$laststore","$home");
  }
  # -------------------------------------------------------------- Critical Store
  sub cstore {
-     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
+     my ($storehash,$symb,$namespace,$domain,$stuname,$laststore) = @_;
      my $home='';
      if ($stuname) { $home=&homeserver($stuname,$domain); }
- Line 4311  sub cstore {
+ Line 6259  sub cstore {
      }
      if (!$home) { $home=$env{'user.home'}; }
-     $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};
+     $$storehash{'ip'}=&get_requestor_ip();
      $$storehash{'host'}=$perlvar{'lonHostID'};
      my $namevalue='';
- Line 4321  sub cstore {
+ Line 6269  sub cstore {
      $namevalue=~s/\&$//;
      &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);
      return critical
-                 ("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
+                 ("store:$domain:$stuname:$namespace:$symb:$namevalue:$laststore","$home");
  }
  # --------------------------------------------------------------------- Restore
- Line 4333  sub restore {
+ Line 6281  sub restore {
      if ($stuname) { $home=&homeserver($stuname,$domain); }
      if (!$symb) {
-       unless ($symb=escape(&symbread())) { return ''; }
+         return if ($namespace eq 'courserequests');
+         unless ($symb=escape(&symbread())) { return ''; }
      } else {
-       $symb=&escape(&symbclean($symb));
+         unless ($namespace eq 'courserequests') {
+             $symb=&escape(&symbclean($symb));
+         }
      }
      if (!$namespace) {
         unless ($namespace=$env{'request.course.id'}) {
- Line 4470  sub update_released_required {
+ Line 6421  sub update_released_required {
  # -------------------------------------------------See if a user is privileged
  sub privileged {
-     my ($username,$domain)=@_;
+     my ($username,$domain,$possdomains,$possroles)=@_;
-     my $rolesdump=&reply("dump:$domain:$username:roles",
+     my $now = time;
- 			&homeserver($username,$domain));
+     my $roles;
-     if (($rolesdump eq 'con_lost') || ($rolesdump eq '') ||
+     if (ref($possroles) eq 'ARRAY') {
-         ($rolesdump =~ /^error:/)) {
+         $roles = $possroles;
-         return 0;
+     } else {
-     }
+         $roles = ['dc','su'];
-     my $now=time;
+     }
-     if ($rolesdump ne '') {
+     if (ref($possdomains) eq 'ARRAY') {
-         foreach my $entry (split(/&/,$rolesdump)) {
+         my %privileged = &privileged_by_domain($possdomains,$roles);
- 	    if ($entry!~/^rolesdef_/) {
+         foreach my $dom (@{$possdomains}) {
- 		my ($area,$role)=split(/=/,$entry);
+             if (($username =~ /^$match_username$/) && ($domain =~ /^$match_domain$/) &&
- 		$area=~s/\_\w\w$//;
+                 (ref($privileged{$dom}) eq 'HASH')) {
- 		my ($trole,$tend,$tstart)=split(/_/,$role);
+                 foreach my $role (@{$roles}) {
- 		if (($trole eq 'dc') || ($trole eq 'su')) {
+                     if (ref($privileged{$dom}{$role}) eq 'HASH') {
- 		    my $active=1;
+                         if (exists($privileged{$dom}{$role}{$username.':'.$domain})) {
- 		    if ($tend) {
+                             my ($end,$start) = split(/:/,$privileged{$dom}{$role}{$username.':'.$domain});
- 			if ($tend<$now) { $active=0; }
+                             return 1 unless (($end && $end < $now) ||
- 		    }
+                                              ($start && $start > $now));
- 		    if ($tstart) {
+                         }
- 			if ($tstart>$now) { $active=0; }
+                     }
- 		    }
+                 }
- 		    if ($active) { return 1; }
+             }
- 		}
+         }
- 	    }
+     } else {
- 	}
+         my %rolesdump = &dump("roles", $domain, $username) or return 0;
+         my $now = time;
+         for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys(%rolesdump)}) {
+             my ($trole, $tend, $tstart) = split(/_/, $role);
+             if (grep(/^\Q$trole\E$/,@{$roles})) {
+                 return 1 unless ($tend && $tend < $now)
+                         or ($tstart && $tstart > $now);
+             }
+         }
      }
      return 0;
  }
+ sub privileged_by_domain {
+     my ($domains,$roles) = @_;
+     my %privileged = ();
+     my $cachetime = 60*60*24;
+     my $now = time;
+     unless ((ref($domains) eq 'ARRAY') && (ref($roles) eq 'ARRAY')) {
+         return %privileged;
+     }
+     foreach my $dom (@{$domains}) {
+         next if (ref($privileged{$dom}) eq 'HASH');
+         my $needroles;
+         foreach my $role (@{$roles}) {
+             my ($result,$cached)=&is_cached_new('priv_'.$role,$dom);
+             if (defined($cached)) {
+                 if (ref($result) eq 'HASH') {
+                     $privileged{$dom}{$role} = $result;
+                 }
+             } else {
+                 $needroles = 1;
+             }
+         }
+         if ($needroles) {
+             my %dompersonnel = &get_domain_roles($dom,$roles);
+             $privileged{$dom} = {};
+             foreach my $server (keys(%dompersonnel)) {
+                 if (ref($dompersonnel{$server}) eq 'HASH') {
+                     foreach my $item (keys(%{$dompersonnel{$server}})) {
+                         my ($trole,$uname,$udom,$rest) = split(/:/,$item,4);
+                         my ($end,$start) = split(/:/,$dompersonnel{$server}{$item});
+                         next if ($end && $end < $now);
+                         $privileged{$dom}{$trole}{$uname.':'.$udom} =
+                             $dompersonnel{$server}{$item};
+                     }
+                 }
+             }
+             if (ref($privileged{$dom}) eq 'HASH') {
+                 foreach my $role (@{$roles}) {
+                     if (ref($privileged{$dom}{$role}) eq 'HASH') {
+                         &do_cache_new('priv_'.$role,$dom,$privileged{$dom}{$role},$cachetime);
+                     } else {
+                         my %hash = ();
+                         &do_cache_new('priv_'.$role,$dom,\%hash,$cachetime);
+                     }
+                 }
+             }
+         }
+     }
+     return %privileged;
+ }
  # -------------------------------------------------------- Get user privileges
  sub rolesinit {
-     my ($domain,$username,$authhost)=@_;
+     my ($domain, $username) = @_;
-     my $now=time;
+     my %userroles = ('user.login.time' => time);
-     my %userroles = ('user.login.time' => $now);
+     my %rolesdump = &dump("roles", $domain, $username) or return \%userroles;
-     my $extra = &freeze_escape({'skipcheck' => 1});
-     my $rolesdump=reply("dump:$domain:$username:roles:.::$extra",$authhost);
+     # firstaccess and timerinterval are related to timed maps/resources.
-     if (($rolesdump eq 'con_lost') || ($rolesdump eq '') ||
+     # also, blocking can be triggered by an activating timer
-         ($rolesdump =~ /^error:/)) {
+     # it's saved in the user's %env.
-         return \%userroles;
+     my %firstaccess = &dump('firstaccesstimes', $domain, $username);
+     my %timerinterval = &dump('timerinterval', $domain, $username);
+     my (%coursetimerstarts, %firstaccchk, %firstaccenv, %coursetimerintervals,
+         %timerintchk, %timerintenv);
+     foreach my $key (keys(%firstaccess)) {
+         my ($cid, $rest) = split(/\0/, $key);
+         $coursetimerstarts{$cid}{$rest} = $firstaccess{$key};
+     }
+     foreach my $key (keys(%timerinterval)) {
+         my ($cid,$rest) = split(/\0/,$key);
+         $coursetimerintervals{$cid}{$rest} = $timerinterval{$key};
      }
      my %allroles=();
      my %allgroups=();
-     if ($rolesdump ne '') {
+     for my $area (grep { ! /^rolesdef_/ } keys(%rolesdump)) {
-         foreach my $entry (split(/&/,$rolesdump)) {
+         my $role = $rolesdump{$area};
- 	  if ($entry!~/^rolesdef_/) {
+         $area =~ s/\_\w\w$//;
-             my ($area,$role)=split(/=/,$entry);
- 	    $area=~s/\_\w\w$//;
+         my ($trole, $tend, $tstart, $group_privs);
-             my ($trole,$tend,$tstart,$group_privs);
- 	    if ($role=~/^cr/) {
+         if ($role =~ /^cr/) {
- 		if ($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) {
+         # Custom role, defined by a user
- 		    ($trole,my $trest)=($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|);
+         # e.g., user.role.cr/msu/smith/mynewrole
- 		    ($tend,$tstart)=split('_',$trest);
+             if ($role =~ m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) {
- 		} else {
+                 $trole = $1;
- 		    $trole=$role;
+                 ($tend, $tstart) = split('_', $2);
- 		}
+             } else {
-             } elsif ($role =~ m|^gr/|) {
+                 $trole = $role;
-                 ($trole,$tend,$tstart) = split(/_/,$role);
-                 next if ($tstart eq '-1');
-                 ($trole,$group_privs) = split(/\//,$trole);
-                 $group_privs = &unescape($group_privs);
- 	    } else {
- 		($trole,$tend,$tstart)=split(/_/,$role);
- 	    }
- 	    my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain,
- 					 $username);
- 	    @userroles{keys(%new_role)} = @new_role{keys(%new_role)};
-             if (($tend!=0) && ($tend<$now)) { $trole=''; }
-             if (($tstart!=0) && ($tstart>$now)) { $trole=''; }
-             if (($area ne '') && ($trole ne '')) {
- 		my $spec=$trole.'.'.$area;
- 		my ($tdummy,$tdomain,$trest)=split(/\//,$area);
- 		if ($trole =~ /^cr\//) {
-                     &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
-                 } elsif ($trole eq 'gr') {
-                     &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);
- 		} else {
-                     &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
- 		}
              }
-           }
+         } elsif ($role =~ m|^gr/|) {
+         # Role of member in a group, defined within a course/community
+         # e.g., user.role.gr/msu/04935610a19ee4a5fmsul1/leopards
+             ($trole, $tend, $tstart) = split(/_/, $role);
+             next if $tstart eq '-1';
+             ($trole, $group_privs) = split(/\//, $trole);
+             $group_privs = &unescape($group_privs);
+         } else {
+         # Just a normal role, defined in roles.tab
+             ($trole, $tend, $tstart) = split(/_/,$role);
+         }
+         my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain,
+                  $username);
+         @userroles{keys(%new_role)} = @new_role{keys(%new_role)};
+         # role expired or not available yet?
+         $trole = '' if ($tend != 0 && $tend < $userroles{'user.login.time'}) or
+             ($tstart != 0 && $tstart > $userroles{'user.login.time'});
+         next if $area eq '' or $trole eq '';
+         my $spec = "$trole.$area";
+         my ($tdummy, $tdomain, $trest) = split(/\//, $area);
+         if ($trole =~ /^cr\//) {
+         # Custom role, defined by a user
+             &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
+         } elsif ($trole eq 'gr') {
+         # Role of a member in a group, defined within a course/community
+             &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);
+             next;
+         } else {
+         # Normal role, defined in roles.tab
+             &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
+         }
+         my $cid = $tdomain.'_'.$trest;
+         unless ($firstaccchk{$cid}) {
+             if (ref($coursetimerstarts{$cid}) eq 'HASH') {
+                 foreach my $item (keys(%{$coursetimerstarts{$cid}})) {
+                     $firstaccenv{'course.'.$cid.'.firstaccess.'.$item} =
+                         $coursetimerstarts{$cid}{$item};
+                 }
+             }
+             $firstaccchk{$cid} = 1;
+         }
+         unless ($timerintchk{$cid}) {
+             if (ref($coursetimerintervals{$cid}) eq 'HASH') {
+                 foreach my $item (keys(%{$coursetimerintervals{$cid}})) {
+                     $timerintenv{'course.'.$cid.'.timerinterval.'.$item} =
+                        $coursetimerintervals{$cid}{$item};
+                 }
+             }
+             $timerintchk{$cid} = 1;
          }
-         my ($author,$adv) = &set_userprivs(\%userroles,\%allroles,\%allgroups);
-         $userroles{'user.adv'}    = $adv;
- 	$userroles{'user.author'} = $author;
-         $env{'user.adv'}=$adv;
      }
-     return \%userroles;
+     @userroles{'user.author','user.adv','user.rar'} = &set_userprivs(\%userroles,
+                                                           \%allroles, \%allgroups);
+     $env{'user.adv'} = $userroles{'user.adv'};
+     $env{'user.rar'} = $userroles{'user.rar'};
+     return (\%userroles,\%firstaccenv,\%timerintenv);
  }
  sub set_arearole {
-     my ($trole,$area,$tstart,$tend,$domain,$username) = @_;
+     my ($trole,$area,$tstart,$tend,$domain,$username,$nolog) = @_;
+     unless ($nolog) {
  # log the associated role with the area
-     &userrolelog($trole,$username,$domain,$area,$tstart,$tend);
+         &userrolelog($trole,$username,$domain,$area,$tstart,$tend);
+     }
      return ('user.role.'.$trole.'.'.$area => $tstart.'.'.$tend);
  }
  sub custom_roleprivs {
      my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;
      my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
-     my $homsvr=homeserver($rauthor,$rdomain);
+     my $homsvr = &homeserver($rauthor,$rdomain);
      if (&hostname($homsvr) ne '') {
          my ($rdummy,$roledef)=
              &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);
- Line 4591  sub custom_roleprivs {
+ Line 6650  sub custom_roleprivs {
                      $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
                  }
                  if (($trest ne '') && (defined($coursepriv))) {
+                     if ($trole =~ m{^cr/$tdomain/$tdomain\Q-domainconfig\E/([^/]+)$}) {
+                         my $rolename = $1;
+                         $coursepriv = &course_adhocrole_privs($rolename,$tdomain,$trest,$coursepriv);
+                     }
                      $$allroles{'cm.'.$area}.=':'.$coursepriv;
                      $$allroles{$spec.'.'.$area}.=':'.$coursepriv;
                  }
- Line 4599  sub custom_roleprivs {
+ Line 6662  sub custom_roleprivs {
      }
  }
+ sub course_adhocrole_privs {
+     my ($rolename,$cdom,$cnum,$coursepriv) = @_;
+     my %overrides = &get('environment',["internal.adhocpriv.$rolename"],$cdom,$cnum);
+     if ($overrides{"internal.adhocpriv.$rolename"}) {
+         my (%currprivs,%storeprivs);
+         foreach my $item (split(/:/,$coursepriv)) {
+             my ($priv,$restrict) = split(/\&/,$item);
+             $currprivs{$priv} = $restrict;
+         }
+         my (%possadd,%possremove,%full);
+         foreach my $item (split(/\:/,$Apache::lonnet::pr{'cr:c'})) {
+             my ($priv,$restrict)=split(/\&/,$item);
+             $full{$priv} = $restrict;
+         }
+         foreach my $item (split(/,/,$overrides{"internal.adhocpriv.$rolename"})) {
+             next if ($item eq '');
+             my ($rule,$rest) = split(/=/,$item);
+             next unless (($rule eq 'off') || ($rule eq 'on'));
+             foreach my $priv (split(/:/,$rest)) {
+                 if ($priv ne '') {
+                     if ($rule eq 'off') {
+                         $possremove{$priv} = 1;
+                     } else {
+                         $possadd{$priv} = 1;
+                     }
+                 }
+             }
+         }
+         foreach my $priv (sort(keys(%full))) {
+             if (exists($currprivs{$priv})) {
+                 unless (exists($possremove{$priv})) {
+                     $storeprivs{$priv} = $currprivs{$priv};
+                 }
+             } elsif (exists($possadd{$priv})) {
+                 $storeprivs{$priv} = $full{$priv};
+             }
+         }
+         $coursepriv = ':'.join(':',map { $_.'&'.$storeprivs{$_}; } sort(keys(%storeprivs)));
+     }
+     return $coursepriv;
+ }
  sub group_roleprivs {
      my ($allgroups,$area,$group_privs,$tend,$tstart) = @_;
      my $access = 1;
- Line 4633  sub set_userprivs {
+ Line 6738  sub set_userprivs {
      my ($userroles,$allroles,$allgroups,$groups_roles) = @_;
      my $author=0;
      my $adv=0;
+     my $rar=0;
      my %grouproles = ();
      if (keys(%{$allgroups}) > 0) {
          my @groupkeys;
- Line 4680  sub set_userprivs {
+ Line 6786  sub set_userprivs {
                      $thesepriv{$privilege}.=$restrictions;
                  }
                  if ($thesepriv{'adv'} eq 'F') { $adv=1; }
+                 if ($thesepriv{'rar'} eq 'F') { $rar=1; }
              }
          }
          my $thesestr='';
- Line 4688  sub set_userprivs {
+ Line 6795  sub set_userprivs {
  	}
          $userroles->{'user.priv.'.$role} = $thesestr;
      }
-     return ($author,$adv);
+     return ($author,$adv,$rar);
  }
  sub role_status {
      my ($rolekey,$update,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;
-     my @pwhere = ();
      if (exists($env{$rolekey}) && $env{$rolekey} ne '') {
-         (undef,undef,$$role,@pwhere)=split(/\./,$rolekey);
+         my ($one,$two) = split(m{\./},$rolekey,2);
+         (undef,undef,$$role) = split(/\./,$one,3);
          unless (!defined($$role) || $$role eq '') {
-             $$where=join('.',@pwhere);
+             $$where = '/'.$two;
              $$trolecode=$$role.'.'.$$where;
              ($$tstart,$$tend)=split(/\./,$env{$rolekey});
              $$tstatus='is';
- Line 4733  sub role_status {
+ Line 6840  sub role_status {
                                  push(@rolecodes,$$role);
                                  &standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where);
                              }
-                             my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups,\%groups_roles);
+                             my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%allroles,\%allgroups,
+                                                                    \%groups_roles);
                              &appenv(\%userroles,\@rolecodes);
-                             &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);
+                             &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec);
                          }
                      }
                      $$tstatus = 'is';
- Line 4811  sub delete_env_groupprivs {
+ Line 6919  sub delete_env_groupprivs {
  }
  sub check_adhoc_privs {
-     my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller) = @_;
+     my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller,$sec) = @_;
      my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;
+     if ($sec) {
+         $cckey .= '/'.$sec;
+     }
+     my $setprivs;
      if ($env{$cckey}) {
          my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);
          &role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);
          unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) {
-             &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);
+             &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller,$sec);
+             $setprivs = 1;
          }
      } else {
-         &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);
+         &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller,$sec);
+         $setprivs = 1;
      }
+     return $setprivs;
  }
  sub set_adhoc_privileges {
- # role can be cc or ca
+ # role can be cc, ca, or cr/<dom>/<dom>-domainconfig/role
-     my ($dcdom,$pickedcourse,$role,$caller) = @_;
+     my ($dcdom,$pickedcourse,$role,$caller,$sec) = @_;
      my $area = '/'.$dcdom.'/'.$pickedcourse;
+     if ($sec ne '') {
+         $area .= '/'.$sec;
+     }
      my $spec = $role.'.'.$area;
      my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'},
-                                   $env{'user.name'});
+                                   $env{'user.name'},1);
-     my %ccrole = ();
+     my %rolehash = ();
-     &standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area);
+     if ($role =~ m{^\Qcr/$dcdom/$dcdom\E\-domainconfig/(\w+)$}) {
-     my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole);
+         my $rolename = $1;
+         &custom_roleprivs(\%rolehash,$role,$dcdom,$pickedcourse,$spec,$area);
+         my %domdef = &get_domain_defaults($dcdom);
+         if (ref($domdef{'adhocroles'}) eq 'HASH') {
+             if (ref($domdef{'adhocroles'}{$rolename}) eq 'HASH') {
+                 &appenv({'request.role.desc' => $domdef{'adhocroles'}{$rolename}{'desc'},});
+             }
+         }
+     } else {
+         &standard_roleprivs(\%rolehash,$role,$dcdom,$spec,$pickedcourse,$area);
+     }
+     my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%rolehash);
      &appenv(\%userroles,[$role,'cm']);
-     &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);
+     &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec);
-     unless ($caller eq 'constructaccess' && $env{'request.course.id'}) {
+     unless (($caller eq 'constructaccess' && $env{'request.course.id'}) ||
+             ($caller eq 'tiny')) {
          &appenv( {'request.role'        => $spec,
                    'request.role.domain' => $dcdom,
-                   'request.course.sec'  => ''
+                   'request.course.sec'  => $sec,
                   }
                 );
          my $tadv=0;
- Line 4893  sub del {
+ Line 7023  sub del {
  # -------------------------------------------------------------- dump interface
+ sub unserialize {
+     my ($rep, $escapedkeys) = @_;
+     return {} if $rep =~ /^error/;
+     my %returnhash=();
+     foreach my $item (split(/\&/,$rep)) {
+         my ($key, $value) = split(/=/, $item, 2);
+         $key = unescape($key) unless $escapedkeys;
+         next if $key =~ /^error: 2 /;
+         $returnhash{$key} = &thaw_unescape($value);
+     }
+     return \%returnhash;
+ }
+ # see Lond::dump_with_regexp
+ # if $escapedkeys hash keys won't get unescaped.
  sub dump {
-     my ($namespace,$udomain,$uname,$regexp,$range,$extra)=@_;
+     my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys,$encrypt)=@_;
      if (!$udomain) { $udomain=$env{'user.domain'}; }
      if (!$uname) { $uname=$env{'user.name'}; }
      my $uhome=&homeserver($uname,$udomain);
      if ($regexp) {
- 	$regexp=&escape($regexp);
+         $regexp=&escape($regexp);
+     } else {
+         $regexp='.';
+     }
+     if (grep { $_ eq $uhome } &current_machine_ids()) {
+         # user is hosted on this machine
+         my $reply = LONCAPA::Lond::dump_with_regexp(join(':', ($udomain,
+                     $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});
+         return %{&unserialize($reply, $escapedkeys)};
+     }
+     my $rep;
+     if ($encrypt) {
+         $rep=&reply("encrypt:edump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
      } else {
- 	$regexp='.';
+         $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=();
      if (!($rep =~ /^error/ )) {
  	foreach my $item (@pairs) {
  	    my ($key,$value)=split(/=/,$item,2);
- 	    $key = &unescape($key);
+             $key = &unescape($key) unless ($escapedkeys);
  	    next if ($key =~ /^error: 2 /);
  	    $returnhash{$key}=&thaw_unescape($value);
  	}
- Line 4922  sub dump {
+ Line 7081  sub dump {
  sub dumpstore {
     my ($namespace,$udomain,$uname,$regexp,$range)=@_;
-    if (!$udomain) { $udomain=$env{'user.domain'}; }
+    # same as dump but keys must be escaped. They may contain colon separated
-    if (!$uname) { $uname=$env{'user.name'}; }
+    # lists of values that may themself contain colons (e.g. symbs).
-    my $uhome=&homeserver($uname,$udomain);
+    return &dump($namespace, $udomain, $uname, $regexp, $range, 1);
-    if ($regexp) {
-        $regexp=&escape($regexp);
-    } else {
-        $regexp='.';
-    }
-    my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
-    my @pairs=split(/\&/,$rep);
-    my %returnhash=();
-    foreach my $item (@pairs) {
-        my ($key,$value)=split(/=/,$item,2);
-        next if ($key =~ /^error: 2 /);
-        $returnhash{$key}=&thaw_unescape($value);
-    }
-    return %returnhash;
  }
  # -------------------------------------------------------------- keys interface
- Line 4964  sub currentdump {
+ Line 7109  sub currentdump {
     $sdom     = $env{'user.domain'}       if (! defined($sdom));
     $sname    = $env{'user.name'}         if (! defined($sname));
     my $uhome = &homeserver($sname,$sdom);
-    my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);
+    my $rep;
+    if (grep { $_ eq $uhome } current_machine_ids()) {
+        $rep = LONCAPA::Lond::dump_profile_database(join(":", ($sdom, $sname,
+                    $courseid)));
+    } else {
+        $rep = reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);
+    }
     return if ($rep =~ /^(error:|no_such_host)/);
     #
     my %returnhash=();
- Line 5055  sub inc {
+ Line 7208  sub inc {
  # --------------------------------------------------------------- put interface
  sub put {
-    my ($namespace,$storehash,$udomain,$uname)=@_;
+    my ($namespace,$storehash,$udomain,$uname,$encrypt)=@_;
     if (!$udomain) { $udomain=$env{'user.domain'}; }
     if (!$uname) { $uname=$env{'user.name'}; }
     my $uhome=&homeserver($uname,$udomain);
- Line 5064  sub put {
+ Line 7217  sub put {
         $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
     }
     $items=~s/\&$//;
-    return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
+    if ($encrypt) {
+        return &reply("encrypt:put:$udomain:$uname:$namespace:$items",$uhome);
+    } else {
+        return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
+    }
  }
  # ------------------------------------------------------------ newput interface
- Line 5085  sub newput {
+ Line 7242  sub newput {
  # ---------------------------------------------------------  putstore interface
  sub putstore {
-    my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;
+    my ($namespace,$symb,$version,$storehash,$udomain,$uname,$tolog)=@_;
     if (!$udomain) { $udomain=$env{'user.domain'}; }
     if (!$uname) { $uname=$env{'user.name'}; }
     my $uhome=&homeserver($uname,$udomain);
- Line 5099  sub putstore {
+ Line 7256  sub putstore {
     my $reply =
         &reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items",
  	      $uhome);
+    if (($tolog) && ($reply eq 'ok')) {
+        my $namevalue='';
+        foreach my $key (keys(%{$storehash})) {
+            $namevalue.=&escape($key).'='.&freeze_escape($storehash->{$key}).'&';
+        }
+        my $ip = &get_requestor_ip();
+        $namevalue .= 'ip='.&escape($ip).
+                      '&host='.&escape($perlvar{'lonHostID'}).
+                      '&version='.$esc_v.
+                      '&by='.&escape($env{'user.name'}.':'.$env{'user.domain'});
+        &Apache::lonnet::courselog($symb.':'.$uname.':'.$udomain.':PUTSTORE:'.$namevalue);
+    }
     if ($reply eq 'unknown_cmd') {
         # gfall back to way things use to be done
         return &old_putstore($namespace,$symb,$version,$storehash,$udomain,
- Line 5192  sub tmpget {
+ Line 7361  sub tmpget {
      if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
      my $rep=&reply("tmpget:$token",$server);
      my %returnhash;
+     if ($rep =~ /^(con_lost|error|no_such_host)/i) {
+         return %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 5207  sub tmpdel {
+ Line 7378  sub tmpdel {
      return &reply("tmpdel:$token",$server);
  }
+ # ------------------------------------------------------------ get_timebased_id
+ sub get_timebased_id {
+     my ($prefix,$keyid,$namespace,$cdom,$cnum,$idtype,$who,$locktries,
+         $maxtries) = @_;
+     my ($newid,$error,$dellock);
+     unless (($prefix =~ /^\w+$/) && ($keyid =~ /^\w+$/) && ($namespace ne '')) {
+         return ('','ok','invalid call to get suffix');
+     }
+ # set defaults for any optional args for which values were not supplied
+     if ($who eq '') {
+         $who = $env{'user.name'}.':'.$env{'user.domain'};
+     }
+     if (!$locktries) {
+         $locktries = 3;
+     }
+     if (!$maxtries) {
+         $maxtries = 10;
+     }
+     if (($cdom eq '') || ($cnum eq '')) {
+         if ($env{'request.course.id'}) {
+             $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
+             $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
+         }
+         if (($cdom eq '') || ($cnum eq '')) {
+             return ('','ok','call to get suffix not in course context');
+         }
+     }
+ # construct locking item
+     my $lockhash = {
+                       $prefix."\0".'locked_'.$keyid => $who,
+                    };
+     my $tries = 0;
+ # attempt to get lock on nohist_$namespace file
+     my $gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum);
+     while (($gotlock ne 'ok') && $tries <$locktries) {
+         $tries ++;
+         sleep 1;
+         $gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum);
+     }
+ # attempt to get unique identifier, based on current timestamp
+     if ($gotlock eq 'ok') {
+         my %inuse = &Apache::lonnet::dump('nohist_'.$namespace,$cdom,$cnum,$prefix);
+         my $id = time;
+         $newid = $id;
+         if ($idtype eq 'addcode') {
+             $newid .= &sixnum_code();
+         }
+         my $idtries = 0;
+         while (exists($inuse{$prefix."\0".$newid}) && $idtries < $maxtries) {
+             if ($idtype eq 'concat') {
+                 $newid = $id.$idtries;
+             } elsif ($idtype eq 'addcode') {
+                 $newid = $newid.&sixnum_code();
+             } else {
+                 $newid ++;
+             }
+             $idtries ++;
+         }
+         if (!exists($inuse{$prefix."\0".$newid})) {
+             my %new_item =  (
+                               $prefix."\0".$newid => $who,
+                             );
+             my $putresult = &Apache::lonnet::put('nohist_'.$namespace,\%new_item,
+                                                  $cdom,$cnum);
+             if ($putresult ne 'ok') {
+                 undef($newid);
+                 $error = 'error saving new item: '.$putresult;
+             }
+         } else {
+              undef($newid);
+              $error = ('error: no unique suffix available for the new item ');
+         }
+ #  remove lock
+         my @del_lock = ($prefix."\0".'locked_'.$keyid);
+         $dellock = &Apache::lonnet::del('nohist_'.$namespace,\@del_lock,$cdom,$cnum);
+     } else {
+         $error = "error: could not obtain lockfile\n";
+         $dellock = 'ok';
+         if (($prefix eq 'paste') && ($namespace eq 'courseeditor') && ($keyid eq 'num')) {
+             $dellock = 'nolock';
+         }
+     }
+     return ($newid,$dellock,$error);
+ }
+ sub sixnum_code {
+     my $code;
+     for (0..6) {
+         $code .= int( rand(9) );
+     }
+     return $code;
+ }
  # -------------------------------------------------- portfolio access checking
  sub portfolio_access {
-     my ($requrl) = @_;
+     my ($requrl,$clientip) = @_;
      my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);
-     my $result = &get_portfolio_access($udom,$unum,$file_name,$group);
+     my $result = &get_portfolio_access($udom,$unum,$file_name,$group,$clientip);
      if ($result) {
          my %setters;
          if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
-             my ($startblock,$endblock) =
+             my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) =
-                 &Apache::loncommon::blockcheck(\%setters,'port',$unum,$udom);
+                 &Apache::loncommon::blockcheck(\%setters,'port',$clientip,$unum,$udom);
-             if ($startblock && $endblock) {
+             if (($startblock && $endblock) || ($by_ip))  {
                  return 'B';
              }
          } else {
-             my ($startblock,$endblock) =
+             my ($startblock,$endblock,$triggerblock,$by_ip,$blockdo) =
-                 &Apache::loncommon::blockcheck(\%setters,'port');
+                 &Apache::loncommon::blockcheck(\%setters,'port',$clientip);
-             if ($startblock && $endblock) {
+             if (($startblock && $endblock) || ($by_ip)) {
                  return 'B';
              }
          }
- Line 5238  sub portfolio_access {
+ Line 7508  sub portfolio_access {
  }
  sub get_portfolio_access {
-     my ($udom,$unum,$file_name,$group,$access_hash) = @_;
+     my ($udom,$unum,$file_name,$group,$clientip,$access_hash) = @_;
      if (!ref($access_hash)) {
  	my $current_perms = &get_portfile_permissions($udom,$unum);
- Line 5247  sub get_portfolio_access {
+ Line 7517  sub get_portfolio_access {
  	$access_hash = $access_controls{$file_name};
      }
-     my ($public,$guest,@domains,@users,@courses,@groups);
+     my ($public,$guest,@domains,@users,@courses,@groups,@ips);
      my $now = time;
      if (ref($access_hash) eq 'HASH') {
          foreach my $key (keys(%{$access_hash})) {
- Line 5271  sub get_portfolio_access {
+ Line 7541  sub get_portfolio_access {
                  push(@courses,$key);
              } elsif ($scope eq 'group') {
                  push(@groups,$key);
+             } elsif ($scope eq 'ip') {
+                 push(@ips,$key);
              }
          }
          if ($public) {
              return 'ok';
+         } elsif (@ips > 0) {
+             my $allowed;
+             foreach my $ipkey (@ips) {
+                 if (ref($access_hash->{$ipkey}{'ip'}) eq 'ARRAY') {
+                     if (&Apache::loncommon::check_ip_acc(join(',',@{$access_hash->{$ipkey}{'ip'}}),$clientip)) {
+                         $allowed = 1;
+                         last;
+                     }
+                 }
+             }
+             if ($allowed) {
+                 return 'ok';
+             }
          }
          if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
              if ($guest) {
- Line 5461  sub usertools_access {
+ Line 7746  sub usertools_access {
                        official   => 1,
                        unofficial => 1,
                        community  => 1,
+                       textbook   => 1,
+                  );
+     } elsif ($context eq 'requestauthor') {
+         %tools = (
+                       requestauthor => 1,
                   );
      } else {
          %tools = (
                        aboutme   => 1,
                        blog      => 1,
+                       webdav    => 1,
                        portfolio => 1,
+                       timezone  => 1,
                   );
      }
      return if (!defined($tools{$tool}));
-     if ((!defined($udom)) || (!defined($uname))) {
+     if (($udom eq '') || ($uname eq '')) {
          $udom = $env{'user.domain'};
          $uname = $env{'user.name'};
      }
- Line 5480  sub usertools_access {
+ Line 7772  sub usertools_access {
          if ($action ne 'reload') {
              if ($context eq 'requestcourses') {
                  return $env{'environment.canrequest.'.$tool};
+             } elsif ($context eq 'requestauthor') {
+                 return $env{'environment.canrequest.author'};
              } else {
                  return $env{'environment.availabletools.'.$tool};
              }
          }
      }
-     my ($toolstatus,$inststatus);
+     my ($toolstatus,$inststatus,$envkey);
+     if ($context eq 'requestauthor') {
+         $envkey = $context;
+     } else {
+         $envkey = $context.'.'.$tool;
+     }
      if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&
           ($action ne 'reload')) {
-         $toolstatus = $env{'environment.'.$context.'.'.$tool};
+         $toolstatus = $env{'environment.'.$envkey};
          $inststatus = $env{'environment.inststatus'};
      } else {
          if (ref($userenvref) eq 'HASH') {
-             $toolstatus = $userenvref->{$context.'.'.$tool};
+             $toolstatus = $userenvref->{$envkey};
              $inststatus = $userenvref->{'inststatus'};
          } else {
-             my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus');
+             my %userenv = &userenvironment($udom,$uname,$envkey,'inststatus');
-             $toolstatus = $userenv{$context.'.'.$tool};
+             $toolstatus = $userenv{$envkey};
              $inststatus = $userenv{'inststatus'};
          }
      }
- Line 5564  sub usertools_access {
+ Line 7863  sub usertools_access {
              }
          }
      } else {
-         if ($context eq 'tools') {
+         if (($context eq 'tools') && ($tool ne 'webdav')) {
              $access = 1;
          } else {
              $access = 0;
- Line 5745  sub customaccess {
+ Line 8044  sub customaccess {
  # ------------------------------------------------- Check for a user privilege
  sub allowed {
-     my ($priv,$uri,$symb,$role)=@_;
+     my ($priv,$uri,$symb,$role,$clientip,$noblockcheck,$ignorecache,$nodeeplinkcheck,$nodeeplinkout)=@_;
      my $ver_orguri=$uri;
      $uri=&deversion($uri);
      my $orguri=$uri;
      $uri=&declutter($uri);
      if ($priv eq 'evb') {
- # Evade communication block restrictions for specified role in a course
+ # Evade communication block restrictions for specified role in a course or domain
          if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) {
              return $1;
          } else {
- Line 5762  sub allowed {
+ Line 8061  sub allowed {
      if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
  # Free bre access to adm and meta resources
-     if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$}))
+     if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|viewclasslist|aboutme|ext\.tool)$}))
  	 || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) ))
  	&& ($priv eq 'bre')) {
  	return 'F';
- Line 5773  sub allowed {
+ Line 8072  sub allowed {
      if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) &&
  	($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {
          my %setters;
-         my ($startblock,$endblock) =
+         my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) =
-             &Apache::loncommon::blockcheck(\%setters,'port');
+             &Apache::loncommon::blockcheck(\%setters,'port',$clientip);
-         if ($startblock && $endblock) {
+         if (($startblock && $endblock) || ($by_ip)) {
              return 'B';
          } else {
              return 'F';
- Line 5810  sub allowed {
+ Line 8109  sub allowed {
  # Free bre to public access
      if ($priv eq 'bre') {
-         my $copyright=&metadata($uri,'copyright');
+         my $copyright;
+         unless ($uri =~ /ext\.tool/) {
+             $copyright=&metadata($uri,'copyright');
+         }
  	if (($copyright eq 'public') && (!$env{'request.course.id'})) {
             return 'F';
          }
- Line 5868  sub allowed {
+ Line 8170  sub allowed {
                          my $adom = $1;
                          foreach my $key (keys(%env)) {
                              if ($key =~ m{^user\.role\.(ca|aa)/\Q$adom\E}) {
-                                 my ($start,$end) = split('.',$env{$key});
+                                 my ($start,$end) = split(/\./,$env{$key});
-                                 if (($now >= $start) && (!$end || $end < $now)) {
+                                 if (($now >= $start) && (!$end || $end > $now)) {
                                      $ownaccess = 1;
                                      last;
                                  }
- Line 5881  sub allowed {
+ Line 8183  sub allowed {
                          foreach my $role ('ca','aa') {
                              if ($env{"user.role.$role./$adom/$aname"}) {
                                  my ($start,$end) =
-                                     split('.',$env{"user.role.$role./$adom/$aname"});
+                                     split(/\./,$env{"user.role.$role./$adom/$aname"});
-                                 if (($now >= $start) && (!$end || $end < $now)) {
+                                 if (($now >= $start) && (!$end || $end > $now)) {
                                      $ownaccess = 1;
                                      last;
                                  }
- Line 5927  sub allowed {
+ Line 8229  sub allowed {
      if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri}
         =~/\Q$priv\E\&([^\:]*)/) {
-         unless (($priv eq 'bro') && (!$ownaccess)) {
+         if ($priv eq 'mip') {
-             $thisallowed.=$1;
+             my $rem = $1;
+             if (($uri ne '') && ($env{'request.course.id'} eq $uri) &&
+                 ($env{'course.'.$env{'request.course.id'}.'.internal.courseowner'} eq $env{'user.name'}.':'.$env{'user.domain'})) {
+                 my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
+                 if ($cdom ne '') {
+                     my %passwdconf = &get_passwdconf($cdom);
+                     if (ref($passwdconf{'crsownerchg'}) eq 'HASH') {
+                         if (ref($passwdconf{'crsownerchg'}{'by'}) eq 'ARRAY') {
+                             if (@{$passwdconf{'crsownerchg'}{'by'}}) {
+                                 my @inststatuses = split(':',$env{'environment.inststatus'});
+                                 unless (@inststatuses) {
+                                     @inststatuses = ('default');
+                                 }
+                                 foreach my $status (@inststatuses) {
+                                     if (grep(/^\Q$status\E$/,@{$passwdconf{'crsownerchg'}{'by'}})) {
+                                         $thisallowed.=$rem;
+                                     }
+                                 }
+                             }
+                         }
+                     }
+                 }
+             }
+         } else {
+             unless (($priv eq 'bro') && (!$ownaccess)) {
+                 $thisallowed.=$1;
+             }
          }
      }
- Line 5940  sub allowed {
+ Line 8268  sub allowed {
          if ($match) {
              if ($env{'user.priv.'.$env{'request.role'}.'./'}
                    =~/\Q$priv\E\&([^\:]*)/) {
-                 $thisallowed.=$1;
+                 my $value = $1;
+                 my $deeplinkblock;
+                 unless ($nodeeplinkcheck) {
+                     $deeplinkblock = &deeplink_check($priv,$symb,$uri);
+                 }
+                 if ($deeplinkblock) {
+                     $thisallowed='D';
+                 } elsif ($noblockcheck) {
+                     $thisallowed.=$value;
+                 } else {
+                     my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);
+                     if (@blockers > 0) {
+                         $thisallowed = 'B';
+                     } else {
+                         $thisallowed.=$value;
+                     }
+                 }
              }
          } else {
              my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri};
- Line 5951  sub allowed {
+ Line 8295  sub allowed {
                      $refuri=&declutter($refuri);
                      my ($match) = &is_on_map($refuri);
                      if ($match) {
-                         $thisallowed='F';
+                         my $deeplinkblock;
+                         unless ($nodeeplinkcheck) {
+                             $deeplinkblock = &deeplink_check($priv,$symb,$refuri);
+                         }
+                         if ($deeplinkblock) {
+                             $thisallowed='D';
+                         } elsif ($noblockcheck) {
+                             $thisallowed='F';
+                         } else {
+                             my @blockers = &has_comm_blocking($priv,'',$refuri,'',1);
+                             if (@blockers > 0) {
+                                 $thisallowed = 'B';
+                             } else {
+                                 $thisallowed='F';
+                             }
+                         }
                      }
                  }
              }
- Line 5962  sub allowed {
+ Line 8321  sub allowed {
  	&& $thisallowed ne 'F'
  	&& $thisallowed ne '2'
  	&& &is_portfolio_url($uri)) {
- 	$thisallowed = &portfolio_access($uri);
+ 	$thisallowed = &portfolio_access($uri,$clientip);
      }
  # Full access at system, domain or course-wide level? Exit.
- Line 5992  sub allowed {
+ Line 8351  sub allowed {
      if ($env{'request.course.id'}) {
+ # If this is modifying password (internal auth) domains must match for user and user's role.
+         if ($priv eq 'mip') {
+             if ($env{'user.domain'} eq $env{'request.role.domain'}) {
+                 return $thisallowed;
+             } else {
+                 return '';
+             }
+         }
         $courseprivid=$env{'request.course.id'};
         if ($env{'request.course.sec'}) {
            $courseprivid.='/'.$env{'request.course.sec'};
- Line 6003  sub allowed {
+ Line 8372  sub allowed {
             $statecond=$cond;
             if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}
                 =~/\Q$priv\E\&([^\:]*)/) {
-                $thisallowed.=$1;
+                my $value = $1;
+                if ($priv eq 'bre') {
+                    my $deeplinkblock;
+                    unless ($nodeeplinkcheck) {
+                        $deeplinkblock = &deeplink_check($priv,$symb,$uri);
+                    }
+                    if ($deeplinkblock) {
+                        $thisallowed = 'D';
+                    } elsif ($noblockcheck) {
+                        $thisallowed.=$value;
+                    } else {
+                        my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);
+                        if (@blockers > 0) {
+                            $thisallowed = 'B';
+                        } else {
+                            $thisallowed.=$value;
+                        }
+                    }
+                } else {
+                    $thisallowed.=$value;
+                }
                 $checkreferer=0;
             }
         }
         if ($checkreferer) {
  	  my $refuri=$env{'httpref.'.$orguri};
              unless ($refuri) {
- Line 6031  sub allowed {
+ Line 8420  sub allowed {
                my $refstatecond=$cond;
                if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}
                    =~/\Q$priv\E\&([^\:]*)/) {
-                   $thisallowed.=$1;
+                   my $value = $1;
+                   if ($priv eq 'bre') {
+                       my $deeplinkblock;
+                       unless ($nodeeplinkcheck) {
+                           $deeplinkblock = &deeplink_check($priv,$symb,$refuri);
+                       }
+                       if ($deeplinkblock) {
+                           $thisallowed = 'D';
+                       } elsif ($noblockcheck) {
+                           $thisallowed.=$value;
+                       } else {
+                           my @blockers = &has_comm_blocking($priv,'',$refuri,'',1);
+                           if (@blockers > 0) {
+                               $thisallowed = 'B';
+                           } else {
+                               $thisallowed.=$value;
+                           }
+                       }
+                   } else {
+                       $thisallowed.=$value;
+                   }
                    $uri=$refuri;
                    $statecond=$refstatecond;
                }
- Line 6064  sub allowed {
+ Line 8473  sub allowed {
  #
  # Possibly locked functionality, check all courses
+ # In roles.tab, L (unless locked) available for bre, pch, plc, pac and sma.
  # Locks might take effect only after 10 minutes cache expiration for other
- # courses, and 2 minutes for current course
+ # courses, and 2 minutes for current course, in which user has st or ta role
+ # which is neither expired nor a future role (unless current course).
-     my $envkey;
+     my ($needlockcheck,$now,$crsonly);
      if ($thisallowed=~/L/) {
-         foreach $envkey (keys(%env)) {
+         $now = time;
+         if ($priv eq 'bre') {
+             if ($uri ne '') {
+                 if ($orguri =~ m{^/+res/}) {
+                     if ($uri =~ m{^lib/templates/}) {
+                         if ($env{'request.course.id'}) {
+                             $crsonly = 1;
+                             $needlockcheck = 1;
+                         }
+                     } else {
+                         $needlockcheck = 1;
+                     }
+                 } elsif ($env{'request.course.id'}) {
+                     my ($crsdom,$crsnum) = split('_',$env{'request.course.id'});
+                     if (($uri =~ m{^(adm|uploaded|public)/$crsdom/$crsnum/}) ||
+                         ($uri =~ m{^adm/$match_domain/$match_username/\d+/(smppg|bulletinboard)$})) {
+                         $crsonly = 1;
+                     }
+                     $needlockcheck = 1;
+                 }
+             }
+         } elsif (($priv eq 'pch') || ($priv eq 'plc') || ($priv eq 'pac') || ($priv eq 'sma')) {
+             $needlockcheck = 1;
+         }
+     }
+     if ($needlockcheck) {
+         foreach my $envkey (keys(%env)) {
             if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
                 my $courseid=$2;
                 my $roleid=$1.'.'.$2;
                 $courseid=~s/^\///;
+                unless ($env{'request.role'} eq $roleid) {
+                    my ($start,$end) = split(/\./,$env{$envkey});
+                    next unless (($now >= $start) && (!$end || $end > $now));
+                }
                 my $expiretime=600;
                 if ($env{'request.role'} eq $roleid) {
  		  $expiretime=120;
- Line 6096  sub allowed {
+ Line 8537  sub allowed {
                 }
                 if (($env{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/)
                  || ($env{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {
- 		   if ($env{'priv.'.$priv.'.lock.expire'}>time) {
+ 		   if ($env{$prefix.'priv.'.$priv.'.lock.expire'}>time) {
                         &log($env{'user.domain'},$env{'user.name'},
                              $env{'user.home'},
                              'Locked by priv: '.$priv.' for '.$uri.' due to '.
- Line 6108  sub allowed {
+ Line 8549  sub allowed {
  	   }
         }
      }
  #
  # Rest of the restrictions depend on selected course
  #
- Line 6167  sub allowed {
+ Line 8608  sub allowed {
         }
     }
+ # Restricted for deeplinked session?
+     if ($env{'request.deeplink.login'}) {
+         if ($env{'acc.deeplinkout'} && !$nodeeplinkout) {
+             if (!$symb) { $symb=&symbread($uri,1); }
+             if (($symb) && ($env{'acc.deeplinkout'}=~/\&\Q$symb\E\&/)) {
+                 return '';
+             }
+         }
+     }
  # Restricted by state or randomout?
     if ($thisallowed=~/X/) {
- Line 6187  sub allowed {
+ Line 8639  sub allowed {
  	return 'A';
      } elsif ($thisallowed eq 'B') {
          return 'B';
+     } elsif ($thisallowed eq 'D') {
+         return 'D';
      }
     return 'F';
  }
+ # ------------------------------------------- Check construction space access
+ sub constructaccess {
+     my ($url,$setpriv)=@_;
+ # We do not allow editing of previous versions of files
+     if ($url=~/\.(\d+)\.(\w+)$/) { return ''; }
+ # Get username and domain from URL
+     my ($ownername,$ownerdomain,$ownerhome);
+     ($ownerdomain,$ownername) =
+         ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)/priv/($match_domain)/($match_username)(?:/|$)});
+ # The URL does not really point to any authorspace, forget it
+     unless (($ownername) && ($ownerdomain)) { return ''; }
+ # Now we need to see if the user has access to the authorspace of
+ # $ownername at $ownerdomain
+     if (($ownername eq $env{'user.name'}) && ($ownerdomain eq $env{'user.domain'})) {
+ # Real author for this?
+        $ownerhome = $env{'user.home'};
+        if (exists($env{'user.priv.au./'.$ownerdomain.'/./'})) {
+           return ($ownername,$ownerdomain,$ownerhome);
+        }
+     } else {
+ # Co-author for this?
+         if (exists($env{'user.priv.ca./'.$ownerdomain.'/'.$ownername.'./'}) ||
+             exists($env{'user.priv.aa./'.$ownerdomain.'/'.$ownername.'./'}) ) {
+             $ownerhome = &homeserver($ownername,$ownerdomain);
+             return ($ownername,$ownerdomain,$ownerhome);
+         }
+     }
+ # We don't have any access right now. If we are not possibly going to do anything about this,
+ # we might as well leave
+    unless ($setpriv) { return ''; }
+ # Backdoor access?
+     my $allowed=&allowed('eco',$ownerdomain);
+ # Nope
+     unless ($allowed) { return ''; }
+ # Looks like we may have access, but could be locked by the owner of the construction space
+     if ($allowed eq 'U') {
+         my %blocked=&get('environment',['domcoord.author'],
+                          $ownerdomain,$ownername);
+ # Is blocked by owner
+         if ($blocked{'domcoord.author'} eq 'blocked') { return ''; }
+     }
+     if (($allowed eq 'F') || ($allowed eq 'U')) {
+ # Grant temporary access
+         my $then=$env{'user.login.time'};
+         my $update=$env{'user.update.time'};
+         if (!$update) { $update = $then; }
+         my $refresh=$env{'user.refresh.time'};
+         if (!$refresh) { $refresh = $update; }
+         my $now = time;
+         &check_adhoc_privs($ownerdomain,$ownername,$update,$refresh,
+                            $now,'ca','constructaccess');
+         $ownerhome = &homeserver($ownername,$ownerdomain);
+         return($ownername,$ownerdomain,$ownerhome);
+     }
+ # No business here
+     return '';
+ }
+ # ----------------------------------------------------------- Content Blocking
+ {
+ # Caches for faster Course Contents display where content blocking
+ # is in operation (i.e., interval param set) for timed quiz.
  #
- #   Removes the versino from a URI and
+ # User for whom data are being temporarily cached.
+ my $cacheduser='';
+ # Course for which data are being temporarily cached.
+ my $cachedcid='';
+ # Cached blockers for this user (a hash of blocking items).
+ my %cachedblockers=();
+ # When the data were last cached.
+ my $cachedlast='';
+ sub load_all_blockers {
+     my ($uname,$udom)=@_;
+     if (($uname ne '') && ($udom ne '')) {
+         if (($cacheduser eq $uname.':'.$udom) &&
+             ($cachedcid eq $env{'request.course.id'}) &&
+             (abs($cachedlast-time)<5)) {
+             return;
+         }
+     }
+     $cachedlast=time;
+     $cacheduser=$uname.':'.$udom;
+     $cachedcid=$env{'request.course.id'};
+     %cachedblockers = &get_commblock_resources();
+     return;
+ }
+ sub get_comm_blocks {
+     my ($cdom,$cnum) = @_;
+     if ($cdom eq '' || $cnum eq '') {
+         return unless ($env{'request.course.id'});
+         $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
+         $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
+     }
+     my %commblocks;
+     my $hashid=$cdom.'_'.$cnum;
+     my ($blocksref,$cached)=&is_cached_new('comm_block',$hashid);
+     if ((defined($cached)) && (ref($blocksref) eq 'HASH')) {
+         %commblocks = %{$blocksref};
+     } else {
+         %commblocks = &Apache::lonnet::dump('comm_block',$cdom,$cnum);
+         my $cachetime = 600;
+         &do_cache_new('comm_block',$hashid,\%commblocks,$cachetime);
+     }
+     return %commblocks;
+ }
+ sub get_commblock_resources {
+     my ($blocks) = @_;
+     my %blockers = ();
+     return %blockers unless ($env{'request.course.id'});
+     my $courseurl = &courseid_to_courseurl($env{'request.course.id'});
+     if ($env{'request.course.sec'}) {
+         $courseurl .= '/'.$env{'request.course.sec'};
+     }
+     return %blockers if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseurl} =~/evb\&([^\:]*)/);
+     my %commblocks;
+     if (ref($blocks) eq 'HASH') {
+         %commblocks = %{$blocks};
+     } else {
+         %commblocks = &get_comm_blocks();
+     }
+     return %blockers unless (keys(%commblocks) > 0);
+     my $navmap = Apache::lonnavmaps::navmap->new();
+     return %blockers unless (ref($navmap));
+     my $now = time;
+     foreach my $block (keys(%commblocks)) {
+         if ($block =~ /^(\d+)____(\d+)$/) {
+             my ($start,$end) = ($1,$2);
+             if ($start <= $now && $end >= $now) {
+                 if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
+                     if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
+                         if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') {
+                             if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'maps'}})) {
+                                 $blockers{$block}{maps} = $commblocks{$block}{'blocks'}{'docs'}{'maps'};
+                             }
+                         }
+                         if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') {
+                             if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'resources'}})) {
+                                 $blockers{$block}{'resources'} = $commblocks{$block}{'blocks'}{'docs'}{'resources'};
+                             }
+                         }
+                     }
+                 }
+             }
+         } elsif ($block =~ /^firstaccess____(.+)$/) {
+             my $item = $1;
+             if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
+                 if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
+                     my (@interval,$mapname);
+                     my $type = 'map';
+                     if ($item eq 'course') {
+                         $type = 'course';
+                         @interval=&EXT("resource.0.interval");
+                     } else {
+                         if ($item =~ /___\d+___/) {
+                             $type = 'resource';
+                             @interval=&EXT("resource.0.interval",$item);
+                         } else {
+                             $mapname = &deversion($item);
+                             if (ref($navmap)) {
+                                 my $timelimit = $navmap->get_mapparam(undef,$mapname,'0.interval');
+                                 @interval = ($timelimit,'map');
+                             }
+                         }
+                     }
+                     if ($interval[0] =~ /^(\d+)/) {
+                         my $timelimit = $1;
+                         my $first_access;
+                         if ($type eq 'resource') {
+                             $first_access=&get_first_access($interval[1],$item);
+                         } elsif ($type eq 'map') {
+                             $first_access=&get_first_access($interval[1],undef,$item);
+                         } else {
+                             $first_access=&get_first_access($interval[1]);
+                         }
+                         if ($first_access) {
+                             my $timesup = $first_access+$timelimit;
+                             if ($timesup > $now) {
+                                 my $activeblock;
+                                 if ($type eq 'resource') {
+                                     if (ref($navmap)) {
+                                         my $res = $navmap->getBySymb($item);
+                                         if ($res->answerable()) {
+                                             $activeblock = 1;
+                                         }
+                                     }
+                                 } elsif ($type eq 'map') {
+                                     my $mapsymb = &symbread($mapname,1);
+                                     if (($mapsymb) && (ref($navmap))) {
+                                         my $mapres = $navmap->getBySymb($mapsymb);
+                                         if (ref($mapres)) {
+                                             my $first = $mapres->map_start();
+                                             my $finish = $mapres->map_finish();
+                                             my $it = $navmap->getIterator($first,$finish,undef,0,0);
+                                             if (ref($it)) {
+                                                 my $res;
+                                                 while ($res = $it->next(undef,1)) {
+                                                     next unless (ref($res));
+                                                     my $symb = $res->symb();
+                                                     next if (($symb eq $mapsymb) || ($symb eq ''));
+                                                     @interval=&EXT("resource.0.interval",$symb);
+                                                     if ($interval[1] eq 'map') {
+                                                         if ($res->answerable()) {
+                                                             $activeblock = 1;
+                                                             last;
+                                                         }
+                                                     }
+                                                 }
+                                             }
+                                         }
+                                     }
+                                 }
+                                 if ($activeblock) {
+                                     if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') {
+                                          if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'maps'}})) {
+                                              $blockers{$block}{'maps'} = $commblocks{$block}{'blocks'}{'docs'}{'maps'};
+                                          }
+                                     }
+                                     if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') {
+                                         if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'resources'}})) {
+                                             $blockers{$block}{'resources'} = $commblocks{$block}{'blocks'}{'docs'}{'resources'};
+                                         }
+                                     }
+                                 }
+                             }
+                         }
+                     }
+                 }
+             }
+         }
+     }
+     return %blockers;
+ }
+ sub has_comm_blocking {
+     my ($priv,$symb,$uri,$ignoresymbdb,$noenccheck,$blocked,$blocks) = @_;
+     my @blockers;
+     return unless ($env{'request.course.id'});
+     return unless ($priv eq 'bre');
+     return if ($env{'request.state'} eq 'construct');
+     my $courseurl = &courseid_to_courseurl($env{'request.course.id'});
+     if ($env{'request.course.sec'}) {
+         $courseurl .= '/'.$env{'request.course.sec'};
+     }
+     return if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseurl} =~/evb\&([^\:]*)/);
+     my %blockinfo;
+     if (ref($blocks) eq 'HASH') {
+         %blockinfo = &get_commblock_resources($blocks);
+     } else {
+         &load_all_blockers($env{'user.name'},$env{'user.domain'});
+         %blockinfo = %cachedblockers;
+     }
+     return unless (keys(%blockinfo) > 0);
+     my (%possibles,@symbs);
+     if (!$symb) {
+         $symb = &symbread($uri,1,1,1,\%possibles,$ignoresymbdb,$noenccheck);
+     }
+     if ($symb) {
+         @symbs = ($symb);
+     } elsif (keys(%possibles)) {
+         @symbs = keys(%possibles);
+     }
+     my $noblock;
+     foreach my $symb (@symbs) {
+         last if ($noblock);
+         my ($map,$resid,$resurl)=&decode_symb($symb);
+         foreach my $block (keys(%blockinfo)) {
+             if ($block =~ /^firstaccess____(.+)$/) {
+                 my $item = $1;
+                 unless ($blocked) {
+                     if (($item eq $map) || ($item eq $symb)) {
+                         $noblock = 1;
+                         last;
+                     }
+                 }
+             }
+             if (ref($blockinfo{$block}) eq 'HASH') {
+                 if (ref($blockinfo{$block}{'resources'}) eq 'HASH') {
+                     if ($blockinfo{$block}{'resources'}{$symb}) {
+                         unless (grep(/^\Q$block\E$/,@blockers)) {
+                             push(@blockers,$block);
+                         }
+                     }
+                 }
+                 if (ref($blockinfo{$block}{'maps'}) eq 'HASH') {
+                     if ($blockinfo{$block}{'maps'}{$map}) {
+                         unless (grep(/^\Q$block\E$/,@blockers)) {
+                             push(@blockers,$block);
+                         }
+                     }
+                 }
+             }
+         }
+     }
+     unless ($noblock) {
+         return @blockers;
+     }
+     return;
+ }
+ }
+ sub deeplink_check {
+     my ($priv,$symb,$uri) = @_;
+     return unless ($env{'request.course.id'});
+     return unless ($priv eq 'bre');
+     return if ($env{'request.state'} eq 'construct');
+     return if ($env{'request.role.adv'});
+     my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
+     my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
+     my (%possibles,@symbs);
+     if (!$symb) {
+         $symb = &symbread($uri,1,1,1,\%possibles);
+     }
+     if ($symb) {
+         @symbs = ($symb);
+     } elsif (keys(%possibles)) {
+         @symbs = keys(%possibles);
+     }
+     my ($deeplink_symb,$allow);
+     if ($env{'request.deeplink.login'}) {
+         $deeplink_symb = &Apache::loncommon::deeplink_login_symb($cnum,$cdom);
+     }
+     foreach my $symb (@symbs) {
+         last if ($allow);
+         my $deeplink = &EXT("resource.0.deeplink",$symb);
+         if ($deeplink eq '') {
+             $allow = 1;
+         } else {
+             my ($state,$others,$listed,$scope,$protect) = split(/,/,$deeplink);
+             if ($state ne 'only') {
+                 $allow = 1;
+             } else {
+                 my $check_deeplink_entry;
+                 if ($protect ne 'none') {
+                     my ($acctype,$item) = split(/:/,$protect);
+                     if (($acctype eq 'ltic') && ($env{'user.linkprotector'})) {
+                         if (grep(/^\Q$item\Ec$/,split(/,/,$env{'user.linkprotector'}))) {
+                             $check_deeplink_entry = 1
+                         }
+                     } elsif (($acctype eq 'ltid') && ($env{'user.linkprotector'})) {
+                         if (grep(/^\Q$item\Ed$/,split(/,/,$env{'user.linkprotector'}))) {
+                             $check_deeplink_entry = 1;
+                         }
+                     } elsif (($acctype eq 'key') && ($env{'user.deeplinkkey'})) {
+                         if (grep(/^\Q$item\E$/,split(/,/,$env{'user.deeplinkkey'}))) {
+                             $check_deeplink_entry = 1;
+                         }
+                     }
+                 }
+                 if (($protect eq 'none') || ($check_deeplink_entry)) {
+                     if ($scope eq 'res') {
+                         if ($symb eq $deeplink_symb) {
+                             $allow = 1;
+                         }
+                     } elsif (($scope eq 'map') || ($scope eq 'rec')) {
+                         my ($map_from_symb,$map_from_login);
+                         $map_from_symb = &deversion((&decode_symb($symb))[0]);
+                         if ($deeplink_symb =~ /\.(page|sequence)$/) {
+                             $map_from_login = &deversion((&decode_symb($deeplink_symb))[2]);
+                         } else {
+                             $map_from_login = &deversion((&decode_symb($deeplink_symb))[0]);
+                         }
+                         if (($map_from_symb) && ($map_from_login)) {
+                             if ($map_from_symb eq $map_from_login) {
+                                 $allow = 1;
+                             } elsif ($scope eq 'rec') {
+                                 my @recurseup = &get_map_hierarchy($map_from_symb,$env{'request.course.id'});
+                                 if (grep(/^\Q$map_from_login\E$/,@recurseup)) {
+                                     $allow = 1;
+                                 }
+                             }
+                         }
+                     }
+                 }
+             }
+         }
+     }
+     return if ($allow);
+     return 1;
+ }
+ # -------------------------------- Deversion and split uri into path an filename
+ #
+ #   Removes the version from a URI and
  #   splits it in to its filename and path to the filename.
  #   Seems like File::Basename could have done this more clearly.
  #   Parameters:
- Line 6259  sub get_symb_from_alias {
+ Line 9110  sub get_symb_from_alias {
  sub definerole {
    if (allowed('mcr','/')) {
-     my ($rolename,$sysrole,$domrole,$courole)=@_;
+     my ($rolename,$sysrole,$domrole,$courole,$uname,$udom)=@_;
      foreach my $role (split(':',$sysrole)) {
  	my ($crole,$cqual)=split(/\&/,$role);
          if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; }
- Line 6287  sub definerole {
+ Line 9138  sub definerole {
              }
          }
      }
+     my $uhome;
+     if (($uname ne '') && ($udom ne '')) {
+         $uhome = &homeserver($uname,$udom);
+         return $uhome if ($uhome eq 'no_host');
+     } else {
+         $uname = $env{'user.name'};
+         $udom = $env{'user.domain'};
+         $uhome = $env{'user.home'};
+     }
      my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:".
-                 "$env{'user.domain'}:$env{'user.name'}:".
+                 "$udom:$uname:rolesdef_$rolename=".
- 	        "rolesdef_$rolename=".
                  escape($sysrole.'_'.$domrole.'_'.$courole);
-     return reply($command,$env{'user.home'});
+     return reply($command,$uhome);
    } else {
      return 'refused';
    }
- Line 6300  sub definerole {
+ Line 9159  sub definerole {
  # ---------------- Make a metadata query against the network of library servers
  sub metadata_query {
-     my ($query,$custom,$customshow,$server_array)=@_;
+     my ($query,$custom,$customshow,$server_array,$domains_hash)=@_;
      my %rhash;
      my %libserv = &all_library();
      my @server_list = (defined($server_array) ? @$server_array
                                                : keys(%libserv) );
      for my $server (@server_list) {
+         my $domains = '';
+         if (ref($domains_hash) eq 'HASH') {
+             $domains = $domains_hash->{$server};
+         }
  	unless ($custom or $customshow) {
- 	    my $reply=&reply("querysend:".&escape($query),$server);
+ 	    my $reply=&reply("querysend:".&escape($query).':::'.&escape($domains),$server);
  	    $rhash{$server}=$reply;
  	}
  	else {
  	    my $reply=&reply("querysend:".&escape($query).':'.
- 			     &escape($custom).':'.&escape($customshow),
+ 			     &escape($custom).':'.&escape($customshow).':'.&escape($domains),
  			     $server);
  	    $rhash{$server}=$reply;
  	}
- Line 6369  sub update_allusers_table {
+ Line 9232  sub update_allusers_table {
  sub fetch_enrollment_query {
      my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;
-     my $homeserver;
+     my ($homeserver,$sleep,$loopmax);
      my $maxtries = 1;
      if ($context eq 'automated') {
          $homeserver = $perlvar{'lonHostID'};
+         $sleep = 2;
+         $loopmax = 100;
          $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout
      } else {
          $homeserver = &homeserver($cnum,$dom);
- Line 6390  sub fetch_enrollment_query {
+ Line 9255  sub fetch_enrollment_query {
          &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum);
          return 'error: '.$queryid;
      }
-     my $reply = &get_query_reply($queryid);
+     my $reply = &get_query_reply($queryid,$sleep,$loopmax);
      my $tries = 1;
      while (($reply=~/^timeout/) && ($tries < $maxtries)) {
-         $reply = &get_query_reply($queryid);
+         $reply = &get_query_reply($queryid,$sleep,$loopmax);
          $tries ++;
      }
      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);
-         if ($homeserver eq $perlvar{'lonHostID'}) {
+         if (grep { $_ eq $homeserver } &current_machine_ids()) {
              foreach my $line (@responses) {
                  my ($key,$value) = split(/=/,$line,2);
                  $$replyref{$key} = $value;
- Line 6418  sub fetch_enrollment_query {
+ Line 9283  sub fetch_enrollment_query {
                          if ($xml_classlist =~ /^error/) {
                              &logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum);
                          } else {
-                             if ( open(FILE,">$destname") ) {
+                             if ( open(FILE,">",$destname) ) {
                                  print FILE &unescape($xml_classlist);
                                  close(FILE);
                              } else {
- Line 6435  sub fetch_enrollment_query {
+ Line 9300  sub fetch_enrollment_query {
  }
  sub get_query_reply {
-     my $queryid=shift;
+     my ($queryid,$sleep,$loopmax) = @_;
+     if (($sleep eq '') || ($sleep !~ /^\d+\.?\d*$/)) {
+         $sleep = 0.2;
+     }
+     if (($loopmax eq '') || ($loopmax =~ /\D/)) {
+         $loopmax = 100;
+     }
      my $replyfile=LONCAPA::tempdir().$queryid;
      my $reply='';
-     for (1..100) {
+     for (1..$loopmax) {
- 	sleep 2;
+ 	sleep($sleep);
          if (-e $replyfile.'.end') {
- 	    if (open(my $fh,$replyfile)) {
+ 	    if (open(my $fh,"<",$replyfile)) {
  		$reply = join('',<$fh>);
  		close($fh);
  	   } else { return 'error: reply_file_error'; }
- Line 6558  sub auto_validate_instcode {
+ Line 9429  sub auto_validate_instcode {
      }
      $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.
                          &escape($instcode).':'.&escape($owner),$homeserver));
-     my ($outcome,$description) = map { &unescape($_); } split('&',$response,2);
+     my ($outcome,$description,$defaultcredits) = map { &unescape($_); } split('&',$response,3);
-     return ($outcome,$description);
+     return ($outcome,$description,$defaultcredits);
+ }
+ sub auto_validate_inst_crosslist {
+     my ($cnum,$cdom,$instcode,$inst_xlist,$coowner) = @_;
+     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');
+         }
+     }
+     unless (($homeserver eq '') || ($homeserver eq 'no_host')) {
+         $response=&reply('autovalidateinstcrosslist:'.$cdom.':'.
+                          &escape($instcode).':'.&escape($inst_xlist).':'.
+                          &escape($coowner),$homeserver);
+     }
+     return $response;
  }
  sub auto_create_password {
- Line 6801  sub auto_courserequest_checks {
+ Line 9691  sub auto_courserequest_checks {
  }
  sub auto_courserequest_validation {
-     my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist) = @_;
+     my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist,$custominfo) = @_;
      my ($homeserver,$response);
      if ($dom =~ /^$match_domain$/) {
          $homeserver = &domain($dom,'primary');
      }
      unless ($homeserver eq 'no_host') {
+         my $customdata;
+         if (ref($custominfo) eq 'HASH') {
+             $customdata = &freeze_escape($custominfo);
+         }
          $response=&unescape(&reply('autocrsreqvalidation:'.$dom.':'.&escape($owner).
                                      ':'.&escape($crstype).':'.&escape($inststatuslist).
-                                     ':'.&escape($instcode).':'.&escape($instseclist),
+                                     ':'.&escape($instcode).':'.&escape($instseclist).':'.
-                                     $homeserver));
+                                     $customdata,$homeserver));
      }
      return $response;
  }
- Line 6830  sub auto_validate_class_sec {
+ Line 9723  sub auto_validate_class_sec {
      return $response;
  }
+ sub auto_instsec_reformat {
+     my ($cdom,$action,$instsecref) = @_;
+     return unless(($action eq 'clutter') || ($action eq 'declutter'));
+     my @homeservers;
+     if (defined(&domain($cdom,'primary'))) {
+         push(@homeservers,&domain($cdom,'primary'));
+     } else {
+         my %servers = &get_servers($cdom,'library');
+         foreach my $tryserver (keys(%servers)) {
+             if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
+                 push(@homeservers,$tryserver);
+             }
+         }
+     }
+     my $response;
+     my %reformatted = %{$instsecref};
+     foreach my $server (@homeservers) {
+         if (ref($instsecref) eq 'HASH') {
+             my $info = &freeze_escape($instsecref);
+             my $response=&reply('autoinstsecreformat:'.$cdom.':'.
+                                 $action.':'.$info,$server);
+             next if ($response =~ /(con_lost|error|no_such_host|refused|unknown_command)/);
+             my @items = split(/&/,$response);
+             foreach my $item (@items) {
+                 my ($key,$value) = split(/=/,$item);
+                 $reformatted{&unescape($key)} = &thaw_unescape($value);
+             }
+         }
+     }
+     return %reformatted;
+ }
+ sub auto_validate_instclasses {
+     my ($cdom,$cnum,$owners,$classesref) = @_;
+     my ($homeserver,%validations);
+     $homeserver = &homeserver($cnum,$cdom);
+     unless ($homeserver eq 'no_host') {
+         my $ownerlist;
+         if (ref($owners) eq 'ARRAY') {
+             $ownerlist = join(',',@{$owners});
+         } else {
+             $ownerlist = $owners;
+         }
+         if (ref($classesref) eq 'HASH') {
+             my $classes = &freeze_escape($classesref);
+             my $response=&reply('autovalidateinstclasses:'.&escape($ownerlist).
+                                 ':'.$cdom.':'.$classes,$homeserver);
+             unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
+                 my @items = split(/&/,$response);
+                 foreach my $item (@items) {
+                     my ($key,$value) = split('=',$item);
+                     $validations{&unescape($key)} = &thaw_unescape($value);
+                 }
+             }
+         }
+     }
+     return %validations;
+ }
+ sub auto_crsreq_update {
+     my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title,
+         $code,$accessstart,$accessend,$inbound) = @_;
+     my ($homeserver,%crsreqresponse);
+     if ($cdom =~ /^$match_domain$/) {
+         $homeserver = &domain($cdom,'primary');
+     }
+     unless (($homeserver eq 'no_host') || ($homeserver eq '')) {
+         my $info;
+         if (ref($inbound) eq 'HASH') {
+             $info = &freeze_escape($inbound);
+         }
+         my $response=&reply('autocrsrequpdate:'.$cdom.':'.$cnum.':'.&escape($crstype).
+                             ':'.&escape($action).':'.&escape($ownername).':'.
+                             &escape($ownerdomain).':'.&escape($fullname).':'.
+                             &escape($title).':'.&escape($code).':'.
+                             &escape($accessstart).':'.&escape($accessend).':'.$info,$homeserver);
+         unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
+             my @items = split(/&/,$response);
+             foreach my $item (@items) {
+                 my ($key,$value) = split('=',$item);
+                 $crsreqresponse{&unescape($key)} = &thaw_unescape($value);
+             }
+         }
+     }
+     return \%crsreqresponse;
+ }
+ sub auto_export_grades {
+     my ($cdom,$cnum,$inforef,$gradesref) = @_;
+     my ($homeserver,%exportresponse);
+     if ($cdom =~ /^$match_domain$/) {
+         $homeserver = &domain($cdom,'primary');
+     }
+     unless (($homeserver eq 'no_host') || ($homeserver eq '')) {
+         my $info;
+         if (ref($inforef) eq 'HASH') {
+             $info = &freeze_escape($inforef);
+         }
+         if (ref($gradesref) eq 'HASH') {
+             my $grades = &freeze_escape($gradesref);
+             my $response=&reply('encrypt:autoexportgrades:'.$cdom.':'.$cnum.':'.
+                                 $info.':'.$grades,$homeserver);
+             unless ($response =~ /(con_lost|error|no_such_host|refused|unknown_command)/) {
+                 my @items = split(/&/,$response);
+                 foreach my $item (@items) {
+                     my ($key,$value) = split('=',$item);
+                     $exportresponse{&unescape($key)} = &thaw_unescape($value);
+                 }
+             }
+         }
+     }
+     return \%exportresponse;
+ }
+ sub check_instcode_cloning {
+     my ($codedefaults,$code_order,$cloner,$clonefromcode,$clonetocode) = @_;
+     unless ((ref($codedefaults) eq 'HASH') && (ref($code_order) eq 'ARRAY')) {
+         return;
+     }
+     my $canclone;
+     if (@{$code_order} > 0) {
+         my $instcoderegexp ='^';
+         my @clonecodes = split(/\&/,$cloner);
+         foreach my $item (@{$code_order}) {
+             if (grep(/^\Q$item\E=/,@clonecodes)) {
+                 foreach my $pair (@clonecodes) {
+                     my ($key,$val) = split(/\=/,$pair,2);
+                     $val = &unescape($val);
+                     if ($key eq $item) {
+                         $instcoderegexp .= '('.$val.')';
+                         last;
+                     }
+                 }
+             } else {
+                 $instcoderegexp .= $codedefaults->{$item};
+             }
+         }
+         $instcoderegexp .= '$';
+         my (@from,@to);
+         eval {
+                (@from) = ($clonefromcode =~ /$instcoderegexp/);
+                (@to) = ($clonetocode =~ /$instcoderegexp/);
+         };
+         if ((@from > 0) && (@to > 0)) {
+             my @diffs = &Apache::loncommon::compare_arrays(\@from,\@to);
+             if (!@diffs) {
+                 $canclone = 1;
+             }
+         }
+     }
+     return $canclone;
+ }
+ sub default_instcode_cloning {
+     my ($clonedom,$domdefclone,$clonefromcode,$clonetocode,$codedefaultsref,$codeorderref) = @_;
+     my (%codedefaults,@code_order,$canclone);
+     if ((ref($codedefaultsref) eq 'HASH') && (ref($codeorderref) eq 'ARRAY')) {
+         %codedefaults = %{$codedefaultsref};
+         @code_order = @{$codeorderref};
+     } elsif ($clonedom) {
+         &auto_instcode_defaults($clonedom,\%codedefaults,\@code_order);
+     }
+     if (($domdefclone) && (@code_order)) {
+         my @clonecodes = split(/\+/,$domdefclone);
+         my $instcoderegexp ='^';
+         foreach my $item (@code_order) {
+             if (grep(/^\Q$item\E$/,@clonecodes)) {
+                 $instcoderegexp .= '('.$codedefaults{$item}.')';
+             } else {
+                 $instcoderegexp .= $codedefaults{$item};
+             }
+         }
+         $instcoderegexp .= '$';
+         my (@from,@to);
+         eval {
+             (@from) = ($clonefromcode =~ /$instcoderegexp/);
+             (@to) = ($clonetocode =~ /$instcoderegexp/);
+         };
+         if ((@from > 0) && (@to > 0)) {
+             my @diffs = &Apache::loncommon::compare_arrays(\@from,\@to);
+             if (!@diffs) {
+                 $canclone = 1;
+             }
+         }
+     }
+     return $canclone;
+ }
  # ------------------------------------------------------- Course Group routines
  sub get_coursegroups {
- Line 6925  sub get_users_groups {
+ Line 10006  sub get_users_groups {
      } else {
          $grouplist = '';
          my $courseurl = &courseid_to_courseurl($courseid);
-         my $extra = &freeze_escape({'skipcheck' => 1});
+         my %roleshash = &dump('roles',$udom,$uname,$courseurl);
-         my %roleshash = &dump('roles',$udom,$uname,$courseurl,undef,$extra);
          my $access_end = $env{'course.'.$courseid.
                                '.default_enrollment_end_date'};
          my $now = time;
- Line 7098  sub assignrole {
+ Line 10178  sub assignrole {
                              }
                          }
                      }
+                 } elsif ($context eq 'requestauthor') {
+                     if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&
+                         ($url eq '/'.$udom.'/') && ($role eq 'au')) {
+                         if ($env{'environment.requestauthor'} eq 'automatic') {
+                             $refused = '';
+                         } else {
+                             my %domdefaults = &get_domain_defaults($udom);
+                             if (ref($domdefaults{'requestauthor'}) eq 'HASH') {
+                                 my $checkbystatus;
+                                 if ($env{'user.adv'}) {
+                                     my $disposition = $domdefaults{'requestauthor'}{'_LC_adv'};
+                                     if ($disposition eq 'automatic') {
+                                         $refused = '';
+                                     } elsif ($disposition eq '') {
+                                         $checkbystatus = 1;
+                                     }
+                                 } else {
+                                     $checkbystatus = 1;
+                                 }
+                                 if ($checkbystatus) {
+                                     if ($env{'environment.inststatus'}) {
+                                         my @inststatuses = split(/,/,$env{'environment.inststatus'});
+                                         foreach my $type (@inststatuses) {
+                                             if (($type ne '') &&
+                                                 ($domdefaults{'requestauthor'}{$type} eq 'automatic')) {
+                                                 $refused = '';
+                                             }
+                                         }
+                                     } elsif ($domdefaults{'requestauthor'}{'default'} eq 'automatic') {
+                                         $refused = '';
+                                     }
+                                 }
+                             }
+                         }
+                     }
                  }
                  if ($refused) {
                      &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
- Line 7147  sub assignrole {
+ Line 10262  sub assignrole {
  # log new user role if status is ok
      if ($answer eq 'ok') {
  	&userrolelog($role,$uname,$udom,$url,$start,$end);
+         if (($role eq 'cc') || ($role eq 'in') ||
+             ($role eq 'ep') || ($role eq 'ad') ||
+             ($role eq 'ta') || ($role eq 'st') ||
+             ($role=~/^cr/) || ($role eq 'gr') ||
+             ($role eq 'co')) {
  # for course roles, perform group memberships changes triggered by role change.
-         &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,$selfenroll,$context);
+             unless ($role =~ /^gr/) {
-         unless ($role =~ /^gr/) {
+                 &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
-             &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
+                                                  $origstart,$selfenroll,$context);
-                                              $origstart,$selfenroll,$context);
+             }
+             &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
+                            $selfenroll,$context);
+         } elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') ||
+                  ($role eq 'au') || ($role eq 'dc') || ($role eq 'dh') ||
+                  ($role eq 'da')) {
+             &domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
+                            $context);
+         } elsif (($role eq 'ca') || ($role eq 'aa')) {
+             &coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
+                              $context);
          }
          if ($role eq 'cc') {
              &autoupdate_coowners($url,$end,$start,$uname,$udom);
- Line 7169  sub autoupdate_coowners {
+ Line 10299  sub autoupdate_coowners {
          if ($domdesign{$cdom.'.autoassign.co-owners'}) {
              my %coursehash = &coursedescription($cdom.'_'.$cnum);
              my $instcode = $coursehash{'internal.coursecode'};
+             my $xlists = $coursehash{'internal.crosslistings'};
              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);
+                         unless ($result eq 'valid') {
+                             if ($xlists ne '') {
+                                 foreach my $xlist (split(',',$xlists)) {
+                                     my ($inst_crosslist,$lcsec) = split(':',$xlist);
+                                     $result =
+                                         &auto_validate_inst_crosslist($cnum,$cdom,$instcode,
+                                                                       $inst_crosslist,$uname.':'.$udom);
+                                     last if ($result eq 'valid');
+                                 }
+                             }
+                         }
                          if ($result eq 'valid') {
                              if ($coursehash{'internal.co-owners'}) {
                                  foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
- Line 7186  sub autoupdate_coowners {
+ Line 10328  sub autoupdate_coowners {
                              } else {
                                  push(@newcoowners,$uname.':'.$udom);
                              }
-                         } else {
+                         } elsif ($coursehash{'internal.co-owners'}) {
-                             if ($coursehash{'internal.co-owners'}) {
+                             foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
-                                 foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
+                                 unless ($coowner eq $uname.':'.$udom) {
-                                     unless ($coowner eq $uname.':'.$udom) {
+                                     push(@newcoowners,$coowner);
-                                         push(@newcoowners,$coowner);
-                                     }
-                                 }
-                                 unless (@newcoowners > 0) {
-                                     $delcoowners = 1;
-                                     $coowners = '';
                                  }
                              }
+                             unless (@newcoowners > 0) {
+                                 $delcoowners = 1;
+                                 $coowners = '';
+                             }
                          }
                          if (@newcoowners || $delcoowners) {
                              &store_coowners($cdom,$cnum,$coursehash{'home'},
- Line 7250  sub store_coowners {
+ Line 10390  sub store_coowners {
  sub modifyuserauth {
      my ($udom,$uname,$umode,$upass)=@_;
      my $uhome=&homeserver($uname,$udom);
-     unless (&allowed('mau',$udom)) { return 'refused'; }
+     my $allowed;
+     if (&allowed('mau',$udom)) {
+         $allowed = 1;
+     } elsif (($umode eq 'internal') && ($udom eq $env{'user.domain'}) &&
+              ($env{'request.course.id'}) && (&allowed('mip',$env{'request.course.id'})) &&
+              (!$env{'course.'.$env{'request.course.id'}.'.internal.nopasswdchg'})) {
+         my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
+         my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
+         if (($cdom ne '') && ($cnum ne '')) {
+             my $is_owner = &is_course_owner($cdom,$cnum);
+             if ($is_owner) {
+                 $allowed = 1;
+             }
+         }
+     }
+     unless ($allowed) { return 'refused'; }
      &logthis('Call to modify user authentication '.$udom.', '.$uname.', '.
               $umode.' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
               ' in domain '.$env{'request.role.domain'});
      my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.
  		     &escape($upass),$uhome);
+     my $ip = &get_requestor_ip();
      &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},
          'Authentication changed for '.$udom.', '.$uname.', '.$umode.
-          '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);
+          '(Remote '.$ip.'): '.$reply);
      &log($udom,,$uname,$uhome,
          'Authentication changed by '.$env{'user.domain'}.', '.
                                       $env{'user.name'}.', '.$umode.
-          '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);
+          '(Remote '.$ip.'): '.$reply);
      unless ($reply eq 'ok') {
          &logthis('Authentication mode error: '.$reply);
  	return 'error: '.$reply;
- Line 7451  sub modifyuser {
+ Line 10607  sub modifyuser {
  sub modifystudent {
      my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
          $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid,
-         $selfenroll,$context,$inststatus)=@_;
+         $selfenroll,$context,$inststatus,$credits,$instsec)=@_;
      if (!$cid) {
  	unless ($cid=$env{'request.course.id'}) {
  	    return 'not_in_class';
- Line 7463  sub modifystudent {
+ Line 10619  sub modifystudent {
           $desiredhome,$email,$inststatus);
      unless ($reply eq 'ok') { return $reply; }
      # This will cause &modify_student_enrollment to get the uid from the
-     # students environment
+     # student's environment
      $uid = undef if (!$forceid);
      $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
- 					$gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context);
+ 					$gene,$usec,$end,$start,$type,$locktype,
+                                         $cid,$selfenroll,$context,$credits,$instsec);
      return $reply;
  }
  sub modify_student_enrollment {
-     my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context) = @_;
+     my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,
+         $locktype,$cid,$selfenroll,$context,$credits,$instsec) = @_;
      my ($cdom,$cnum,$chome);
      if (!$cid) {
  	unless ($cid=$env{'request.course.id'}) {
- Line 7514  sub modify_student_enrollment {
+ Line 10672  sub modify_student_enrollment {
          $uid    = $tmp{'id'}         if (!defined($uid)    || $uid  eq '');
      }
      my $fullname = &format_name($first,$middle,$last,$gene,'lastname');
+     my $user = "$uname:$udom";
+     my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum);
      my $reply=cput('classlist',
- 		   {"$uname:$udom" =>
+ 		   {$user =>
- 			join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },
+ 			join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits,$instsec) },
  		   $cdom,$cnum);
-     unless (($reply eq 'ok') || ($reply eq 'delayed')) {
+     if (($reply eq 'ok') || ($reply eq 'delayed')) {
+         &devalidate_getsection_cache($udom,$uname,$cid);
+     } else {
  	return 'error: '.$reply;
-     } else {
- 	&devalidate_getsection_cache($udom,$uname,$cid);
      }
      # Add student role to user
      my $uurl='/'.$cid;
- Line 7529  sub modify_student_enrollment {
+ Line 10689  sub modify_student_enrollment {
      if ($usec) {
  	$uurl.='/'.$usec;
      }
-     return &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,$selfenroll,$context);
+     my $result = &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,
+                              $selfenroll,$context);
+     if ($result ne 'ok') {
+         if ($old_entry{$user} ne '') {
+             $reply = &cput('classlist',\%old_entry,$cdom,$cnum);
+         } else {
+             $reply = &del('classlist',[$user],$cdom,$cnum);
+         }
+     }
+     return $result;
  }
  sub format_name {
- Line 7574  sub writecoursepref {
+ Line 10743  sub writecoursepref {
  sub createcourse {
      my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
-         $course_owner,$crstype,$cnum,$context,$category)=@_;
+         $course_owner,$crstype,$cnum,$context,$category,$callercontext)=@_;
      $url=&declutter($url);
      my $cid='';
      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,
+             my $reload;
+             if (($callercontext eq 'auto') &&
+                ($ownerdom eq $env{'user.domain'}) && ($ownername eq $env{'user.name'})) {
+                 $reload = 'reload';
+             }
+             if (&usertools_access($ownername,$ownerdom,$category,$reload,
                                    $context)) {
                  $can_create = 1;
              }
- Line 7728  sub generate_coursenum {
+ Line 10902  sub generate_coursenum {
  }
  sub is_course {
-     my ($cdom,$cnum) = @_;
+     my ($cdom, $cnum) = scalar(@_) == 1 ?
-     my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,
+          ($_[0] =~ /^($match_domain)_($match_courseid)$/)  :  @_;
- 				undef,'.');
+     return unless (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/));
-     if (exists($courses{$cdom.'_'.$cnum})) {
+     my $uhome=&homeserver($cnum,$cdom);
-         return 1;
+     my $iscourse;
+     if (grep { $_ eq $uhome } current_machine_ids()) {
+         $iscourse = &LONCAPA::Lond::is_course($cdom,$cnum);
+     } else {
+         my $hashid = $cdom.':'.$cnum;
+         ($iscourse,my $cached) = &is_cached_new('iscourse',$hashid);
+         unless (defined($cached)) {
+             my %courses = &courseiddump($cdom, '.', 1, '.', '.',
+                                         $cnum,undef,undef,'.');
+             $iscourse = 0;
+             if (exists($courses{$cdom.'_'.$cnum})) {
+                 $iscourse = 1;
+             }
+             &do_cache_new('iscourse',$hashid,$iscourse,3600);
+         }
      }
-     return 0;
+     return unless($iscourse);
+     return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum;
  }
  sub store_userdata {
- Line 7750  sub store_userdata {
+ Line 10939  sub store_userdata {
              if (($uhome eq '') || ($uhome eq 'no_host')) {
                  $result = 'error: no_host';
              } else {
-                 $storehash->{'ip'} = $ENV{'REMOTE_ADDR'};
+                 $storehash->{'ip'} = &get_requestor_ip();
                  $storehash->{'host'} = $perlvar{'lonHostID'};
                  my $namevalue='';
- Line 7758  sub store_userdata {
+ Line 10947  sub store_userdata {
                      $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
                  }
                  $namevalue=~s/\&$//;
+                 unless ($namespace eq 'courserequests') {
+                     $datakey = &escape($datakey);
+                 }
                  $result =  &reply("store:$udom:$uname:$namespace:$datakey:".
                                    $namevalue,$uhome);
              }
- Line 7866  sub save_selected_files {
+ Line 11058  sub save_selected_files {
      my ($user, $path, @files) = @_;
      my $filename = $user."savedfiles";
      my @other_files = &files_not_in_path($user, $path);
-     open (OUT, '>'.$tmpdir.$filename);
+     open (OUT,'>',LONCAPA::tempdir().$filename);
      foreach my $file (@files) {
          print (OUT $env{'form.currentpath'}.$file."\n");
      }
- Line 7880  sub save_selected_files {
+ Line 11072  sub save_selected_files {
  sub clear_selected_files {
      my ($user) = @_;
      my $filename = $user."savedfiles";
-     open (OUT, '>'.LONCAPA::tempdir().$filename);
+     open (OUT,'>',LONCAPA::tempdir().$filename);
      print (OUT undef);
      close (OUT);
      return ("ok");
- Line 7890  sub files_in_path {
+ Line 11082  sub files_in_path {
      my ($user, $path) = @_;
      my $filename = $user."savedfiles";
      my %return_files;
-     open (IN, '<'.LONCAPA::tempdir().$filename);
+     open (IN,'<',LONCAPA::tempdir().$filename);
      while (my $line_in = <IN>) {
          chomp ($line_in);
          my @paths_and_file = split (m!/!, $line_in);
- Line 7912  sub files_not_in_path {
+ Line 11104  sub files_not_in_path {
      my $filename = $user."savedfiles";
      my @return_files;
      my $path_part;
-     open(IN, '<'.LONCAPA::.$filename);
+     open(IN, '<',LONCAPA::tempdir().$filename);
      while (my $line = <IN>) {
          #ok, I know it's clunky, but I want it to work
          my @paths_and_file = split(m|/|, $line);
- Line 8025  sub modify_access_controls {
+ Line 11217  sub modify_access_controls {
      my $tries = 0;
      my $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
-     while (($gotlock ne 'ok') && $tries <3) {
+     while (($gotlock ne 'ok') && $tries < 10) {
          $tries ++;
-         sleep 1;
+         sleep(0.1);
          $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
      }
      if ($gotlock eq 'ok') {
- Line 8320  sub dirlist {
+ Line 11512  sub dirlist {
              foreach my $user (sort(keys(%allusers))) {
                  push(@alluserslist,$user.'&user');
              }
-             return (\@alluserslist);
+             if (!%listerror) {
+                 # no errors
+                 return (\@alluserslist);
+             } elsif (scalar(keys(%servers)) == 1) {
+                 # one library server, one error
+                 my ($key) = keys(%listerror);
+                 return (\@alluserslist, $listerror{$key});
+             } elsif ( grep { $_ eq 'con_lost' } values(%listerror) ) {
+                 # con_lost indicates that we might miss data from at least one
+                 # library server
+                 return (\@alluserslist, 'con_lost');
+             } else {
+                 # multiple library servers and no con_lost -> data should be
+                 # complete.
+                 return (\@alluserslist);
+             }
          } else {
              return ([],'missing username');
          }
- Line 8537  sub get_userresdata {
+ Line 11745  sub get_userresdata {
      }
      #error 2 occurs when the .db doesn't exist
      if ($tmp!~/error: 2 /) {
- 	&logthis("<font color=\"blue\">WARNING:".
+         if ((!defined($cached)) || ($tmp ne 'con_lost')) {
- 		 " Trying to get resource data for ".
+ 	    &logthis("<font color=\"blue\">WARNING:".
- 		 $uname." at ".$udom.": ".
+ 		     " Trying to get resource data for ".
- 		 $tmp."</font>");
+ 		     $uname." at ".$udom.": ".
+ 		     $tmp."</font>");
+         }
      } elsif ($tmp=~/error: 2 /) {
  	#&EXT_cache_set($udom,$uname);
  	&do_cache_new('userres',$hashid,undef,600);
- Line 8580  sub resdata {
+ Line 11790  sub resdata {
      return undef;
  }
+ sub get_domain_lti {
+     my ($cdom,$context) = @_;
+     my ($name,$cachename,%lti);
+     if ($context eq 'consumer') {
+         $name = 'ltitools';
+     } elsif ($context eq 'provider') {
+         $name = 'lti';
+     } elsif ($context eq 'linkprot') {
+         $name = 'ltisec';
+     } else {
+         return %lti;
+     }
+     if ($context eq 'linkprot') {
+         $cachename = $context;
+     } else {
+         $cachename = $name;
+     }
+     my ($result,$cached)=&is_cached_new($cachename,$cdom);
+     if (defined($cached)) {
+         if (ref($result) eq 'HASH') {
+             %lti = %{$result};
+         }
+     } else {
+         my %domconfig = &get_dom('configuration',[$name],$cdom);
+         if (ref($domconfig{$name}) eq 'HASH') {
+             if ($context eq 'linkprot') {
+                 if (ref($domconfig{$name}{'linkprot'}) eq 'HASH') {
+                     %lti = %{$domconfig{$name}{'linkprot'}};
+                 }
+             } else {
+                 %lti = %{$domconfig{$name}};
+             }
+             if (($context eq 'consumer') && (keys(%lti))) {
+                 my %encdomconfig = &get_dom('encconfig',[$name],$cdom,undef,1);
+                 if (ref($encdomconfig{$name}) eq 'HASH') {
+                     foreach my $id (keys(%lti)) {
+                         if (ref($encdomconfig{$name}{$id}) eq 'HASH') {
+                             foreach my $item ('key','secret') {
+                                 $lti{$id}{$item} = $encdomconfig{$name}{$id}{$item};
+                             }
+                         }
+                     }
+                 }
+             }
+         }
+         my $cachetime = 24*60*60;
+         &do_cache_new($cachename,$cdom,\%lti,$cachetime);
+     }
+     return %lti;
+ }
+ sub get_course_lti {
+     my ($cnum,$cdom) = @_;
+     my $hashid=$cdom.'_'.$cnum;
+     my %courselti;
+     my ($result,$cached)=&is_cached_new('courselti',$hashid);
+     if (defined($cached)) {
+         if (ref($result) eq 'HASH') {
+             %courselti = %{$result};
+         }
+     } else {
+         %courselti = &dump('lti',$cdom,$cnum,undef,undef,undef,1);
+         my $cachetime = 24*60*60;
+         &do_cache_new('courselti',$hashid,\%courselti,$cachetime);
+     }
+     return %courselti;
+ }
+ sub courselti_itemid {
+     my ($cnum,$cdom,$url,$method,$params,$context) = @_;
+     my ($chome,$itemid);
+     $chome = &homeserver($cnum,$cdom);
+     return if ($chome eq 'no_host');
+     if (ref($params) eq 'HASH') {
+         my $items = &freeze_escape($params);
+         my $rep;
+         if (grep { $_ eq $chome } current_machine_ids()) {
+             $rep = LONCAPA::Lond::crslti_itemid($cdom,$cnum,$url,$method,$params,$perlvar{'lonVersion'});
+         } else {
+             my $escurl = &escape($url);
+             my $escmethod = &escape($method);
+             my $items = &freeze_escape($params);
+             $rep = &reply("encrypt:lti:$cdom:$cnum:$context:$escurl:$escmethod:$items",$chome);
+         }
+         unless (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') ||
+                 ($rep eq 'unknown_cmd')) {
+             $itemid = $rep;
+         }
+     }
+     return $itemid;
+ }
+ sub domainlti_itemid {
+     my ($cdom,$url,$method,$params,$context) = @_;
+     my ($primary_id,$itemid);
+     $primary_id = &domain($cdom,'primary');
+     return if ($primary_id eq '');
+     if (ref($params) eq 'HASH') {
+         my $items = &freeze_escape($params);
+         my $rep;
+         if (grep { $_ eq $primary_id } current_machine_ids()) {
+             $rep = LONCAPA::Lond::domlti_itemid($cdom,$context,$url,$method,$params,$perlvar{'lonVersion'});
+         } else {
+             my $cnum = '';
+             my $escurl = &escape($url);
+             my $escmethod = &escape($method);
+             my $items = &freeze_escape($params);
+             $rep = &reply("encrypt:lti:$cdom:$cnum:$context:$escurl:$escmethod:$items",$primary_id);
+         }
+         unless (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') ||
+                 ($rep eq 'unknown_cmd')) {
+             $itemid = $rep;
+         }
+     }
+     return $itemid;
+ }
+ sub count_supptools {
+     my ($cnum,$cdom,$ignorecache,$reload)=@_;
+     my $hashid=$cnum.':'.$cdom;
+     my ($numexttools,$cached);
+     unless ($ignorecache) {
+         ($numexttools,$cached) = &is_cached_new('supptools',$hashid);
+     }
+     unless (defined($cached)) {
+         my $chome=&homeserver($cnum,$cdom);
+         $numexttools = 0;
+         unless ($chome eq 'no_host') {
+             my ($supplemental) = &Apache::loncommon::get_supplemental($cnum,$cdom,$reload);
+             if (ref($supplemental) eq 'HASH') {
+                 if ((ref($supplemental->{'ids'}) eq 'HASH') && (ref($supplemental->{'hidden'}) eq 'HASH')) {
+                     foreach my $key (keys(%{$supplemental->{'ids'}})) {
+                         if ($key =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) {
+                             $numexttools ++;
+                         }
+                     }
+                 }
+             }
+         }
+         &do_cache_new('supptools',$hashid,$numexttools,600);
+     }
+     return $numexttools;
+ }
+ sub has_unhidden_suppfiles {
+     my ($cnum,$cdom,$ignorecache,$possdel)=@_;
+     my $hashid=$cnum.':'.$cdom;
+     my ($showsupp,$cached);
+     unless ($ignorecache) {
+         ($showsupp,$cached) = &is_cached_new('showsupp',$hashid);
+     }
+     unless (defined($cached)) {
+         my $chome=&homeserver($cnum,$cdom);
+         unless ($chome eq 'no_host') {
+             my ($supplemental) = &Apache::loncommon::get_supplemental($cnum,$cdom,$ignorecache,$possdel);
+             if (ref($supplemental) eq 'HASH') {
+                 if ((ref($supplemental->{'ids'}) eq 'HASH') && (ref($supplemental->{'hidden'}) eq 'HASH')) {
+                     foreach my $key (keys(%{$supplemental->{'ids'}})) {
+                         next if ($key =~ /\.sequence$/);
+                         if (ref($supplemental->{'ids'}->{$key}) eq 'ARRAY') {
+                             foreach my $id (@{$supplemental->{'ids'}->{$key}}) {
+                                 unless ($supplemental->{'hidden'}->{$id}) {
+                                     $showsupp = 1;
+                                     last;
+                                 }
+                             }
+                         }
+                         last if ($showsupp);
+                     }
+                 }
+             }
+         }
+         &do_cache_new('showsupp',$hashid,$showsupp,600);
+     }
+     return $showsupp;
+ }
  #
  # EXT resource caching routines
  #
+ {
+ # Cache (5 seconds) of map hierarchy for speedup of navmaps display
+ #
+ # The course for which we cache
+ my $cachedmapkey='';
+ # The cached recursive maps for this course
+ my %cachedmaps=();
+ # When this was last done
+ my $cachedmaptime='';
  sub clear_EXT_cache_status {
      &delenv('cache.EXT.');
  }
- Line 8608  sub EXT_cache_set {
+ Line 12007  sub EXT_cache_set {
  # --------------------------------------------------------- Value of a Variable
  sub EXT {
-     my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_;
+     my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid)=@_;
      unless ($varname) { return ''; }
      #get real user name/domain, courseid and symb
      my $courseid;
- Line 8640  sub EXT {
+ Line 12039  sub EXT {
  	    if ( (defined($Apache::lonhomework::parsing_a_problem)
  		  || defined($Apache::lonhomework::parsing_a_task))
  		 &&
  		 ($symbparm eq &symbread()) ) {
  		# if we are in the middle of processing the resource the
  		# get the value we are planning on committing
                  if (defined($Apache::lonhomework::results{$qualifierrest})) {
- Line 8709  sub EXT {
+ Line 12108  sub EXT {
     } elsif ($realm eq 'request') {
  # ------------------------------------------------------------- request.browser
          if ($space eq 'browser') {
- 	    if ($qualifier eq 'textremote') {
+             return $env{'browser.'.$qualifier};
- 		if (&Apache::lonlocal::mt('textual_remote_display') eq 'on') {
- 		    return 1;
- 		} else {
- 		    return 0;
- 		}
- 	    } else {
- 		return $env{'browser.'.$qualifier};
- 	    }
  # ------------------------------------------------------------ request.filename
          } else {
              return $env{'request.'.$spacequalifierrest};
- Line 8731  sub EXT {
+ Line 12122  sub EXT {
  	    if (!$symbparm) { $symbparm=&symbread(); }
  	}
- 	if ($space eq 'title') {
+         if ($qualifier eq '') {
- 	    if (!$symbparm) { $symbparm = $env{'request.filename'}; }
+ 	    if ($space eq 'title') {
- 	    return &gettitle($symbparm);
+ 	        if (!$symbparm) { $symbparm = $env{'request.filename'}; }
- 	}
+ 	        return &gettitle($symbparm);
+ 	    }
- 	if ($space eq 'map') {
+ 	    if ($space eq 'map') {
- 	    my ($map) = &decode_symb($symbparm);
+ 	        my ($map) = &decode_symb($symbparm);
- 	    return &symbread($map);
+ 	        return &symbread($map);
- 	}
- 	if ($space eq 'filename') {
- 	    if ($symbparm) {
- 		return &clutter((&decode_symb($symbparm))[2]);
  	    }
- 	    return &hreflocation('',$env{'request.filename'});
+             if ($space eq 'maptitle') {
- 	}
+                 my ($map) = &decode_symb($symbparm);
+                 return &gettitle($map);
+             }
+ 	    if ($space eq 'filename') {
+ 	        if ($symbparm) {
+ 		    return &clutter((&decode_symb($symbparm))[2]);
+ 	        }
+ 	        return &hreflocation('',$env{'request.filename'});
+ 	    }
+             if ((defined($courseid)) && ($courseid eq $env{'request.course.id'}) && $symbparm) {
+                 if ($space eq 'visibleparts') {
+                     my $navmap = Apache::lonnavmaps::navmap->new();
+                     my $item;
+                     if (ref($navmap)) {
+                         my $res = $navmap->getBySymb($symbparm);
+                         my $parts = $res->parts();
+                         if (ref($parts) eq 'ARRAY') {
+                             $item = join(',',@{$parts});
+                         }
+                         undef($navmap);
+                     }
+                     return $item;
+                 }
+             }
+         }
  	my ($section, $group, @groups);
  	my ($courselevelm,$courselevel);
- 	if ($symbparm && defined($courseid) &&
+         if (($courseid eq '') && ($cid)) {
- 	    $courseid eq $env{'request.course.id'}) {
+             $courseid = $cid;
+         }
+ 	if (($symbparm && $courseid) &&
+ 	    (($courseid eq $env{'request.course.id'}) || ($courseid eq $cid))) {
  	    #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
- Line 8880  sub EXT {
+ Line 12296  sub EXT {
  	if ($space eq 'name') {
  	    return $ENV{'SERVER_NAME'};
          }
+     } elsif ($realm eq 'client') {
+         if ($space eq 'remote_addr') {
+             return &get_requestor_ip();
+         }
      }
      return '';
  }
- Line 8913  sub check_group_parms {
+ Line 12333  sub check_group_parms {
      return $coursereply;
  }
+ sub get_map_hierarchy {
+     my ($mapname,$courseid) = @_;
+     my @recurseup = ();
+     if ($mapname) {
+         if (($cachedmapkey eq $courseid) &&
+             (abs($cachedmaptime-time)<5)) {
+             if (ref($cachedmaps{$mapname}) eq 'ARRAY') {
+                 return @{$cachedmaps{$mapname}};
+             }
+         }
+         my $navmap = Apache::lonnavmaps::navmap->new();
+         if (ref($navmap)) {
+             @recurseup = $navmap->recurseup_maps($mapname);
+             undef($navmap);
+             $cachedmaps{$mapname} = \@recurseup;
+             $cachedmaptime=time;
+             $cachedmapkey=$courseid;
+         }
+     }
+     return @recurseup;
+ }
+ }
  sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().
      my ($courseid,@groups) = @_;
      @groups = sort(@groups);
- Line 8991  sub add_prefix_and_part {
+ Line 12435  sub add_prefix_and_part {
  my %metaentry;
  my %importedpartids;
+ my %importedrespids;
  sub metadata {
      my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
      $uri=&declutter($uri);
      # if it is a non metadata possible uri return quickly
      if (($uri eq '') ||
  	(($uri =~ m|^/*adm/|) &&
- 	     ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||
+ 	     ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard|ext\.tool)$})) ||
          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {
  	return undef;
      }
-     if (($uri =~ /^priv/ || $uri=~/home\/httpd\/html\/priv/)
+     if (($uri =~ /^priv/ || $uri=~m{^home/httpd/html/priv})
  	&& &Apache::lonxml::get_state('target') =~ /^(|meta)$/) {
  	return undef;
      }
- Line 9018  sub metadata {
+ Line 12463  sub metadata {
      }
      {
  # Imported parts would go here
-         my %importedids=();
+         my @origfiletagids=();
-         my @origfileimportpartids=();
          my $importedparts=0;
+ # Imported responseids would go here
+         my $importedresponses=0;
  #
  # Is this a recursive call for a library?
  #
- Line 9115  sub metadata {
+ Line 12562  sub metadata {
                          my $dir=$filename;
                          $dir=~s|[^/]*$||;
                          $location=&filelocation($dir,$location);
+                         my $importid=$token->[2]->{'id'};
                          my $importmode=$token->[2]->{'importmode'};
+ #
+ # Check metadata for imported file to
+ # see if it contained response items
+ #
+                         my %currmetaentry = %metaentry;
+                         my $libresponseorder = &metadata($location,'responseorder');
+                         my $origfile;
+                         if ($libresponseorder ne '') {
+                             if ($#origfiletagids<0) {
+                                 undef(%importedrespids);
+                                 undef(%importedpartids);
+                             }
+                             @{$importedrespids{$importid}} = split(/\s*,\s*/,$libresponseorder);
+                             if (@{$importedrespids{$importid}} > 0) {
+                                 $importedresponses = 1;
+ # We need to get the original file and the imported file to get the response order correct
+ # Load and inspect original file
+                                 if ($#origfiletagids<0) {
+                                     my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
+                                     $origfile=&getfile($origfilelocation);
+                                     @origfiletagids=($origfile=~/<((?:\w+)response|import|part)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
+                                 }
+                             }
+                         }
+ # Do not overwrite contents of %metaentry hash for resource itself with
+ # hash populated for imported library file
+                         %metaentry = %currmetaentry;
+                         undef(%currmetaentry);
                          if ($importmode eq 'problem') {
  # Import as problem/response
                             $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
- Line 9125  sub metadata {
+ Line 12601  sub metadata {
                             $importedparts=1;
  # We need to get the original file and the imported file to get the part order correct
  # Good news: we do not need to worry about nested libraries, since parts cannot be nested
- # Load and inspect original file
+ # Load and inspect original file if we didn't do that already
-                            if ($#origfileimportpartids<0) {
+                            if ($#origfiletagids<0) {
-                               undef(%importedpartids);
+                                undef(%importedrespids);
-                               my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
+                                undef(%importedpartids);
-                               my $origfile=&getfile($origfilelocation);
+                                if ($origfile eq '') {
-                               @origfileimportpartids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
+                                    my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
+                                    $origfile=&getfile($origfilelocation);
+                                    @origfiletagids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
+                                }
                             }
  # Load and inspect imported file
- Line 9244  sub metadata {
+ Line 12723  sub metadata {
  	    grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));
  	$metaentry{':packages'} = join(',',@uniq_packages);
-         if ($importedparts) {
+         if (($importedresponses) || ($importedparts)) {
+             if ($importedparts) {
  # We had imported parts and need to rebuild partorder
-            $metaentry{':partorder'}='';
+                 $metaentry{':partorder'}='';
-            $metathesekeys{'partorder'}=1;
+                 $metathesekeys{'partorder'}=1;
-            for (my $index=0;$index<$#origfileimportpartids;$index+=2) {
+             }
-                if ($origfileimportpartids[$index] eq 'part') {
+             if ($importedresponses) {
- # original part, part of the problem
+ # We had imported responses and need to rebuild responseorder
-                   $metaentry{':partorder'}.=','.$origfileimportpartids[$index+1];
+                 $metaentry{':responseorder'}='';
-                } else {
+                 $metathesekeys{'responseorder'}=1;
- # we have imported parts at this position
+             }
-                   $metaentry{':partorder'}.=','.$importedpartids{$origfileimportpartids[$index+1]};
+             for (my $index=0;$index<$#origfiletagids;$index+=2) {
-                }
+                 my $origid = $origfiletagids[$index+1];
-            }
+                 if ($origfiletagids[$index] eq 'part') {
-            $metaentry{':partorder'}=~s/^\,//;
+ # Original part, part of the problem
+                     if ($importedparts) {
+                         $metaentry{':partorder'}.=','.$origid;
+                     }
+                 } elsif ($origfiletagids[$index] eq 'import') {
+                     if ($importedparts) {
+ # We have imported parts at this position
+                         $metaentry{':partorder'}.=','.$importedpartids{$origid};
+                     }
+                     if ($importedresponses) {
+ # We have imported responses at this position
+                         if (ref($importedrespids{$origid}) eq 'ARRAY') {
+                             $metaentry{':responseorder'}.=','.join(',',map { $origid.'_'.$_ } @{$importedrespids{$origid}});
+                         }
+                     }
+                 } else {
+ # Original response item, part of the problem
+                     if ($importedresponses) {
+                         $metaentry{':responseorder'}.=','.$origid;
+                     }
+                 }
+             }
+             if ($importedparts) {
+                 $metaentry{':partorder'}=~s/^\,//;
+             }
+             if ($importedresponses) {
+                 $metaentry{':responseorder'}=~s/^\,//;
+             }
          }
  	$metaentry{':keys'} = join(',',keys(%metathesekeys));
  	&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
- 	$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
+ 	$metaentry{':allpossiblekeys'}=join(',',keys(%metathesekeys));
  	&do_cache_new('meta',$uri,\%metaentry,$cachetime);
  # this is the end of "was not already recently cached
      }
- Line 9362  sub gettitle {
+ Line 12869  sub gettitle {
  	}
  	$title=~s/\&colon\;/\:/gs;
  	if ($title) {
+ # Remember both $symb and $title for dynamic metadata
+             $accesshash{$symb.'___crstitle'}=$title;
+             $accesshash{&declutter($map).'___'.&declutter($url).'___usage'}=time;
+ # Cache this title and then return it
  	    return &do_cache_new('title',$key,$title,600);
  	}
  	$urlsymb=$url;
- Line 9394  sub get_slot {
+ Line 12905  sub get_slot {
      }
      return $slotinfo{$which};
  }
+ sub get_reservable_slots {
+     my ($cnum,$cdom,$uname,$udom) = @_;
+     my $now = time;
+     my $reservable_info;
+     my $key=join("\0",'reservableslots',$cdom,$cnum,$uname,$udom);
+     if (exists($remembered{$key})) {
+         $reservable_info = $remembered{$key};
+     } else {
+         my %resv;
+         ($resv{'now_order'},$resv{'now'},$resv{'future_order'},$resv{'future'}) =
+         &Apache::loncommon::get_future_slots($cnum,$cdom,$now);
+         $reservable_info = \%resv;
+         $remembered{$key} = $reservable_info;
+     }
+     return $reservable_info;
+ }
+ sub get_course_slots {
+     my ($cnum,$cdom) = @_;
+     my $hashid=$cnum.':'.$cdom;
+     my ($result,$cached) = &Apache::lonnet::is_cached_new('allslots',$hashid);
+     if (defined($cached)) {
+         if (ref($result) eq 'HASH') {
+             return %{$result};
+         }
+     } else {
+         my %slots=&Apache::lonnet::dump('slots',$cdom,$cnum);
+         my ($tmp) = keys(%slots);
+         if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
+             &do_cache_new('allslots',$hashid,\%slots,600);
+             return %slots;
+         }
+     }
+     return;
+ }
+ sub devalidate_slots_cache {
+     my ($cnum,$cdom)=@_;
+     my $hashid=$cnum.':'.$cdom;
+     &devalidate_cache_new('allslots',$hashid);
+ }
+ sub get_coursechange {
+     my ($cdom,$cnum) = @_;
+     if ($cdom eq '' || $cnum eq '') {
+         return unless ($env{'request.course.id'});
+         $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
+         $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
+     }
+     my $hashid=$cdom.'_'.$cnum;
+     my ($change,$cached)=&is_cached_new('crschange',$hashid);
+     if ((defined($cached)) && ($change ne '')) {
+         return $change;
+     } else {
+         my %crshash;
+         %crshash = &get('environment',['internal.contentchange'],$cdom,$cnum);
+         if ($crshash{'internal.contentchange'} eq '') {
+             $change = $env{'course.'.$cdom.'_'.$cnum.'.internal.created'};
+             if ($change eq '') {
+                 %crshash = &get('environment',['internal.created'],$cdom,$cnum);
+                 $change = $crshash{'internal.created'};
+             }
+         } else {
+             $change = $crshash{'internal.contentchange'};
+         }
+         my $cachetime = 600;
+         &do_cache_new('crschange',$hashid,$change,$cachetime);
+     }
+     return $change;
+ }
+ sub devalidate_coursechange_cache {
+     my ($cdom,$cnum)=@_;
+     my $hashid=$cdom.'_'.$cnum;
+     &devalidate_cache_new('crschange',$hashid);
+ }
+ sub get_suppchange {
+     my ($cdom,$cnum) = @_;
+     if ($cdom eq '' || $cnum eq '') {
+         return unless ($env{'request.course.id'});
+         $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
+         $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
+     }
+     my $hashid=$cdom.'_'.$cnum;
+     my ($change,$cached)=&is_cached_new('suppchange',$hashid);
+     if ((defined($cached)) && ($change ne '')) {
+         return $change;
+     } else {
+         my %crshash = &get('environment',['internal.supplementalchange'],$cdom,$cnum);
+         if ($crshash{'internal.supplementalchange'} eq '') {
+             $change = $env{'course.'.$cdom.'_'.$cnum.'.internal.created'};
+             if ($change eq '') {
+                 %crshash = &get('environment',['internal.created'],$cdom,$cnum);
+                 $change = $crshash{'internal.created'};
+             }
+         } else {
+             $change = $crshash{'internal.supplementalchange'};
+         }
+         my $cachetime = 600;
+         &do_cache_new('suppchange',$hashid,$change,$cachetime);
+     }
+     return $change;
+ }
+ sub devalidate_suppchange_cache {
+     my ($cdom,$cnum)=@_;
+     my $hashid=$cdom.'_'.$cnum;
+     &devalidate_cache_new('suppchange',$hashid);
+ }
+ sub update_supp_caches {
+     my ($cdom,$cnum) = @_;
+     my %servers = &internet_dom_servers($cdom);
+     my @ids=&current_machine_ids();
+     foreach my $server (keys(%servers)) {
+         next if (grep(/^\Q$server\E$/,@ids));
+         my $hashid=$cnum.':'.$cdom;
+         my $cachekey = &escape('showsupp').':'.&escape($hashid);
+         &remote_devalidate_cache($server,[$cachekey]);
+     }
+     &has_unhidden_suppfiles($cnum,$cdom,1,1);
+     &count_supptools($cnum,$cdom,1);
+     my $now = time;
+     if ($env{'request.course.id'} eq $cdom.'_'.$cnum) {
+         &Apache::lonnet::appenv({'request.course.suppupdated' => $now});
+     }
+     &put('environment',{'internal.supplementalchange' => $now},
+          $cdom,$cnum);
+     &Apache::lonnet::appenv(
+         {'course.'.$cdom.'_'.$cnum.'.internal.supplementalchange' => $now});
+     &do_cache_new('suppchange',$cdom.'_'.$cnum,$now,600);
+ }
  # ------------------------------------------------- Update symbolic store links
  sub symblist {
- Line 9421  sub symblist {
+ Line 13067  sub symblist {
  # --------------------------------------------------------------- Verify a symb
  sub symbverify {
-     my ($symb,$thisurl)=@_;
+     my ($symb,$thisurl,$encstate)=@_;
      my $thisfn=$thisurl;
      $thisfn=&declutter($thisfn);
  # direct jump to resource in page or to a sequence - will construct own symbs
- Line 9442  sub symbverify {
+ Line 13088  sub symbverify {
                              &GDBM_READER(),0640)) {
          if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) {
              $thisurl =~ s/\?.+$//;
+             if ($map =~ m{^uploaded/.+\.page$}) {
+                 $thisurl =~ s{^(/adm/wrapper|)/ext/}{http://};
+                 $thisurl =~ s{^\Qhttp://https://\E}{https://};
+             }
+         }
+         my $ids;
+         if ($map =~ m{^uploaded/.+\.page$}) {
+             $ids=$bighash{'ids_'.&clutter_with_no_wrapper($thisurl)};
+         } else {
+             $ids=$bighash{'ids_'.&clutter($thisurl)};
          }
-         my $ids=$bighash{'ids_'.&clutter($thisurl)};
          unless ($ids) {
              my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl;
              $ids=$bighash{$idkey};
          }
          if ($ids) {
  # ------------------------------------------------------------------- Has ID(s)
+             if ($thisfn =~ m{^/adm/wrapper/ext/}) {
+                 $symb =~ 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) {
- 		   if (($env{'request.role.adv'}) ||
+                    if (ref($encstate)) {
- 		       ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) ||
+                        $$encstate = $bighash{'encrypted_'.$id};
+                    }
+                    if (($env{'request.role.adv'}) ||
+                        ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) ||
                         ($thisurl eq '/adm/navmaps')) {
- 		       $okay=1;
+                        $okay=1;
- 		   }
+                        last;
- 	       }
+                    }
- 	   }
+                }
+            }
          }
  	untie(%bighash);
      }
- Line 9536  sub deversion {
+ Line 13195  sub deversion {
  # ------------------------------------------------------ Return symb list entry
  sub symbread {
-     my ($thisfn,$donotrecurse)=@_;
+     my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles,
+         $ignoresymbdb,$noenccheck)=@_;
      my $cache_str='request.symbread.cached.'.$thisfn;
-     if (defined($env{$cache_str})) { return $env{$cache_str}; }
+     if (defined($env{$cache_str})) {
+         unless (ref($possibles) eq 'HASH') {
+             if ($ignorecachednull) {
+                 return $env{$cache_str} unless ($env{$cache_str} eq '');
+             } else {
+                 return $env{$cache_str};
+             }
+         }
+     }
  # no filename provided? try from environment
      unless ($thisfn) {
          if ($env{'request.symb'}) {
- 	    return $env{$cache_str}=&symbclean($env{'request.symb'});
+             return $env{$cache_str}=&symbclean($env{'request.symb'});
- 	}
+         }
- 	$thisfn=$env{'request.filename'};
+         $thisfn=$env{'request.filename'};
      }
      if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
  # is that filename actually a symb? Verify, clean, and return
- Line 9558  sub symbread {
+ Line 13226  sub symbread {
      my %bighash;
      my $syval='';
      if (($env{'request.course.fn'}) && ($thisfn)) {
-         my $targetfn = $thisfn;
+         unless ($ignoresymbdb) {
-         if ( ($thisfn =~ m/^(uploaded|editupload)\//) && ($thisfn !~ m/\.(page|sequence)$/) ) {
+             if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
-             $targetfn = 'adm/wrapper/'.$thisfn;
+                           &GDBM_READER(),0640)) {
-         }
+ 	        $syval=$hash{$thisfn};
- 	if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) {
+                 untie(%hash);
- 	    $targetfn=$1;
+             }
- 	}
+             if ($syval && $checkforblock) {
-         if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
+                 my @blockers = &has_comm_blocking('bre',$syval,$thisfn,$ignoresymbdb,$noenccheck);
-                       &GDBM_READER(),0640)) {
+                 if (@blockers) {
- 	    $syval=$hash{$targetfn};
+                     $syval='';
-             untie(%hash);
+                 }
+             }
          }
  # ---------------------------------------------------------- There was an entry
          if ($syval) {
- Line 9600  sub symbread {
+ Line 13269  sub symbread {
  		     my ($mapid,$resid)=split(/\./,$ids);
  		     $syval=&encode_symb($bighash{'map_id_'.$mapid},
  						    $resid,$thisfn);
-                  } elsif (!$donotrecurse) {
+                      if (ref($possibles) eq 'HASH') {
+                          unless ($bighash{'randomout_'.$ids} || $env{'request.role.adv'}) {
+                              $possibles->{$syval} = 1;
+                          }
+                      }
+                      if ($checkforblock) {
+                          unless ($bighash{'randomout_'.$ids} || $env{'request.role.adv'}) {
+                              my @blockers = &has_comm_blocking('bre',$syval,$bighash{'src_'.$ids},'',$noenccheck);
+                              if (@blockers) {
+                                  $syval = '';
+                                  untie(%bighash);
+                                  return $env{$cache_str}='';
+                              }
+                          }
+                      }
+                  } elsif ((!$donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) {
  # ------------------------------------------ There is more than one possibility
                       my $realpossible=0;
                       foreach my $id (@possibilities) {
  			 my $file=$bighash{'src_'.$id};
-                          if (&allowed('bre',$file)) {
+                          my $canaccess;
-          		    my ($mapid,$resid)=split(/\./,$id);
+                          if (($donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) {
-                             if ($bighash{'map_type_'.$mapid} ne 'page') {
+                              $canaccess = 1;
- 				$realpossible++;
+                          } else {
-                                 $syval=&encode_symb($bighash{'map_id_'.$mapid},
+                              $canaccess = &allowed('bre',$file);
- 						    $resid,$thisfn);
+                          }
-                             }
+                          if ($canaccess) {
+          		     my ($mapid,$resid)=split(/\./,$id);
+                              if ($bighash{'map_type_'.$mapid} ne 'page') {
+                                  my $poss_syval=&encode_symb($bighash{'map_id_'.$mapid},
+                                                              $resid,$thisfn);
+                                  next if ($bighash{'randomout_'.$id} && !$env{'request.role.adv'});
+                                  next unless (($noenccheck) || ($bighash{'encrypted_'.$id} eq $env{'request.enc'}));
+                                  if ($checkforblock) {
+                                      my @blockers = &has_comm_blocking('bre',$poss_syval,$file,'',$noenccheck);
+                                      if (@blockers > 0) {
+                                          $syval = '';
+                                      } else {
+                                          $syval = $poss_syval;
+                                          $realpossible++;
+                                      }
+                                  } else {
+                                      $syval = $poss_syval;
+                                      $realpossible++;
+                                  }
+                                  if ($syval) {
+                                      if (ref($possibles) eq 'HASH') {
+                                          $possibles->{$syval} = 1;
+                                      }
+                                  }
+                              }
  			 }
                       }
  		     if ($realpossible!=1) { $syval=''; }
- Line 9619  sub symbread {
+ Line 13327  sub symbread {
                       $syval='';
                   }
  	      }
-               untie(%bighash)
+               untie(%bighash);
             }
          }
          if ($syval) {
- Line 9759  sub rndseed {
+ Line 13467  sub rndseed {
      if (!defined($symb)) {
  	unless ($symb=$wsymb) { return time; }
      }
-     if (!$courseid) { $courseid=$wcourseid; }
+     if (!defined $courseid) {
-     if (!$domain) { $domain=$wdomain; }
+ 	$courseid=$wcourseid;
-     if (!$username) { $username=$wusername }
+     }
+     if (!defined $domain) { $domain=$wdomain; }
+     if (!defined $username) { $username=$wusername }
      my $which;
      if (defined($cenv->{'rndseed'})) {
- Line 9769  sub rndseed {
+ Line 13479  sub rndseed {
      } else {
  	$which =&get_rand_alg($courseid);
      }
      if (defined(&getCODE())) {
  	if ($which eq '64bit5') {
  	    return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);
  	} elsif ($which eq '64bit4') {
- Line 9957  sub rndseed_CODE_64bit5 {
+ Line 13665  sub rndseed_CODE_64bit5 {
  sub setup_random_from_rndseed {
      my ($rndseed)=@_;
      if ($rndseed =~/([,:])/) {
- 	my ($num1,$num2)=split(/[,:]/,$rndseed);
+ 	my ($num1,$num2) = map { abs($_); } (split(/[,:]/,$rndseed));
- 	&Math::Random::random_set_seed(abs($num1),abs($num2));
+         if ((!$num1) || (!$num2) || ($num1 > 2147483562) || ($num2 > 2147483398)) {
+             &Math::Random::random_set_seed_from_phrase($rndseed);
+         } else {
+             &Math::Random::random_set_seed($num1,$num2);
+         }
      } else {
  	&Math::Random::random_set_seed_from_phrase($rndseed);
      }
- Line 10097  sub repcopy_userfile {
+ Line 13809  sub repcopy_userfile {
      my ($file)=@_;
      my $londocroot = $perlvar{'lonDocRoot'};
      if ($file =~ m{^/*(uploaded|editupload)/}) { $file=&filelocation("",$file); }
-     if ($file =~ m{^\Q$londocroot/lonUsers/\E}) { return 'ok'; }
+     if ($file =~ m{^\Q/home/httpd/lonUsers/\E}) { return 'ok'; }
      my ($cdom,$cnum,$filename) =
  	($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|);
      my $uri="/uploaded/$cdom/$cnum/$filename";
- Line 10144  sub repcopy_userfile {
+ Line 13856  sub repcopy_userfile {
      my $request;
      $uri=~s/^\///;
      my $homeserver = &homeserver($cnum,$cdom);
+     my $hostname = &hostname($homeserver);
      my $protocol = $protocol{$homeserver};
      $protocol = 'http' if ($protocol ne 'https');
-     $request=new HTTP::Request('GET',$protocol.'://'.&hostname($homeserver).'/raw/'.$uri);
+     $request=new HTTP::Request('GET',$protocol.'://'.$hostname.'/raw/'.$uri);
      my $response=$ua->request($request,$transferfile);
  # did it work?
      if ($response->is_error()) {
- Line 10170  sub tokenwrapper {
+ Line 13883  sub tokenwrapper {
  	$file=~s|(\?\.*)*$||;
          &appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}});
          my $homeserver = &homeserver($uname,$udom);
+         my $hostname = &hostname($homeserver);
          my $protocol = $protocol{$homeserver};
          $protocol = 'http' if ($protocol ne 'https');
-         return $protocol.'://'.&hostname($homeserver).'/'.$uri.
+         return $protocol.'://'.$hostname.'/'.$uri.
                 (($uri=~/\?/)?'&':'?').'token='.$token.
                                 '&tokenissued='.$perlvar{'lonHostID'};
      } else {
- Line 10188  sub getuploaded {
+ Line 13902  sub getuploaded {
      my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
      $uri=~s/^\///;
      my $homeserver = &homeserver($cnum,$cdom);
+     my $hostname = &hostname($homeserver);
      my $protocol = $protocol{$homeserver};
      $protocol = 'http' if ($protocol ne 'https');
-     $uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri;
+     $uri = $protocol.'://'.$hostname.'/raw/'.$uri;
      my $ua=new LWP::UserAgent;
      my $request=new HTTP::Request($reqtype,$uri);
      my $response=$ua->request($request);
- Line 10210  sub readfile {
+ Line 13925  sub readfile {
      my $file = shift;
      if ( (! -e $file ) || ($file eq '') ) { return -1; };
      my $fh;
-     open($fh,"<$file");
+     open($fh,"<",$file);
      my $a='';
      while (my $line = <$fh>) { $a .= $line; }
      return $a;
- Line 10323  sub machine_ids {
+ Line 14038  sub machine_ids {
  sub additional_machine_domains {
      my @domains;
-     open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab");
+     if (-e "$perlvar{'lonTabDir'}/expected_domains.tab") {
-     while( my $line = <$fh>) {
+         if (open(my $fh,"<","$perlvar{'lonTabDir'}/expected_domains.tab")) {
-         $line =~ s/\s//g;
+             while( my $line = <$fh>) {
-         push(@domains,$line);
+                 chomp($line);
+                 $line =~ s/\s//g;
+                 push(@domains,$line);
+             }
+             close($fh);
+         }
      }
      return @domains;
  }
- Line 10344  sub default_login_domain {
+ Line 14064  sub default_login_domain {
      return $domain;
  }
+ sub shared_institution {
+     my ($dom,$lonhost) = @_;
+     if ($lonhost eq '') {
+         $lonhost = $perlvar{'lonHostID'};
+     }
+     my $same_intdom;
+     my $hostintdom = &internet_dom($lonhost);
+     if ($hostintdom ne '') {
+         my %iphost = &get_iphost();
+         my $primary_id = &domain($dom,'primary');
+         my $primary_ip = &get_host_ip($primary_id);
+         if (ref($iphost{$primary_ip}) eq 'ARRAY') {
+             foreach my $id (@{$iphost{$primary_ip}}) {
+                 my $intdom = &internet_dom($id);
+                 if ($intdom eq $hostintdom) {
+                     $same_intdom = 1;
+                     last;
+                 }
+             }
+         }
+     }
+     return $same_intdom;
+ }
+ sub uses_sts {
+     my ($ignore_cache) = @_;
+     my $lonhost = $perlvar{'lonHostID'};
+     my $hostname = &hostname($lonhost);
+     my $sts_on;
+     if ($protocol{$lonhost} eq 'https') {
+         my $cachetime = 12*3600;
+         if (!$ignore_cache) {
+             ($sts_on,my $cached)=&is_cached_new('stspolicy',$lonhost);
+             if (defined($cached)) {
+                 return $sts_on;
+             }
+         }
+         my $ua=new LWP::UserAgent;
+         my $url = $protocol{$lonhost}.'://'.$hostname.'/index.html';
+         my $request=new HTTP::Request('HEAD',$url);
+         my $response=$ua->request($request);
+         if ($response->is_success) {
+             my $has_sts = $response->header('Strict-Transport-Security');
+             if ($has_sts eq '') {
+                 $sts_on = 0;
+             } else {
+                 if ($has_sts =~ /\Qmax-age=\E(\d+)/) {
+                     my $maxage = $1;
+                     if ($maxage) {
+                         $sts_on = 1;
+                     } else {
+                         $sts_on = 0;
+                     }
+                 } else {
+                     $sts_on = 0;
+                 }
+             }
+             return &do_cache_new('stspolicy',$lonhost,$sts_on,$cachetime);
+         }
+     }
+     return;
+ }
+ sub waf_allssl {
+     my ($host_name) = @_;
+     my $alias = &get_proxy_alias();
+     if ($host_name eq '') {
+         $host_name = $ENV{'SERVER_NAME'};
+     }
+     if (($host_name ne '') && ($alias eq $host_name)) {
+         my $serverhomedom = &host_domain($perlvar{'lonHostID'});
+         my %defdomdefaults = &get_domain_defaults($serverhomedom);
+         if ($defdomdefaults{'waf_sslopt'}) {
+             return $defdomdefaults{'waf_sslopt'};
+         }
+     }
+     return;
+ }
+ sub get_requestor_ip {
+     my ($r,$nolookup,$noproxy) = @_;
+     my $from_ip;
+     if (ref($r)) {
+         if ($r->can('useragent_ip')) {
+             if ($noproxy && $r->can('client_ip')) {
+                 $from_ip = $r->client_ip();
+             } else {
+                 $from_ip = $r->useragent_ip();
+             }
+         } elsif ($r->connection->can('remote_ip')) {
+             $from_ip = $r->connection->remote_ip();
+         } else {
+             $from_ip = $r->get_remote_host($nolookup);
+         }
+     } else {
+         $from_ip = $ENV{'REMOTE_ADDR'};
+     }
+     return $from_ip if ($noproxy);
+    # Who controls proxy settings for server
+     my $dom_in_use = $Apache::lonnet::perlvar{'lonDefDomain'};
+     my $proxyinfo = &get_proxy_settings($dom_in_use);
+     if ((ref($proxyinfo) eq 'HASH') && ($from_ip)) {
+         if ($proxyinfo->{'vpnint'}) {
+             if (&ip_match($from_ip,$proxyinfo->{'vpnint'})) {
+                 return $from_ip;
+             }
+         }
+         if ($proxyinfo->{'trusted'}) {
+             if (&ip_match($from_ip,$proxyinfo->{'trusted'})) {
+                 my $ipheader = $proxyinfo->{'ipheader'};
+                 my ($ip,$xfor);
+                 if (ref($r)) {
+                     if ($ipheader) {
+                         $ip = $r->headers_in->{$ipheader};
+                     }
+                     $xfor = $r->headers_in->{'X-Forwarded-For'};
+                 } else {
+                     if ($ipheader) {
+                         $ip = $ENV{'HTTP_'.uc($ipheader)};
+                     }
+                     $xfor = $ENV{'HTTP_X_FORWARDED_FOR'};
+                 }
+                 if (($ip eq '') && ($xfor ne '')) {
+                     foreach my $poss_ip (reverse(split(/\s*,\s*/,$xfor))) {
+                         unless (&ip_match($poss_ip,$proxyinfo->{'trusted'})) {
+                             $ip = $poss_ip;
+                             last;
+                         }
+                     }
+                 }
+                 if ($ip ne '') {
+                     return $ip;
+                 }
+             }
+         }
+     }
+     return $from_ip;
+ }
+ sub get_proxy_settings {
+     my ($dom_in_use) = @_;
+     my %domdefaults = &Apache::lonnet::get_domain_defaults($dom_in_use);
+     my $proxyinfo = {
+                        ipheader => $domdefaults{'waf_ipheader'},
+                        trusted  => $domdefaults{'waf_trusted'},
+                        vpnint   => $domdefaults{'waf_vpnint'},
+                        vpnext   => $domdefaults{'waf_vpnext'},
+                        sslopt   => $domdefaults{'waf_sslopt'},
+                     };
+     return $proxyinfo;
+ }
+ sub ip_match {
+     my ($ip,$pattern_str) = @_;
+     $ip=Net::CIDR::cidrvalidate($ip);
+     if ($ip) {
+         return Net::CIDR::cidrlookup($ip,split(/\s*,\s*/,$pattern_str));
+     }
+     return;
+ }
+ sub get_proxy_alias {
+     my ($lonid) = @_;
+     if ($lonid eq '') {
+         $lonid = $perlvar{'lonHostID'};
+     }
+     if (!defined(&hostname($lonid))) {
+         return;
+     }
+     if ($lonid ne '') {
+         my ($alias,$cached) = &is_cached_new('proxyalias',$lonid);
+         if ($cached) {
+             return $alias;
+         }
+         my $dom = &Apache::lonnet::host_domain($lonid);
+         if ($dom ne '') {
+             my $cachetime = 60*60*24;
+             my %domconfig =
+                 &Apache::lonnet::get_dom('configuration',['wafproxy'],$dom);
+             if (ref($domconfig{'wafproxy'}) eq 'HASH') {
+                 if (ref($domconfig{'wafproxy'}{'alias'}) eq 'HASH') {
+                     $alias = $domconfig{'wafproxy'}{'alias'}{$lonid};
+                 }
+             }
+             return &do_cache_new('proxyalias',$lonid,$alias,$cachetime);
+         }
+     }
+     return;
+ }
+ sub use_proxy_alias {
+     my ($r,$lonid) = @_;
+     my $alias = &get_proxy_alias($lonid);
+     if ($alias) {
+         my $dom = &host_domain($lonid);
+         if ($dom ne '') {
+             my $proxyinfo = &get_proxy_settings($dom);
+             my ($vpnint,$remote_ip);
+             if (ref($proxyinfo) eq 'HASH') {
+                 $vpnint = $proxyinfo->{'vpnint'};
+                 if ($vpnint) {
+                     $remote_ip = &get_requestor_ip($r,1,1);
+                 }
+             }
+             unless ($vpnint && &ip_match($remote_ip,$vpnint)) {
+                 return $alias;
+             }
+         }
+     }
+     return;
+ }
+ sub alias_sso {
+     my ($lonid) = @_;
+     if ($lonid eq '') {
+         $lonid = $perlvar{'lonHostID'};
+     }
+     if (!defined(&hostname($lonid))) {
+         return;
+     }
+     if ($lonid ne '') {
+         my ($use_alias,$cached) = &is_cached_new('proxysaml',$lonid);
+         if ($cached) {
+             return $use_alias;
+         }
+         my $dom = &Apache::lonnet::host_domain($lonid);
+         if ($dom ne '') {
+             my $cachetime = 60*60*24;
+             my %domconfig =
+                 &Apache::lonnet::get_dom('configuration',['wafproxy'],$dom);
+             if (ref($domconfig{'wafproxy'}) eq 'HASH') {
+                 if (ref($domconfig{'wafproxy'}{'saml'}) eq 'HASH') {
+                     $use_alias = $domconfig{'wafproxy'}{'saml'}{$lonid};
+                 }
+             }
+             return &do_cache_new('proxysaml',$lonid,$use_alias,$cachetime);
+         }
+     }
+     return;
+ }
+ sub get_saml_landing {
+     my ($lonid) = @_;
+     if ($lonid eq '') {
+         my $defdom = &default_login_domain();
+         my @hosts = &current_machine_ids();
+         if (@hosts > 1) {
+             foreach my $hostid (@hosts) {
+                 if (&host_domain($hostid) eq $defdom) {
+                     $lonid = $hostid;
+                     last;
+                 }
+             }
+         } else {
+             $lonid = $perlvar{'lonHostID'};
+         }
+         if ($lonid) {
+             unless (&Apache::lonnet::host_domain($lonid) eq $defdom) {
+                 return;
+             }
+         } else {
+             return;
+         }
+     } elsif (!defined(&hostname($lonid))) {
+         return;
+     }
+     my ($landing,$cached) = &is_cached_new('samllanding',$lonid);
+     if ($cached) {
+         return $landing;
+     }
+     my $dom = &Apache::lonnet::host_domain($lonid);
+     if ($dom ne '') {
+         my $cachetime = 60*60*24;
+         my %domconfig =
+             &Apache::lonnet::get_dom('configuration',['login'],$dom);
+         if (ref($domconfig{'login'}) eq 'HASH') {
+             if (ref($domconfig{'login'}{'saml'}) eq 'HASH') {
+                 if (ref($domconfig{'login'}{'saml'}{$lonid}) eq 'HASH') {
+                     $landing = 1;
+                 }
+             }
+         }
+         return &do_cache_new('samllanding',$lonid,$landing,$cachetime);
+     }
+     return;
+ }
  # ------------------------------------------------------------- Declutters URLs
  sub declutter {
      my $thisfn=shift;
      if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
-     $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;
+     unless ($thisfn=~m{^/home/httpd/html/priv/}) {
+         $thisfn=~s{^/home/httpd/html}{};
+     }
      $thisfn=~s/^\///;
      $thisfn=~s|^adm/wrapper/||;
      $thisfn=~s|^adm/coursedocs/showdoc/||;
      $thisfn=~s/^res\///;
+     $thisfn=~s/^priv\///;
      unless (($thisfn =~ /^ext/) || ($thisfn =~ /\.(page|sequence)___\d+___ext/)) {
          $thisfn=~s/\?.+$//;
      }
- Line 10391  sub clutter {
+ Line 14401  sub clutter {
  #		&logthis("Got a blank emb style");
  	    }
  	}
+     } elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/ext\.tool$}) {
+         $thisfn='/adm/wrapper'.$thisfn;
      }
      return $thisfn;
  }
- Line 10453  sub goodbye {
+ Line 14465  sub goodbye {
  }
  sub get_dns {
-     my ($url,$func,$ignore_cache) = @_;
+     my ($url,$func,$ignore_cache,$nocache,$hashref) = @_;
      if (!$ignore_cache) {
  	my ($content,$cached)=
  	    &Apache::lonnet::is_cached_new('dns',$url);
  	if ($cached) {
- 	    &$func($content);
+ 	    &$func($content,$hashref);
  	    return;
  	}
      }
      my %alldns;
-     open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
+     if (open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab")) {
-     foreach my $dns (<$config>) {
+         foreach my $dns (<$config>) {
- 	next if ($dns !~ /^\^(\S*)/x);
+ 	    next if ($dns !~ /^\^(\S*)/x);
-         my $line = $1;
+             my $line = $1;
-         my ($host,$protocol) = split(/:/,$line);
+             my ($host,$protocol) = split(/:/,$line);
-         if ($protocol ne 'https') {
+             if ($protocol ne 'https') {
-             $protocol = 'http';
+                 $protocol = 'http';
+             }
+ 	    $alldns{$host} = $protocol;
          }
- 	$alldns{$host} = $protocol;
+         close($config);
      }
      while (%alldns) {
- 	my ($dns) = keys(%alldns);
+ 	my ($dns) = sort { $b cmp $a } keys(%alldns);
- 	my $ua=new LWP::UserAgent;
+         my @content;
-         $ua->timeout(30);
+         if ($dns eq Sys::Hostname::FQDN::fqdn()) {
- 	my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
+             my $command = (split('/',$url))[3];
- 	my $response=$ua->request($request);
+             my ($dir,$file) = &parse_getdns_url($command,$url);
-         delete($alldns{$dns});
+             delete($alldns{$dns});
- 	next if ($response->is_error());
+             next if (($dir eq '') || ($file eq ''));
- 	my @content = split("\n",$response->content);
+             if (open(my $config,'<',"$dir/$file")) {
- 	&Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60);
+                 @content = <$config>;
- 	&$func(\@content);
+                 close($config);
+             }
+         } else {
+ 	    my $ua=new LWP::UserAgent;
+             $ua->timeout(30);
+ 	    my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
+ 	    my $response=$ua->request($request);
+             delete($alldns{$dns});
+ 	    next if ($response->is_error());
+ 	    @content = split("\n",$response->content);
+         }
+         unless ($nocache) {
+ 	    &do_cache_new('dns',$url,\@content,30*24*60*60);
+         }
+ 	&$func(\@content,$hashref);
  	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");
+     if (open(my $config,"<","$perlvar{'lonTabDir'}/dns_$which.tab")) {
-     my @content = <$config>;
+         my @content = <$config>;
-     &$func(\@content);
+         &$func(\@content,$hashref);
+     }
+     return;
+ }
+ # ------------------------------------------------------Get DNS checksums file
+ sub parse_dns_checksums_tab {
+     my ($lines,$hashref) = @_;
+     my $lonhost = $perlvar{'lonHostID'};
+     my $machine_dom = &Apache::lonnet::host_domain($lonhost);
+     my $loncaparev = &get_server_loncaparev($machine_dom);
+     my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0];
+     my $webconfdir = '/etc/httpd/conf';
+     if ($distro =~ /^(ubuntu|debian)(\d+)$/) {
+         $webconfdir = '/etc/apache2';
+     } elsif ($distro =~ /^sles(\d+)$/) {
+         if ($1 >= 10) {
+             $webconfdir = '/etc/apache2';
+         }
+     } elsif ($distro =~ /^suse(\d+\.\d+)$/) {
+         if ($1 >= 10.0) {
+             $webconfdir = '/etc/apache2';
+         }
+     }
+     my ($release,$timestamp) = split(/\-/,$loncaparev);
+     my (%chksum,%revnum);
+     if (ref($lines) eq 'ARRAY') {
+         chomp(@{$lines});
+         my $version = shift(@{$lines});
+         if ($version eq $release) {
+             foreach my $line (@{$lines}) {
+                 my ($file,$version,$shasum) = split(/,/,$line);
+                 if ($file =~ m{^/etc/httpd/conf}) {
+                     if ($webconfdir eq '/etc/apache2') {
+                         $file =~ s{^\Q/etc/httpd/conf/\E}{$webconfdir/};
+                     }
+                 }
+                 $chksum{$file} = $shasum;
+                 $revnum{$file} = $version;
+             }
+             if (ref($hashref) eq 'HASH') {
+                 %{$hashref} = (
+                                 sums     => \%chksum,
+                                 versions => \%revnum,
+                               );
+             }
+         }
+     }
      return;
  }
+ sub fetch_dns_checksums {
+     my %checksums;
+     my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});
+     my $loncaparev = &get_server_loncaparev($machine_dom,$perlvar{'lonHostID'});
+     my ($release,$timestamp) = split(/\-/,$loncaparev);
+     &get_dns("/adm/dns/checksums/$release",\&parse_dns_checksums_tab,1,1,
+              \%checksums);
+     return \%checksums;
+ }
+ sub parse_getdns_url {
+     my ($command,$url) = @_;
+     my $dir = $perlvar{'lonTabDir'};
+     my $file;
+     if ($command eq 'hosts') {
+         $file = 'dns_hosts.tab';
+     } elsif ($command eq 'domain') {
+         $file = 'dns_domain.tab';
+     } elsif ($command eq 'checksums') {
+         my $version = (split('/',$url))[4];
+         $file = "dns_checksums/$version.tab",
+     }
+     return ($dir,$file);
+ }
  # ------------------------------------------------------------ Read domain file
  {
      my $loaded;
- Line 10523  sub get_dns {
+ Line 14623  sub get_dns {
      }
      sub load_domain_tab {
- 	my ($ignore_cache) = @_;
+ 	my ($ignore_cache,$nocache) = @_;
- 	&get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache);
+ 	&get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache,$nocache);
  	my $fh;
- 	if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) {
+ 	if (open($fh,"<",$perlvar{'lonTabDir'}.'/domain.tab')) {
  	    my @lines = <$fh>;
  	    &parse_domain_tab(\@lines);
  	}
- Line 10578  sub get_dns {
+ Line 14678  sub get_dns {
  	    my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline);
  	    $name=~s/\s//g;
  	    if ($id && $domain && $role && $name) {
+                 if ((exists($hostname{$id})) && ($hostname{$id} ne '')) {
+                     my $curr = $hostname{$id};
+                     my $skip;
+                     if (ref($name_to_host{$curr}) eq 'ARRAY') {
+                         if (($curr eq $name) && (@{$name_to_host{$curr}} == 1)) {
+                             $skip = 1;
+                         } else {
+                             @{$name_to_host{$curr}} = grep { $_ ne $id } @{$name_to_host{$curr}};
+                         }
+                     }
+                     unless ($skip) {
+                         push(@{$name_to_host{$name}},$id);
+                     }
+                 } else {
+                     push(@{$name_to_host{$name}},$id);
+                 }
  		$hostname{$id}=$name;
- 		push(@{$name_to_host{$name}}, $id);
  		$hostdom{$id}=$domain;
  		if ($role eq 'library') { $libserv{$id}=$name; }
                  if (defined($protocol)) {
- Line 10610  sub get_dns {
+ Line 14725  sub get_dns {
      }
      sub load_hosts_tab {
- 	my ($ignore_cache) = @_;
+ 	my ($ignore_cache,$nocache) = @_;
- 	&get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache);
+ 	&get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache,$nocache);
- 	open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
+ 	open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab");
  	my @config = <$config>;
  	&parse_hosts_tab(\@config);
  	close($config);
- Line 10633  sub get_dns {
+ Line 14748  sub get_dns {
      }
      sub all_names {
- 	&load_hosts_tab() if (!$loaded);
+         my ($ignore_cache,$nocache) = @_;
+ 	&load_hosts_tab($ignore_cache,$nocache) if (!$loaded);
  	return %name_to_host;
      }
- Line 10755  sub get_dns {
+ Line 14871  sub get_dns {
      }
      sub get_iphost {
- 	my ($ignore_cache) = @_;
+ 	my ($ignore_cache,$nocache) = @_;
  	if (!$ignore_cache) {
  	    if (%iphost) {
- Line 10779  sub get_dns {
+ Line 14895  sub get_dns {
  	    %old_name_to_ip = %{$ip_info->[1]};
  	}
- 	my %name_to_host = &all_names();
+ 	my %name_to_host = &all_names($ignore_cache,$nocache);
  	foreach my $name (keys(%name_to_host)) {
  	    my $ip;
  	    if (!exists($name_to_ip{$name})) {
- Line 10804  sub get_dns {
+ Line 14920  sub get_dns {
  	    }
  	    push(@{$iphost{$ip}},@{$name_to_host{$name}});
  	}
- 	&Apache::lonnet::do_cache_new('iphost','iphost',
+         unless ($nocache) {
- 				      [\%iphost,\%name_to_ip,\%lonid_to_ip],
+ 	    &do_cache_new('iphost','iphost',
-*60*60);
+ 		          [\%iphost,\%name_to_ip,\%lonid_to_ip],
+*60*60);
+         }
  	return %iphost;
      }
- Line 10862  sub get_dns {
+ Line 14980  sub get_dns {
              }
              $seen{$prim_ip} = 1;
          }
-         return &Apache::lonnet::do_cache_new('internetnames',$lonid,\@idns,12*60*60);
+         return &do_cache_new('internetnames',$lonid,\@idns,12*60*60);
      }
  }
  sub all_loncaparevs {
-     return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10);
+     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 2.11);
+ }
+ # ------------------------------------------------------- Read loncaparev table
+ {
+     sub load_loncaparevs {
+         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
+ {
+     sub load_serverhomeIDs {
+         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);
+             }
+         }
+     }
+ }
  BEGIN {
  # ----------------------------------- Read loncapa.conf and loncapa_apache.conf
- Line 10883  BEGIN {
+ Line 15034  BEGIN {
  # ------------------------------------------------------ Read spare server file
  {
-     open(my $config,"<$perlvar{'lonTabDir'}/spare.tab");
+     open(my $config,"<","$perlvar{'lonTabDir'}/spare.tab");
      while (my $configline=<$config>) {
         chomp($configline);
- Line 10897  BEGIN {
+ Line 15048  BEGIN {
  }
  # ------------------------------------------------------------ Read permissions
  {
-     open(my $config,"<$perlvar{'lonTabDir'}/roles.tab");
+     open(my $config,"<","$perlvar{'lonTabDir'}/roles.tab");
      while (my $configline=<$config>) {
  	chomp($configline);
- Line 10911  BEGIN {
+ Line 15062  BEGIN {
  # -------------------------------------------- Read plain texts for permissions
  {
-     open(my $config,"<$perlvar{'lonTabDir'}/rolesplain.tab");
+     open(my $config,"<","$perlvar{'lonTabDir'}/rolesplain.tab");
      while (my $configline=<$config>) {
  	chomp($configline);
- Line 10931  BEGIN {
+ Line 15082  BEGIN {
  # ---------------------------------------------------------- Read package table
  {
-     open(my $config,"<$perlvar{'lonTabDir'}/packages.tab");
+     open(my $config,"<","$perlvar{'lonTabDir'}/packages.tab");
      while (my $configline=<$config>) {
  	if ($configline !~ /\S/ || $configline=~/^#/) { next; }
- Line 10946  BEGIN {
+ Line 15097  BEGIN {
      close($config);
  }
- # ---------------------------------------------------------- Read loncaparev table
+ # --------------------------------------------------------- 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
+ &load_loncaparevs();
- {
-     if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") {
+ # ------------------------------------------------------- Read serverhostID table
-         if (open(my $config,"<$perlvar{'lonTabDir'}/serverhomeIDs.tab")) {
-             while (my $configline=<$config>) {
+ &load_serverhomeIDs();
-                 chomp($configline);
-                 my ($name,$id)=split(/:/,$configline);
-                 $serverhomeIDs{$name}=$id;
-             }
-             close($config);
-         }
-     }
- }
+ # ---------------------------------------------------------- Read releaseslist XML
  {
      my $file = $Apache::lonnet::perlvar{'lonTabDir'}.'/releaseslist.xml';
      if (-e $file) {
- Line 10996  BEGIN {
+ Line 15128  BEGIN {
  # ---------------------------------------------------------- Read managers table
  {
      if (-e "$perlvar{'lonTabDir'}/managers.tab") {
-         if (open(my $config,"<$perlvar{'lonTabDir'}/managers.tab")) {
+         if (open(my $config,"<","$perlvar{'lonTabDir'}/managers.tab")) {
              while (my $configline=<$config>) {
                  chomp($configline);
                  next if ($configline =~ /^\#/);
- Line 11015  BEGIN {
+ Line 15147  BEGIN {
  }
+ # ------------- set default texengine (domain default overrides this)
+ {
+     $deftex = LONCAPA::texengine();
+ }
+ # ------------- set default minimum length for passwords for internal auth users
+ {
+     $passwdmin = LONCAPA::passwd_min();
+ }
  $memcache=new Cache::Memcached({'servers'           => ['127.0.0.1:11211'],
  				'compress_threshold'=> 20_000,
   			        });
- Line 11172  were new keys. I.E. 1:foo will become 1:
+ Line 15314  were new keys. I.E. 1:foo will become 1:
  Calling convention:
-  my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname,$home);
+  my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname);
-  &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$home);
+  &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$laststore);
  For more detailed information, see lonnet specific documentation.
- Line 11272  B<idput($udom,%ids)>: store away a list
+ Line 15414  B<idput($udom,%ids)>: store away a list
  =item *
  X<rolesinit()>
- B<rolesinit($udom,$username,$authhost)>: get user privileges
+ B<rolesinit($udom,$username)>: get user privileges.
+ returns user role, first access and timer interval hashes
+ =item *
+ X<privileged()>
+ B<privileged($username,$domain)>: returns a true if user has a
+ privileged and active role (i.e. su or dc), false otherwise.
  =item *
  X<getsection()>
- Line 11303  escaped strings of the action recorded i
+ Line 15451  escaped strings of the action recorded i
  =item *
- allowed($priv,$uri,$symb,$role) : check for a user privilege; returns codes for allowed actions
+ allowed($priv,$uri,$symb,$role,$clientip,$noblockcheck) : check for a user privilege;
+ returns codes for allowed actions.
+ The first argument is required, all others are optional.
+ $priv is the privilege being checked.
+ $uri contains additional information about what is being checked for access (e.g.,
+ URL, course ID etc.).
+ $symb is the unique resource instance identifier in a course; if needed,
+ but not provided, it will be retrieved via a call to &symbread().
+ $role is the role for which a priv is being checked (only used if priv is evb).
+ $clientip is the user's IP address (only used when checking for access to portfolio
+ files).
+ $noblockcheck, if true, skips calls to &has_comm_blocking() for the bre priv. This
+ prevents recursive calls to &allowed.
   F: full access
   U,I,K: authentication modes (cxx only)
   '': forbidden
 : user needs to choose course
 : browse allowed
   A: passphrase authentication needed
+  B: access temporarily blocked because of a blocking event in a course.
+  D: access blocked because access is required via session initiated via deep-link
+ =item *
+ constructaccess($url,$setpriv) : check for access to construction space URL
+ See if the owner domain and name in the URL match those in the
+ expected environment.  If so, return three element list
+ ($ownername,$ownerdomain,$ownerhome).
+ Otherwise return the null string.
+ If second argument 'setpriv' is true, it assigns the privileges,
+ and returns the same three element list, unless the owner has
+ blocked "ad hoc" Domain Coordinator access to the Author Space,
+ in which case the null string is returned.
  =item *
- definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom
+ definerole($rolename,$sysrole,$domrole,$courole,$uname,$udom) : define role;
- role rolename set privileges in format of lonTabs/roles.tab for system, domain,
+ define a custom role rolename set privileges in format of lonTabs/roles.tab
- and course level
+ for system, domain, and course level. $uname and $udom are optional (current
+ user's username and domain will be used when either of $uname or $udom are absent.
  =item *
- Line 11329  environment).  If no custom name is defi
+ Line 15510  environment).  If no custom name is defi
  =item *
- get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec) :
+ get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec,$hidepriv) :
  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,
- Line 11343  of role statuses (active, future or prev
+ Line 15524  of role statuses (active, future or prev
  to restrict the list of roles reported. If no array ref is
  provided for types, will default to return only active roles.
+ =item *
+ in_course($udom,$uname,$cdom,$cnum,$type,$hideprivileged) : determine if
+ user: $uname:$udom has a role in the course: $cdom_$cnum.
+ Additional optional arguments are: $type (if role checking is to be restricted
+ to certain user status types -- previous (expired roles), active (currently
+ available roles) or future (roles available in the future), and
+ $hideprivileged -- if true will not report course roles for users who
+ have active Domain Coordinator role in course's domain or in additional
+ domains (specified in 'Domains to check for privileged users' in course
+ environment -- set via:  Course Settings -> Classlists and staff listing).
+ =item *
+ privileged($username,$domain,$possdomains,$possroles) : returns 1 if user
+ $username:$domain is a privileged user (e.g., Domain Coordinator or Super User)
+ $possdomains and $possroles are optional array refs -- to domains to check and
+ roles to check.  If $possdomains is not specified, a dump will be done of the
+ users' roles.db to check for a dc or su role in any domain. This can be
+ time consuming if &privileged is called repeatedly (e.g., when displaying a
+ classlist), so in such cases, supplying a $possdomains array is preferred, as
+ this then allows &privileged_by_domain() to be used, which caches the identity
+ of privileged users, eliminating the need for repeated calls to &dump().
+ =item *
+ privileged_by_domain($possdomains,$roles) : returns a hash of a hash of a hash,
+ where the outer hash keys are domains specified in the $possdomains array ref,
+ next inner hash keys are privileged roles specified in the $roles array ref,
+ and the innermost hash contains key = value pairs for username:domain = end:start
+ for active or future "privileged" users with that role in that domain. To avoid
+ repeated dumps of domain roles -- via &get_domain_roles() -- contents of the
+ innerhash are cached using priv_$role and $dom as the identifiers.
  =back
  =head2 User Modification
- Line 11384  or when Autoupdate.pl is run by cron in
+ Line 15600  or when Autoupdate.pl is run by cron in
  modifystudent
  modify a student's enrollment and identification information.
- The course id is resolved based on the current users environment.
+ The course id is resolved based on the current user's environment.
- This means the envoking user must be a course coordinator or otherwise
+ This means the invoking user must be a course coordinator or otherwise
  associated with a course.
  This call is essentially a wrapper for lonnet::modifyuser and
- Line 11435  Inputs:
+ Line 15651  Inputs:
  =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
+ =item B<$credits> Number of credits student will earn from this class - only needs to be supplied if value needs to be different from default credits for class.
  =back
- Line 11443  Inputs:
+ Line 15661  Inputs:
  modify_student_enrollment
- Change a students enrollment status in a class.  The environment variable
+ Change a student's enrollment status in a class.  The environment variable
  'role.request.course' must be defined for this function to proceed.
  Inputs:
  =over 4
- =item $udom, students domain
+ =item $udom, student's domain
- =item $uname, students name
+ =item $uname, student's name
- =item $uid, students user id
+ =item $uid, student's user id
- =item $first, students first name
+ =item $first, student's first name
  =item $middle
- Line 11480  Inputs:
+ Line 15698  Inputs:
  =item $context
+ =item $credits, number of credits student will earn from this class
+ =item $instsec, institutional course section code for student
  =back
- Line 11536  If defined, the supplied username is use
+ Line 15758  If defined, the supplied username is use
  resdata($name,$domain,$type,@which) : request for current parameter
  setting for a specific $type, where $type is either 'course' or 'user',
  @what should be a list of parameters to ask about. This routine caches
- answers for 5 minutes.
+ answers for 10 minutes.
  =item *
- Line 11545  data base, returning a hash that is keye
+ Line 15767  data base, returning a hash that is keye
  values that are the resource value.  I believe that the timestamps and
  versions are also returned.
  =back
  =head2 Course Modification
- Line 11565  createcourse($udom,$description,$url,$co
+ Line 15786  createcourse($udom,$description,$url,$co
  generate_coursenum($udom,$crstype) : get a unique (unused) course number in domain $udom for course type $crstype (Course or Community).
+ =item *
+ is_course($courseid), is_course($cdom, $cnum)
+ Accepts either a combined $courseid (in the form of domain_courseid) or the
+ two component version $cdom, $cnum. It checks if the specified course exists.
+ Returns:
+     undef if the course doesn't exist, otherwise
+     in scalar context the combined courseid.
+     in list context the two components of the course identifier, domain and
+     courseid.
+ =back
+ =head2 Bubblesheet Configuration
+ =over 4
+ =item *
+ get_scantron_config($which)
+ $which - the name of the configuration to parse from the file.
+ Parses and returns the bubblesheet configuration line selected as a
+ hash of configuration file fields.
+ Returns:
+     If the named configuration is not in the file, an empty
+     hash is returned.
+     a hash with the fields
+       name         - internal name for the this configuration setup
+       description  - text to display to operator that describes this config
+       CODElocation - if 0 or the string 'none'
+                           - no CODE exists for this config
+                      if -1 || the string 'letter'
+                           - a CODE exists for this config and is
+                             a string of letters
+                      Unsupported value (but planned for future support)
+                           if a positive integer
+                                - The CODE exists as the first n items from
+                                  the question section of the form
+                           if the string 'number'
+                                - The CODE exists for this config and is
+                                  a string of numbers
+       CODEstart   - (only matter if a CODE exists) column in the line where
+                      the CODE starts
+       CODElength  - length of the CODE
+       IDstart     - column where the student/employee ID starts
+       IDlength    - length of the student/employee ID info
+       Qstart      - column where the information from the bubbled
+                     'questions' start
+       Qlength     - number of columns comprising a single bubble line from
+                     the sheet. (usually either 1 or 10)
+       Qon         - either a single character representing the character used
+                     to signal a bubble was chosen in the positional setup, or
+                     the string 'letter' if the letter of the chosen bubble is
+                     in the final, or 'number' if a number representing the
+                     chosen bubble is in the file (1->A 0->J)
+       Qoff        - the character used to represent that a bubble was
+                     left blank
+       PaperID     - if the scanning process generates a unique number for each
+                     sheet scanned the column that this ID number starts in
+       PaperIDlength - number of columns that comprise the unique ID number
+                       for the sheet of paper
+       FirstName   - column that the first name starts in
+       FirstNameLength - number of columns that the first name spans
+       LastName    - column that the last name starts in
+       LastNameLength - number of columns that the last name spans
+       BubblesPerRow - number of bubbles available in each row used to
+                       bubble an answer. (If not specified, 10 assumed).
+ =item *
+ get_scantronformat_file($cdom)
+ $cdom - the course's domain (optional); if not supplied, uses
+ domain for current $env{'request.course.id'}.
+ Returns an array containing lines from the scantron format file for
+ the domain of the course.
+ If a url for a custom.tab file is listed in domain's configuration.db,
+ lines are from this file.
+ Otherwise, if a default.tab has been published in RES space by the
+ domainconfig user, lines are from this file.
+ Otherwise, fall back to getting lines from the legacy file on the
+ local server:  /home/httpd/lonTabs/default_scantronformat.tab
  =back
  =head2 Resource Subroutines
- Line 11592  resource. Expects the local filesystem p
+ Line 15908  resource. Expects the local filesystem p
  =item *
- EXT($varname,$symb,$udom,$uname) : evaluates and returns the value of
+ EXT($varname,$symb,$udom,$uname,$usection,$recurse,$cid) : evaluates
- a vairety of different possible values, $varname should be a request
+ and returns the value of a variety of different possible values,
- string, and the other parameters can be used to specify who and what
+ $varname should be a request string, and the other parameters can be
- one is asking about.
+ used to specify who and what one is asking about. Ordinarily, $cid
+ does not need to be specified, as it is retrived from
+ $env{'request.course.id'}, but &Apache::lonnet::EXT() is called
+ within lonuserstate::loadmap() when initializing a course, before
+ $env{'request.course.id'} has been set, so it needs to be provided
+ in that one case.
  Possible values for $varname are environment.lastname (or other item
  from the envirnment hash), user.name (or someother aspect about the
- Line 11628  will be stored for query
+ Line 15949  will be stored for query
  =item *
- symbread($filename) : return symbolic list entry (filename argument optional);
+ symbread($filename,$donotrecurse,$ignorecachednull,$checkforblock,$possibles) :
+ return symbolic list entry (all arguments optional).
+ Args: filename is the filename (including path) for the file for which a symb
+ is required; donotrecurse, if true will prevent calls to allowed() being made
+ to check access status if more than one resource was found in the bighash
+ (see rev. 1.249) to avoid an infinite loop if an ambiguous resource is part of
+ a randompick); ignorecachednull, if true will prevent a symb of '' being
+ returned if $env{$cache_str} is defined as ''; checkforblock if true will
+ cause possible symbs to be checked to determine if they are subject to content
+ blocking, if so they will not be included as possible symbs; possibles is a
+ ref to a hash, which, as a side effect, will be populated with all possible
+ symbs (content blocking not tested).
  returns the data handle
  =item *
- symbverify($symb,$thisfn) : verifies that $symb actually exists and is
+ symbverify($symb,$thisfn,$encstate) : verifies that $symb actually exists
- a possible symb for the URL in $thisfn, and if is an encryypted
+ and is a possible symb for the URL in $thisfn, and if is an encrypted
  resource that the user accessed using /enc/ returns a 1 on success, 0
- on failure, user must be in a course, as it assumes the existance of
+ on failure, user must be in a course, as it assumes the existence of
- the course initial hash, and uses $env('request.course.id'}
+ the course initial hash, and uses $env('request.course.id'}.  The third
+ arg is an optional reference to a scalar.  If this arg is passed in the
+ call to symbverify, it will be set to 1 if the symb has been set to be
+ encrypted; otherwise it will be null.
  =item *
- Line 11691  expirespread($uname,$udom,$stype,$usymb)
+ Line 16027  expirespread($uname,$udom,$stype,$usymb)
  devalidate($symb) : devalidate temporary spreadsheet calculations,
  forcing spreadsheet to reevaluate the resource scores next time.
+ =item *
+ can_edit_resource($file,$cnum,$cdom,$resurl,$symb,$group) : determine if current user can edit a particular resource,
+ when viewing in course context.
+  input: six args -- filename (decluttered), course number, course domain,
+                     url, symb (if registered) and group (if this is a
+                     group item -- e.g., bulletin board, group page etc.).
+  output: array of five scalars --
+          $cfile -- url for file editing if editable on current server
+          $home -- homeserver of resource (i.e., for author if published,
+                                           or course if uploaded.).
+          $switchserver --  1 if server switch will be needed.
+          $forceedit -- 1 if icon/link should be to go to edit mode
+          $forceview -- 1 if icon/link should be to go to view mode
+ =item *
+ is_course_upload($file,$cnum,$cdom)
+ Used in course context to determine if current file was uploaded to
+ the course (i.e., would be found in /userfiles/docs on the course's
+ homeserver.
+   input: 3 args -- filename (decluttered), course number and course domain.
+   output: boolean -- 1 if file was uploaded.
  =back
  =head2 Storing/Retreiving Data
- Line 11699  forcing spreadsheet to reevaluate the re
+ Line 16063  forcing spreadsheet to reevaluate the re
  =item *
- store($storehash,$symb,$namespace,$udom,$uname) : stores hash permanently
+ store($storehash,$symb,$namespace,$udom,$uname,$laststore) : stores hash
- for this url; hashref needs to be given and should be a \%hashname; the
+ permanently for this url; hashref needs to be given and should be a \%hashname;
- remaining args aren't required and if they aren't passed or are '' they will
+ the remaining args aren't required and if they aren't passed or are '' they will
- be derived from the env
+ be derived from the env (with the exception of $laststore, which is an
+ optional arg used when a user's submission is stored in grading).
+ $laststore is $version=$timestamp, where $version is the most recent version
+ number retrieved for the corresponding $symb in the $namespace db file, and
+ $timestamp is the timestamp for that transaction (UNIX time).
+ $laststore is currently only passed when cstore() is called by
+ structuretags::finalize_storage().
  =item *
- cstore($storehash,$symb,$namespace,$udom,$uname) : same as store but
+ cstore($storehash,$symb,$namespace,$udom,$uname,$laststore) : same as store
- uses critical subroutine
+ but uses critical subroutine
  =item *
- Line 11730  $range should be either an integer '100'
+ Line 16100  $range should be either an integer '100'
  =item *
- putstore($namespace,$symb,$version,$storehash,$udomain,$uname) :
+ putstore($namespace,$symb,$version,$storehash,$udomain,$uname,$tolog) :
  replaces a &store() version of data with a replacement set of data
  for a particular resource in a namespace passed in the $storehash hash
- reference
+ reference. If $tolog is true, the transaction is logged in the courselog
+ with an action=PUTSTORE.
  =item *
- Line 11843  server ($udom and $uhome are optional)
+ Line 16214  server ($udom and $uhome are optional)
  =item *
- get_domain_defaults($target_domain) : returns hash with defaults for
+ get_domain_defaults($target_domain,$ignore_cache) : returns hash with defaults
- authentication and language in the domain. Keys are: auth_def, auth_arg_def,
+ for: authentication, language, quotas, timezone, date locale, and portal URL in
- lang_def; corresponsing values are authentication type (internal, krb4, krb5,
+ the target domain.
- 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
+ May also include additional key => value pairs for the following groups:
- (if available), or lastly from values in lonTabs/dns_domain,tab,
- or lonTabs/domain.tab.
+ =over
+ =item
+ disk quotas (MB allocated by default to portfolios and authoring spaces).
+ =over
+ =item defaultquota, authorquota
+ =back
+ =item
+ tools (availability of aboutme page, blog, webDAV access for authoring spaces,
+ portfolio for users).
+ =over
+ =item
+ aboutme, blog, webdav, portfolio
+ =back
+ =item
+ requestcourses: ability to request courses, and how requests are processed.
+ =over
+ =item
+ official, unofficial, community, textbook
+ =back
+ =item
+ inststatus: types of institutional affiliation, and order in which they are displayed.
+ =over
+ =item
+ inststatustypes, inststatusorder, inststatusguest
+ =back
+ =item
+ coursedefaults: can PDF forms can be created, default credits for courses, default quotas (MB)
+ for course's uploaded content.
+ =over
+ =item
+ canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota,
+ communityquota, textbookquota
+ =back
+ =item
+ usersessions: set options for hosting of your users in other domains, and hosting of users from other domains
+ on your servers.
+ =over
+ =item
+ remotesessions, hostedsessions
+ =back
+ =back
+ In cases where a domain coordinator has never used the "Set Domain Configuration"
+ utility to create a configuration.db file on a domain's primary library server
+ only the following domain defaults: auth_def, auth_arg_def, lang_def
+ -- corresponding values are authentication type (internal, krb4, krb5,
+ or localauth), initial password or a kerberos realm, language (e.g., en-us) --
+ will be available. Values are retrieved from cache (if current), unless the
+ optional $ignore_cache arg is true, or from domain's configuration.db (if available),
+ or lastly from values in lonTabs/dns_domain,tab, or lonTabs/domain.tab.
+ Typical usage:
- %domdefaults = &get_auth_defaults($target_domain);
+ %domdefaults = &get_domain_defaults($target_domain);
  =back
- Line 12076  filelocation except for hrefs
+ Line 16523  filelocation except for hrefs
  =item *
- declutter() : declutters URLs (remove docroot, beginning slashes, 'res' etc)
+ declutter() : declutters URLs -- remove beginning slashes, 'res' etc.
+ also removes beginning /home/httpd/html unless /priv/ follows it.
  =back
- Line 12126  userspace, probably shouldn't be called
+ Line 16574  userspace, probably shouldn't be called
    formname: same as for userfileupload()
    fname: filename (including subdirectories) for the file
    parser: if 'parse', will parse (html) file to extract references to objects, links etc.
+           if hashref, and context is scantron, will convert csv format to standard format
    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
- Line 12246  Internal notes:
+ Line 16695  Internal notes:
   Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays.
+ =item *
  modify_access_controls():
  Modifies access controls for a portfolio file
- Line 12263  Returns:
+ Line 16714  Returns:
 . reference to hash of any new or updated access controls.
 . reference to hash used to map incoming IDs to uniqueIDs assigned to control.
     key = integer (inbound ID)
     value = uniqueID
+ =item *
+ get_timebased_id():
+ Attempts to get a unique timestamp-based suffix for use with items added to a
+ course via the Course Editor (e.g., folders, composite pages,
+ group bulletin boards).
+ Args: (first three required; six others optional)
+. prefix (alphanumeric): of keys in hash, e.g., suppsequence, docspage,
+    docssequence, or name of group
+. keyid (alphanumeric): name of temporary locking key in hash,
+    e.g., num, boardids
+. namespace: name of gdbm file used to store suffixes already assigned;
+    file will be named nohist_namespace.db
+. cdom: domain of course; default is current course domain from %env
+. cnum: course number; default is current course number from %env
+. idtype: set to concat if an additional digit is to be appended to the
+    unix timestamp to form the suffix, if the plain timestamp is already
+    in use.  Default is to not do this, but simply increment the unix
+    timestamp by 1 until a unique key is obtained.
+. who: holder of locking key; defaults to user:domain for user.
+. locktries: number of attempts to obtain a lock (sleep of 1s before
+    retrying); default is 3.
+. maxtries: number of attempts to obtain a unique suffix; default is 20.
+ Returns:
+. suffix obtained (numeric)
+. result of deleting locking key (ok if deleted, or lock never obtained)
+. error: contains (localized) error message if an error occurred.
  =back

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

Removed from v.1.1144
changed lines
	Added in v.1.1172.2.146.2.9