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.1172.2.52 and 1.1511

-version 1.1172.2.52, 2014/06/25 18:44:10
+version 1.1511, 2023/06/02 01:20:29
  Line 71  delayed.
  package Apache::lonnet;
  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 Encode;
+ 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 91  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::LWPReq;
+ 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)
  {
      my $logid;
- Line 123  our @EXPORT = qw(%env);
+ Line 130  our @EXPORT = qw(%env);
  	$logid ++;
          my $now = time();
  	my $id=$now.'00000'.$$.'00000'.$logid;
-         my $logentry = {
+         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,
+                                   }
                         };
-         return &put('nohist_'.$hash_name,$logentry,$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 154  sub logthis {
+ Line 162  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 167  sub logperm {
+ Line 175  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 180  sub create_connection {
+ Line 188  sub create_connection {
  				     Type    => SOCK_STREAM,
  				     Timeout => 10);
      return 0 if (!$client);
-     print $client (join(':',$hostname,$lonid,&machine_ids($hostname))."\n");
+     print $client (join(':',$hostname,$lonid,&machine_ids($hostname),$loncaparevs{$lonid})."\n");
      my $result = <$client>;
      chomp($result);
      return 1 if ($result eq 'done');
- Line 225  sub get_server_distarch {
+ Line 233  sub get_server_distarch {
      return;
  }
+ sub get_servercerts_info {
+     my ($lonhost,$hostname,$context) = @_;
+     return if ($lonhost eq '');
+     if ($hostname eq '') {
+         $hostname = &hostname($lonhost);
+     }
+     return if ($hostname eq '');
+     my ($rep,$uselocal);
+     if ($context eq 'install') {
+         $uselocal = 1;
+     } elsif (grep { $_ eq $lonhost } &current_machine_ids()) {
+         $uselocal = 1;
+     }
+     if (($context ne 'cgi') && ($context ne 'install') && ($uselocal)) {
+         my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0];
+         if ($distro eq '') {
+             $uselocal = 0;
+         } elsif ($distro =~ /^(?:centos|redhat|scientific)(\d+)$/) {
+             if ($1 < 6) {
+                 $uselocal = 0;
+             }
+         }  elsif ($distro =~ /^(?:sles)(\d+)$/) {
+             if ($1 < 12) {
+                 $uselocal = 0;
+             }
+         }
+     }
+     if ($uselocal) {
+         $rep = LONCAPA::Lond::server_certs(\%perlvar,$lonhost,$hostname);
+     } else {
+         $rep=&reply('servercerts',$lonhost);
+     }
+     my ($result,%returnhash);
+     if (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') ||
+         ($rep eq 'unknown_cmd')) {
+         $result = $rep;
+     } else {
+         $result = 'ok';
+         my @pairs=split(/\&/,$rep);
+         foreach my $item (@pairs) {
+             my ($key,$value)=split(/=/,$item,2);
+             my $what = &unescape($key);
+             $returnhash{$what}=&thaw_unescape($value);
+         }
+     }
+     return ($result,\%returnhash);
+ }
  sub get_server_loncaparev {
      my ($dom,$lonhost,$ignore_cache,$caller) = @_;
      if (defined($lonhost)) {
- Line 259  sub get_server_loncaparev {
+ Line 315  sub get_server_loncaparev {
              $answer = &reply('serverloncaparev',$lonhost);
              if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) {
                  if ($caller eq 'loncron') {
-                     my $ua=new LWP::UserAgent;
+                     my $hostname = &hostname($lonhost);
-                     $ua->timeout(4);
                      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);
+                     my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,4,1);
                      unless ($response->is_error()) {
                          my $content = $response->content;
                          if ($content =~ /<p>VERSION\:\s*([\w.\-]+)<\/p>/) {
- Line 356  sub remote_devalidate_cache {
+ Line 411  sub remote_devalidate_cache {
      my $items;
      return unless (ref($cachekeys) eq 'ARRAY');
      my $cachestr = join('&',@{$cachekeys});
-     return &reply('devalidatecache:'.&escape($cachestr),$lonhost);
+     my $response = &reply('devalidatecache:'.&escape($cachestr),$lonhost);
+     return $response;
+ }
+ sub sign_lti {
+     my ($cdom,$cnum,$crsdef,$type,$context,$url,$ltinum,$keynum,$paramsref,$inforef) = @_;
+     my $chome;
+     if (&domain($cdom) ne '') {
+         if ($crsdef) {
+             $chome = &homeserver($cnum,$cdom);
+         } else {
+             $chome = &domain($cdom,'primary');
+         }
+     }
+     if ($cdom && $chome && ($chome ne 'no_host')) {
+         if ((ref($paramsref) eq 'HASH') &&
+             (ref($inforef) eq 'HASH')) {
+             my $rep;
+             if (grep { $_ eq $chome } &current_machine_ids()) {
+                 # domain information is hosted on this machine
+                 $rep =
+                     &LONCAPA::Lond::sign_lti_payload($cdom,$cnum,$crsdef,$type,
+                                                      $context,$url,$ltinum,$keynum,
+                                                      $perlvar{'lonVersion'},
+                                                      $paramsref,$inforef);
+                 if (ref($rep) eq 'HASH') {
+                     return ('ok',$rep);
+                 }
+             } else {
+                 my ($escurl,$params,$info);
+                 $escurl = &escape($url);
+                 if (ref($paramsref) eq 'HASH') {
+                     $params = &freeze_escape($paramsref);
+                 }
+                 if (ref($inforef) eq 'HASH') {
+                     $info = &freeze_escape($inforef);
+                 }
+                 $rep=&reply("encrypt:signlti:$cdom:$cnum:$crsdef:$type:$context:$escurl:$ltinum:$keynum:$params:$info",$chome);
+             }
+             if (($rep eq '') || ($rep =~ /^con_lost|error|no_such_host|unknown_cmd/i)) {
+                 return ();
+             } elsif (($inforef->{'respfmt'} eq 'to_post_body') ||
+                      ($inforef->{'respfmt'} eq 'to_authorization_header')) {
+                 return ('ok',$rep);
+             } else {
+                 my %returnhash;
+                 foreach my $item (split(/\&/,$rep)) {
+                     my ($name,$value)=split(/\=/,$item);
+                     $returnhash{&unescape($name)}=&thaw_unescape($value);
+                 }
+                 return('ok',\%returnhash);
+             }
+         } else {
+             return ();
+         }
+     } else {
+         return ();
+         &logthis("sign_lti failed - no homeserver and/or domain ($cdom) ($chome)");
+     }
  }
  # -------------------------------------------------- Non-critical communication
- Line 370  sub subreply {
+ Line 483  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 388  sub subreply {
+ Line 501  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 407  sub reply {
+ Line 520  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') ||
+                 ($subcmd eq 'put')) {
+                 (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') || ($subcmd eq 'put')) {
+                     splice(@rest,3,1,'Hidden');
+                 }
+                 $logged = join(':',('encrypt:'.$subcmd,@rest));
+             }
+         }
+         &logthis("<font color=\"blue\">WARNING:".
+                  " $logged to $server returned $answer</font>");
      }
      return $answer;
  }
- Line 417  sub reply {
+ Line 549  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 436  sub reconlonc {
+ Line 568  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) {
  	    &logthis("lonc at pid $loncpid responding, sending USR1");
              kill USR1 => $loncpid;
              sleep 1;
-          } else {
+         } else {
  	    &logthis(
                 "<font color=\"blue\">WARNING:".
                 " lonc at pid $loncpid not responding, giving up</font>");
- Line 464  sub critical {
+ Line 596  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 476  sub critical {
+ Line 608  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 601  sub transfer_profile_to_env {
+ Line 733  sub transfer_profile_to_env {
  # ---------------------------------------------------- Check for valid session
  sub check_for_valid_session {
-     my ($r,$name,$userhashref) = @_;
+     my ($r,$name,$userhashref,$domref) = @_;
      my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
-     if ($name eq '') {
+     my ($lonidsdir,$linkname,$pubname,$secure,$lonid);
-         $name = 'lonID';
-     }
-     my $lonid=$cookies{$name};
-     return undef if (!$lonid);
-     my $handle=&LONCAPA::clean_handle($lonid->value);
-     my $lonidsdir;
      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);
+     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") {
+         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;
      }
-     return undef if (!-e "$lonidsdir/$handle.id");
      my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
      return undef if (!$opened);
- Line 630  sub check_for_valid_session {
+ Line 792  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'};
+         }
+         $userhashref->{'lti'} = $disk_env{'request.lti.login'};
+         if ($userhashref->{'lti'}) {
+             $userhashref->{'ltitarget'} = $disk_env{'request.lti.target'};
+             $userhashref->{'ltiuri'} = $disk_env{'request.lti.uri'};
+         }
      }
+     untie(%disk_env);
      return $handle;
  }
- Line 661  sub timed_flock {
+ Line 833  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 686  sub appenv {
+ Line 889  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 811  sub userload {
+ Line 1017  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 828  sub userload {
+ Line 1035  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
                                                       :  $userloadpercent;
      my ($uint_dom,$remotesessions);
      if (($udom ne '') && (&domain($udom) ne '')) {
-         my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
+         my $uprimary_id = &domain($udom,'primary');
-         $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);
+         $uint_dom = &internet_dom($uprimary_id);
-         my %udomdefaults = &Apache::lonnet::get_domain_defaults($udom);
+         my %udomdefaults = &get_domain_defaults($udom);
          $remotesessions = $udomdefaults{'remotesessions'};
      }
      my $spareshash = &this_host_spares($udom);
      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 858  sub spareserver {
+ Line 1063  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 870  sub spareserver {
+ Line 1073  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 = &use_proxy_alias($r,$spare_server);
+                 $hostname = $alias if ($alias ne '');
  	        $spare_server = $protocol.'://'.$hostname;
              }
          }
- Line 943  sub find_existing_session {
+ Line 1148  sub find_existing_session {
      return;
  }
+ sub delusersession {
+     my ($lonid,$udom,$uname) = @_;
+     my $uprimary_id = &domain($udom,'primary');
+     my $uintdom = &internet_dom($uprimary_id);
+     my $intdom = &internet_dom($lonid);
+     my $serverhomedom = &host_domain($lonid);
+     if (($uintdom ne '') && ($uintdom eq $intdom)) {
+         return &reply(join(':','delusersession',
+                             map {&escape($_)} ($udom,$uname)),$lonid);
+     }
+     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 966  sub choose_server {
+ Line 1268  sub choose_server {
          unless (defined($cached)) {
              my $cachetime = 60*60*24;
              my %domconfig =
-                 &Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom);
+                 &get_dom('configuration',['loadbalancing'],$udom);
              if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
                  $balancers = &do_cache_new('loadbalancing',$udom,$domconfig{'loadbalancing'},
                                             $cachetime);
- Line 974  sub choose_server {
+ Line 1276  sub choose_server {
          }
      }
      foreach my $lonhost (keys(%servers)) {
-         my $loginvia;
          if ($skiploadbal) {
              if (ref($balancers) eq 'HASH') {
                  next if (exists($balancers->{$lonhost}));
              }
          }
+         my $loginvia;
          if ($checkloginvia) {
              $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};
              if ($loginvia) {
- Line 1006  sub choose_server {
+ Line 1308  sub choose_server {
      if ($login_host ne '') {
          $hostname = &hostname($login_host);
      }
-     return ($login_host,$hostname,$portal_path,$isredirect);
+     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 1044  sub changepass {
+ Line 1368  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 1053  sub changepass {
+ Line 1380  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 1102  sub authenticate {
+ Line 1429  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;
-     my $host_idn = &Apache::lonnet::internet_dom($lonhost);
+     my $host_idn = &internet_dom($lonhost);
      if (ref($remotesessions) eq 'HASH') {
          if (ref($remotesessions->{'excludedomain'}) eq 'ARRAY') {
              if (grep(/^\Q$host_idn\E$/,@{$remotesessions->{'excludedomain'}})) {
- Line 1147  sub can_host_session {
+ Line 1497  sub can_host_session {
      }
      if ($canhost) {
          if (ref($hostedsessions) eq 'HASH') {
-             my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
+             my $uprimary_id = &domain($udom,'primary');
-             my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);
+             my $uint_dom = &internet_dom($uprimary_id);
              if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') {
                  if (($uint_dom ne '') &&
                      (grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'excludedomain'}}))) {
- Line 1173  sub can_host_session {
+ Line 1523  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;
+         }
+     }
+     if ($canhost) {
+         if (ref($defdomdefaults{'offloadoth'}) eq 'HASH') {
+             if ($defdomdefaults{'offloadoth'}{$try_server}) {
+                 unless (&shared_institution($udom,$try_server)) {
+                     $canhost = 0;
+                 }
+             }
+         }
      }
-     unless (grep(/^\Q$uint_dom\E$/,@intdoms)) {
+     if (($canhost) && ($uint_dom)) {
-         my $serverhomeID = &Apache::lonnet::get_server_homeID($try_server);
+         my @intdoms;
-         my $serverhomedom = &Apache::lonnet::host_domain($serverhomeID);
+         my $internet_names = &get_internet_names($try_server);
-         my %defdomdefaults = &Apache::lonnet::get_domain_defaults($serverhomedom);
+         if (ref($internet_names) eq 'ARRAY') {
-         my $remoterev = &Apache::lonnet::get_server_loncaparev(undef,$try_server);
+             @intdoms = @{$internet_names};
-         $canhost = &can_host_session($udom,$try_server,$remoterev,
+         }
-                                      $remotesessions,
+         unless (grep(/^\Q$uint_dom\E$/,@intdoms)) {
-                                      $defdomdefaults{'hostedsessions'});
+             my $remoterev = &get_server_loncaparev(undef,$try_server);
+             $canhost = &can_host_session($udom,$try_server,$remoterev,
+                                          $remotesessions,
+                                          $defdomdefaults{'hostedsessions'});
+         }
      }
      return $canhost;
  }
- Line 1223  sub spares_for_offload  {
+ Line 1590  sub spares_for_offload  {
      } else {
          my $cachetime = 60*60*24;
          my %domconfig =
-             &Apache::lonnet::get_dom('configuration',['usersessions'],$dom_in_use);
+             &get_dom('configuration',['usersessions'],$dom_in_use);
          if (ref($domconfig{'usersessions'}) eq 'HASH') {
              if (ref($domconfig{'usersessions'}{'spares'}) eq 'HASH') {
                  if (ref($domconfig{'usersessions'}{'spares'}{$lonhost_in_use}) eq 'HASH') {
- Line 1270  sub get_lonbalancer_config {
+ Line 1637  sub get_lonbalancer_config {
  }
  sub check_loadbalancing {
-     my ($uname,$udom) = @_;
+     my ($uname,$udom,$caller) = @_;
      my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom,
-         $rule_in_effect,$offloadto,$otherserver);
+         $rule_in_effect,$offloadto,$otherserver,$setcookie,$dom_balancers);
      my $lonhost = $perlvar{'lonHostID'};
      my @hosts = &current_machine_ids();
-     my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
+     my $uprimary_id = &domain($udom,'primary');
-     my $uintdom = &Apache::lonnet::internet_dom($uprimary_id);
+     my $uintdom = &internet_dom($uprimary_id);
-     my $intdom = &Apache::lonnet::internet_dom($lonhost);
+     my $intdom = &internet_dom($lonhost);
      my $serverhomedom = &host_domain($lonhost);
+     my $domneedscache;
      my $cachetime = 60*60*24;
      if (($uintdom ne '') && ($uintdom eq $intdom)) {
- Line 1291  sub check_loadbalancing {
+ Line 1658  sub check_loadbalancing {
      my ($result,$cached)=&is_cached_new('loadbalancing',$dom_in_use);
      unless (defined($cached)) {
          my %domconfig =
-             &Apache::lonnet::get_dom('configuration',['loadbalancing'],$dom_in_use);
+             &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') {
-         ($is_balancer,$currtargets,$currrules) =
+         ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers) =
              &check_balancer_result($result,@hosts);
          if ($is_balancer) {
              if (ref($currrules) eq 'HASH') {
- Line 1350  sub check_loadbalancing {
+ Line 1719  sub check_loadbalancing {
          ($result,$cached)=&is_cached_new('loadbalancing',$serverhomedom);
          unless (defined($cached)) {
              my %domconfig =
-                 &Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom);
+                 &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') {
-             ($is_balancer,$currtargets,$currrules) =
+             ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers) =
                  &check_balancer_result($result,@hosts);
              if ($is_balancer) {
                  if (ref($currrules) eq 'HASH') {
- Line 1372  sub check_loadbalancing {
+ Line 1743  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;
+         }
+     }
+     if ($domneedscache) {
+         &do_cache_new('loadbalancing',$domneedscache,$is_balancer,$cachetime);
      }
-     if ($is_balancer) {
+     if (($is_balancer) && ($caller ne 'switchserver')) {
          my $lowest_load = 30000;
          if (ref($offloadto) eq 'HASH') {
              if (ref($offloadto->{'primary'}) eq 'ARRAY') {
- Line 1408  sub check_loadbalancing {
+ Line 1788  sub check_loadbalancing {
                  }
              }
          }
-         if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) {
+         unless ($caller eq 'login') {
-             $is_balancer = 0;
+             if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) {
-             if ($uname ne '' && $udom ne '') {
+                 $is_balancer = 0;
-                 if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {
+                 if ($uname ne '' && $udom ne '') {
+                     if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {
-                     &appenv({'user.loadbalexempt'     => $lonhost,
+                         &appenv({'user.loadbalexempt'     => $lonhost,
-                              'user.loadbalcheck.time' => time});
+                                  'user.loadbalcheck.time' => time});
+                     }
                  }
              }
          }
      }
-     return ($is_balancer,$otherserver);
+     if (($is_balancer) && (!$homeintdom)) {
+         undef($setcookie);
+     }
+     return ($is_balancer,$otherserver,$setcookie,$offloadto,$dom_balancers);
  }
  sub check_balancer_result {
      my ($result,@hosts) = @_;
-     my ($is_balancer,$currtargets,$currrules);
+     my ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers);
      if (ref($result) eq 'HASH') {
          if ($result->{'lonhost'} ne '') {
              my $currbalancer = $result->{'lonhost'};
- Line 1433  sub check_balancer_result {
+ Line 1817  sub check_balancer_result {
                  $currtargets = $result->{'targets'};
                  $currrules = $result->{'rules'};
              }
+             $dom_balancers = $currbalancer;
          } else {
-             foreach my $key (keys(%{$result})) {
+             if (keys(%{$result})) {
-                 if (($key ne '') && (grep(/^\Q$key\E$/,@hosts)) &&
+                 foreach my $key (keys(%{$result})) {
-                     (ref($result->{$key}) eq 'HASH')) {
+                     if (($key ne '') && (grep(/^\Q$key\E$/,@hosts)) &&
-                     $is_balancer = 1;
+                         (ref($result->{$key}) eq 'HASH')) {
-                     $currrules = $result->{$key}{'rules'};
+                         $is_balancer = 1;
-                     $currtargets = $result->{$key}{'targets'};
+                         $currrules = $result->{$key}{'rules'};
-                     last;
+                         $currtargets = $result->{$key}{'targets'};
+                         $setcookie = $result->{$key}{'cookie'};
+                         last;
+                     }
                  }
+                 $dom_balancers = join(',',sort(keys(%{$result})));
              }
          }
      }
-     return ($is_balancer,$currtargets,$currrules);
+     return ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers);
  }
  sub get_loadbalancer_targets {
- Line 1463  sub get_loadbalancer_targets {
+ Line 1852  sub get_loadbalancer_targets {
              }
          } elsif ($rule_in_effect eq 'externalbalancer') {
              my %domconfig =
-                 &Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom);
+                 &get_dom('configuration',['loadbalancing'],$udom);
              if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
                  if ($domconfig{'loadbalancing'}{'lonhost'} ne '') {
                      if (&hostname($domconfig{'loadbalancing'}{'lonhost'}) ne '') {
- Line 1517  sub internet_dom_servers {
+ Line 1906  sub internet_dom_servers {
      return %uniqservers;
  }
+ sub trusted_domains {
+     my ($cmdtype,$calldom) = @_;
+     my ($trusted,$untrusted);
+     if (&domain($calldom) eq '') {
+         return ($trusted,$untrusted);
+     }
+     unless ($cmdtype =~ /^(content|shared|enroll|coaurem|othcoau|domroles|catalog|reqcrs|msg)$/) {
+         return ($trusted,$untrusted);
+     }
+     my $callprimary = &domain($calldom,'primary');
+     my $intcalldom = &internet_dom($callprimary);
+     if ($intcalldom eq '') {
+         return ($trusted,$untrusted);
+     }
+     my ($trustconfig,$cached)=&is_cached_new('trust',$calldom);
+     unless (defined($cached)) {
+         my %domconfig = &get_dom('configuration',['trust'],$calldom);
+         &do_cache_new('trust',$calldom,$domconfig{'trust'},3600);
+         $trustconfig = $domconfig{'trust'};
+     }
+     if (ref($trustconfig)) {
+         my (%possexc,%possinc,@allexc,@allinc);
+         if (ref($trustconfig->{$cmdtype}) eq 'HASH') {
+             if (ref($trustconfig->{$cmdtype}->{'exc'}) eq 'ARRAY') {
+                 map { $possexc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'exc'}};
+             }
+             if (ref($trustconfig->{$cmdtype}->{'inc'}) eq 'ARRAY') {
+                 $possinc{$intcalldom} = 1;
+                 map { $possinc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'inc'}};
+             }
+         }
+         if (keys(%possexc)) {
+             if (keys(%possinc)) {
+                 foreach my $key (sort(keys(%possexc))) {
+                     next if ($key eq $intcalldom);
+                     unless ($possinc{$key}) {
+                         push(@allexc,$key);
+                     }
+                 }
+             } else {
+                 @allexc = sort(keys(%possexc));
+             }
+         }
+         if (keys(%possinc)) {
+             $possinc{$intcalldom} = 1;
+             @allinc = sort(keys(%possinc));
+         }
+         if ((@allexc > 0) || (@allinc > 0)) {
+             my %doms_by_intdom;
+             my %allintdoms = &all_host_intdom();
+             my %alldoms = &all_host_domain();
+             foreach my $key (%allintdoms) {
+                 if (ref($doms_by_intdom{$allintdoms{$key}}) eq 'ARRAY') {
+                     unless (grep(/^\Q$alldoms{$key}\E$/,@{$doms_by_intdom{$allintdoms{$key}}})) {
+                         push(@{$doms_by_intdom{$allintdoms{$key}}},$alldoms{$key});
+                     }
+                 } else {
+                     $doms_by_intdom{$allintdoms{$key}} = [$alldoms{$key}];
+                 }
+             }
+             foreach my $exc (@allexc) {
+                 if (ref($doms_by_intdom{$exc}) eq 'ARRAY') {
+                     push(@{$untrusted},@{$doms_by_intdom{$exc}});
+                 }
+             }
+             foreach my $inc (@allinc) {
+                 if (ref($doms_by_intdom{$inc}) eq 'ARRAY') {
+                     push(@{$trusted},@{$doms_by_intdom{$inc}});
+                 }
+             }
+         }
+     }
+     return ($trusted,$untrusted);
+ }
+ sub will_trust {
+     my ($cmdtype,$domain,$possdom) = @_;
+     return 1 if ($domain eq $possdom);
+     my ($trustedref,$untrustedref) = &trusted_domains($cmdtype,$possdom);
+     my $willtrust;
+     if ((ref($trustedref) eq 'ARRAY') && (@{$trustedref} > 0)) {
+         if (grep(/^\Q$domain\E$/,@{$trustedref})) {
+             $willtrust = 1;
+         }
+     } elsif ((ref($untrustedref) eq 'ARRAY') && (@{$untrustedref} > 0)) {
+         unless (grep(/^\Q$domain\E$/,@{$untrustedref})) {
+             $willtrust = 1;
+         }
+     } else {
+         $willtrust = 1;
+     }
+     return $willtrust;
+ }
  # ---------------------- Find the homebase for a user from domain's lib servers
  my %homecache;
- Line 1542  sub homeserver {
+ Line 2026  sub homeserver {
      return 'no_host';
  }
- # ------------------------------------- Find the usernames behind a list of IDs
+ # ----- Find the usernames behind a list of student/employee IDs or clicker IDs
  sub idget {
-     my ($udom,@ids)=@_;
+     my ($udom,$idsref,$namespace)=@_;
      my %returnhash=();
+     my @ids=();
+     if (ref($idsref) eq 'ARRAY') {
+         @ids = @{$idsref};
+     } else {
+         return %returnhash;
+     }
+     if ($namespace eq '') {
+         $namespace = 'ids';
+     }
      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/;
+ 	if ($namespace eq 'ids') {
- 	my $reply=&reply("idget:$udom:".$idlist,$tryserver);
+ 	    $idlist=~tr/A-Z/a-z/;
+ 	}
+ 	my $reply;
+ 	if ($namespace eq 'ids') {
+ 	    $reply=&reply("idget:$udom:".$idlist,$tryserver);
+ 	} else {
+ 	    $reply=&reply("getdom:$udom:$namespace:$idlist",$tryserver);
+ 	}
  	my @answer=();
  	if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {
  	    @answer=split(/\&/,$reply);
- Line 1560  sub idget {
+ Line 2060  sub idget {
  	my $i;
  	for ($i=0;$i<=$#ids;$i++) {
  	    if ($answer[$i]) {
- 		$returnhash{$ids[$i]}=$answer[$i];
+ 		$returnhash{$ids[$i]}=&unescape($answer[$i]);
  	    }
  	}
      }
      return %returnhash;
  }
- Line 1578  sub idrget {
+ Line 2078  sub idrget {
      return %returnhash;
  }
- # ------------------------------- Store away a list of names and associated IDs
+ # Store away a list of names and associated student/employee IDs or clicker IDs
  sub idput {
-     my ($udom,%ids)=@_;
+     my ($udom,$idsref,$uhom,$namespace)=@_;
      my %servers=();
+     my %ids=();
+     my %byid = ();
+     if (ref($idsref) eq 'HASH') {
+         %ids=%{$idsref};
+     }
+     if ($namespace eq '') {
+         $namespace = 'ids';
+     }
      foreach my $uname (keys(%ids)) {
  	&cput('environment',{'id'=>$ids{$uname}},$udom,$uname);
-         my $uhom=&homeserver($uname,$udom);
+         if ($uhom eq '') {
+             $uhom=&homeserver($uname,$udom);
+         }
          if ($uhom ne 'no_host') {
-             my $id=&escape($ids{$uname});
-             $id=~tr/A-Z/a-z/;
              my $esc_unam=&escape($uname);
- 	    if ($servers{$uhom}) {
+             if ($namespace eq 'ids') {
- 		$servers{$uhom}.='&'.$id.'='.$esc_unam;
+                 my $id=&escape($ids{$uname});
+                 $id=~tr/A-Z/a-z/;
+                 my $esc_unam=&escape($uname);
+                 $servers{$uhom}.=$id.'='.$esc_unam.'&';
              } else {
-                 $servers{$uhom}=$id.'='.$esc_unam;
+                 my @currids = split(/,/,$ids{$uname});
+                 foreach my $id (@currids) {
+                     $byid{$uhom}{$id} .= $uname.',';
+                 }
+             }
+         }
+     }
+     if ($namespace eq 'clickers') {
+         foreach my $server (keys(%byid)) {
+             if (ref($byid{$server}) eq 'HASH') {
+                 foreach my $id (keys(%{$byid{$server}})) {
+                     $byid{$server} =~ s/,$//;
+                     $servers{$uhom}.=&escape($id).'='.&escape($byid{$server}).'&';
+                 }
              }
          }
      }
      foreach my $server (keys(%servers)) {
-         &critical('idput:'.$udom.':'.$servers{$server},$server);
+         $servers{$server} =~ s/\&$//;
+         if ($namespace eq 'ids') {
+             &critical('idput:'.$udom.':'.$servers{$server},$server);
+         } else {
+             &critical('updateclickers:'.$udom.':add:'.$servers{$server},$server);
+         }
      }
  }
- # ---------------------------------------- Delete unwanted IDs from ids.db file
+ # ------------- Delete unwanted student/employee IDs or clicker IDs from domain
  sub iddel {
-     my ($udom,$idshashref,$uhome)=@_;
+     my ($udom,$idshashref,$uhome,$namespace)=@_;
      my %result=();
-     unless (ref($idshashref) eq 'HASH') {
+     my %ids=();
+     my %byid = ();
+     if (ref($idshashref) eq 'HASH') {
+         %ids=%{$idshashref};
+     } else {
          return %result;
      }
+     if ($namespace eq '') {
+         $namespace = 'ids';
+     }
      my %servers=();
-     while (my ($id,$uname) = each(%{$idshashref})) {
+     while (my ($id,$unamestr) = each(%ids)) {
-         my $uhom;
+         if ($namespace eq 'ids') {
-         if ($uhome) {
+             my $uhom = $uhome;
-             $uhom = $uhome;
+             if ($uhom eq '') {
-         } else {
+                 $uhom=&homeserver($unamestr,$udom);
-             $uhom=&homeserver($uname,$udom);
+             }
-         }
+             if ($uhom ne 'no_host') {
-         if ($uhom ne 'no_host') {
-             if ($servers{$uhom}) {
                  $servers{$uhom}.='&'.&escape($id);
-             } else {
+             }
-                 $servers{$uhom}=&escape($id);
+          } else {
+             my @curritems = split(/,/,$ids{$id});
+             foreach my $uname (@curritems) {
+                 my $uhom = $uhome;
+                 if ($uhom eq '') {
+                     $uhom=&homeserver($uname,$udom);
+                 }
+                 if ($uhom ne 'no_host') {
+                     $byid{$uhom}{$id} .= $uname.',';
+                 }
+             }
+         }
+     }
+     if ($namespace eq 'clickers') {
+         foreach my $server (keys(%byid)) {
+             if (ref($byid{$server}) eq 'HASH') {
+                 foreach my $id (keys(%{$byid{$server}})) {
+                     $byid{$server}{$id} =~ s/,$//;
+                     $servers{$server}.=&escape($id).'='.&escape($byid{$server}{$id}).'&';
+                 }
              }
          }
      }
      foreach my $server (keys(%servers)) {
-         $result{$server} = &critical('iddel:'.$udom.':'.$servers{$server},$uhome);
+         $servers{$server} =~ s/\&$//;
+         if ($namespace eq 'ids') {
+             $result{$server} = &critical('iddel:'.$udom.':'.$servers{$server},$uhome);
+         } elsif ($namespace eq 'clickers') {
+             $result{$server} = &critical('updateclickers:'.$udom.':del:'.$servers{$server},$server);
+         }
      }
      return %result;
  }
+ # ----- Update clicker ID-to-username look-ups in clickers.db on library server
+ sub updateclickers {
+     my ($udom,$action,$idshashref,$uhome,$critical) = @_;
+     my %clickers;
+     if (ref($idshashref) eq 'HASH') {
+         %clickers=%{$idshashref};
+     } else {
+         return;
+     }
+     my $items='';
+     foreach my $item (keys(%clickers)) {
+         $items.=&escape($item).'='.&escape($clickers{$item}).'&';
+     }
+     $items=~s/\&$//;
+     my $request = "updateclickers:$udom:$action:$items";
+     if ($critical) {
+         return &critical($request,$uhome);
+     } else {
+         return &reply($request,$uhome);
+     }
+ }
  # ------------------------------dump from db file owned by domainconfig user
  sub dump_dom {
      my ($namespace, $udom, $regexp) = @_;
- Line 1646  sub dump_dom {
+ Line 2227  sub dump_dom {
  # ------------------------------------------ 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 1654  sub get_dom {
+ Line 2236  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 1667  sub get_dom {
+ Line 2250  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 1690  sub get_dom {
+ Line 2283  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 1711  sub put_dom {
+ Line 2304  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 1745  sub del_dom {
+ Line 2342  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 1754  sub get_domainconfiguser {
+ Line 2402  sub get_domainconfiguser {
  sub retrieve_inst_usertypes {
      my ($udom) = @_;
      my (%returnhash,@order);
-     my %domdefs = &Apache::lonnet::get_domain_defaults($udom);
+     my %domdefs = &get_domain_defaults($udom);
      if ((ref($domdefs{'inststatustypes'}) eq 'HASH') &&
          (ref($domdefs{'inststatusorder'}) eq 'ARRAY')) {
          return ($domdefs{'inststatustypes'},$domdefs{'inststatusorder'});
- Line 1787  sub retrieve_inst_usertypes {
+ Line 2435  sub retrieve_inst_usertypes {
  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 1802  sub inst_directory_query {
+ Line 2450  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) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
+                 if (($major eq '' && $minor eq '') || ($major < 2) ||
+                     (($major == 2) && ($minor < 12))) {
+                     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 1843  sub usersearch {
+ Line 2501  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) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
+                     next if (($major eq '' && $minor eq '') || ($major < 2) ||
+                              (($major == 2) && ($minor < 12)));
+                 }
+             }
              my $host=&hostname($tryserver);
              my $queryid=
                  &reply("querysend:".&escape($query).':'.
- Line 1928  sub get_instuser {
+ Line 2594  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 1950  sub inst_rulecheck {
+ Line 2673  sub inst_rulecheck {
                      $response=&unescape(&reply('instselfcreatecheck:'.
                                                 &escape($udom).':'.&escape($uname).
                                                ':'.$rulestr,$homeserver));
+                 } elsif ($item eq 'unamemap') {
+                     $response=&unescape(&reply('instunamemapcheck:'.
+                                                &escape($udom).':'.&escape($uname).
+                                               ':'.$rulestr,$homeserver));
                  }
                  if ($response ne 'refused') {
                      my @pairs=split(/\&/,$response);
- Line 1979  sub inst_userrules {
+ Line 2706  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 2020  sub get_domain_defaults {
+ Line 2750  sub get_domain_defaults {
      }
      my %domdefaults;
      my %domconfig =
-          &Apache::lonnet::get_dom('configuration',['defaults','quotas',
+          &get_dom('configuration',['defaults','quotas',
                                    'requestcourses','inststatus',
                                    'coursedefaults','usersessions',
                                    'requestauthor','selfenrollment',
-                                   'coursecategories'],$domain);
+                                   'coursecategories','ssl','autoenroll',
-     my @coursetypes = ('official','unofficial','community','textbook');
+                                   'trust','helpsettings','wafproxy',
+                                   'ltisec','toolsec','domexttool',
+                                   'exttool'],$domain);
+     my @coursetypes = ('official','unofficial','community','textbook','placement');
      if (ref($domconfig{'defaults'}) eq 'HASH') {
          $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};
          $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
- Line 2033  sub get_domain_defaults {
+ Line 2766  sub get_domain_defaults {
          $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};
          $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};
          $domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'};
+         $domdefaults{'portal_def_email'} = $domconfig{'defaults'}{'portal_def_email'};
+         $domdefaults{'portal_def_web'} = $domconfig{'defaults'}{'portal_def_web'};
+         $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 2055  sub get_domain_defaults {
+ Line 2794  sub get_domain_defaults {
          }
      }
      if (ref($domconfig{'requestcourses'}) eq 'HASH') {
-         foreach my $item ('official','unofficial','community','textbook') {
+         foreach my $item ('official','unofficial','community','textbook','placement') {
              $domdefaults{$item} = $domconfig{'requestcourses'}{$item};
          }
      }
- Line 2068  sub get_domain_defaults {
+ Line 2807  sub get_domain_defaults {
          }
      }
      if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
+         $domdefaults{'canuse_pdfforms'} = $domconfig{'coursedefaults'}{'canuse_pdfforms'};
+         $domdefaults{'usejsme'} = $domconfig{'coursedefaults'}{'usejsme'};
+         $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') {
- Line 2077  sub get_domain_defaults {
+ Line 2823  sub get_domain_defaults {
              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'}{'domexttool'}) eq 'HASH') {
+                 $domdefaults{$type.'domexttool'} = $domconfig{'coursedefaults'}{'domexttool'}{$type};
+             } else {
+                 $domdefaults{$type.'domexttool'} = 1;
+             }
+             if (ref($domconfig{'coursedefaults'}{'exttool'}) eq 'HASH') {
+                 $domdefaults{$type.'exttool'} = $domconfig{'coursedefaults'}{'exttool'}{$type};
+             } else {
+                 $domdefaults{$type.'exttool'} = 0;
+             }
+         }
+         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 2086  sub get_domain_defaults {
+ Line 2864  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') {
- Line 2125  sub get_domain_defaults {
+ Line 2909  sub get_domain_defaults {
              $domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'};
          }
      }
+     if (ref($domconfig{'ssl'}) eq 'HASH') {
+         if (ref($domconfig{'ssl'}{'replication'}) eq 'HASH') {
+             $domdefaults{'replication'} = $domconfig{'ssl'}{'replication'};
+         }
+         if (ref($domconfig{'ssl'}{'connto'}) eq 'HASH') {
+             $domdefaults{'connect'} = $domconfig{'ssl'}{'connto'};
+         }
+         if (ref($domconfig{'ssl'}{'connfrom'}) eq 'HASH') {
+             $domdefaults{'connect'} = $domconfig{'ssl'}{'connfrom'};
+         }
+     }
+     if (ref($domconfig{'trust'}) eq 'HASH') {
+         my @prefixes = qw(content shared enroll othcoau coaurem domroles catalog reqcrs msg);
+         foreach my $prefix (@prefixes) {
+             if (ref($domconfig{'trust'}{$prefix}) eq 'HASH') {
+                 $domdefaults{'trust'.$prefix} = $domconfig{'trust'}{$prefix};
+             }
+         }
+     }
+     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'};
+         }
+     }
+     if (ref($domconfig{'wafproxy'}) eq 'HASH') {
+         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{'ltiprivhosts'} = $domconfig{'ltisec'}{'private'}{'keys'};
+             }
+         }
+     }
+     if (ref($domconfig{'toolsec'}) eq 'HASH') {
+         if (ref($domconfig{'toolsec'}{'encrypt'}) eq 'HASH') {
+             $domdefaults{'toolenc_crs'} = $domconfig{'toolsec'}{'encrypt'}{'crs'};
+             $domdefaults{'toolenc_dom'} = $domconfig{'toolsec'}{'encrypt'}{'dom'};
+         }
+         if (ref($domconfig{'toolsec'}{'private'}) eq 'HASH') {
+             if (ref($domconfig{'toolsec'}{'private'}{'keys'}) eq 'ARRAY') {
+                 $domdefaults{'toolprivhosts'} = $domconfig{'toolsec'}{'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 = {};
+         }
+         &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 = {
+                                 totcodes => $totcodes,
+                                 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;
+ }
+ 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 = &use_proxy_alias($r,$chome);
+         $hostname = $alias if ($alias ne '');
+         $firsturl = $protocol.'://'.$hostname;
+     }
+     return $firsturl;
+ }
+ sub url_prefix {
+     my ($r,$dom,$home,$context) = @_;
+     my $prefix;
+     my %domdefs = &get_domain_defaults($dom);
+     if ($domdefs{'portal_def'} && $domdefs{'portal_def_'.$context}) {
+         if ($domdefs{'portal_def'} =~ m{^(https?://[^/]+)}) {
+             $prefix = $1;
+         }
+     }
+     if ($prefix eq '') {
+         my $hostname = &hostname($home);
+         my $protocol = $protocol{$home};
+         $protocol = 'http' if ($protocol{$home} ne 'https');
+         my $alias = &use_proxy_alias($r,$home);
+         $hostname = $alias if ($alias ne '');
+         $prefix = $protocol.'://'.$hostname;
+     }
+     return $prefix;
+ }
+ # --------------------------------------------- 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;
+ }
  # --------------------------------------------------- Assign a key to a student
  sub assign_access_key {
- Line 2277  sub courseid_to_courseurl {
+ Line 3241  sub courseid_to_courseurl {
  	return "/$cdom/$cnum";
      }
-     my %courseinfo=&Apache::lonnet::coursedescription($courseid);
+     my %courseinfo=&coursedescription($courseid);
      if (exists($courseinfo{'num'})) {
  	return "/$courseinfo{'domain'}/$courseinfo{'num'}";
      }
- Line 2365  sub make_key {
+ Line 3329  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) whenever possible
-     if (exists($remembered{$id})) {
+     if (exists($remembered{$remembered_id})) {
- 	if ($debug) { &Apache::lonnet::logthis("Early return $id of $remembered{$id} "); }
+ 	if ($debug) { &Apache::lonnet::logthis("Early return $remembered_id of $remembered{$remembered_id} "); }
- 	$accessed{$id}=[&gettimeofday()];
+ 	$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 2389  sub is_cached_new {
+ Line 3355  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 2411  sub do_cache_new {
+ Line 3378  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 2472  sub userenvironment {
+ Line 3439  sub userenvironment {
  # ---------------------------------------------------------- Get a studentphoto
  sub studentphoto {
      my ($udom,$unam,$ext) = @_;
-     my $home=&Apache::lonnet::homeserver($unam,$udom);
+     my $home=&homeserver($unam,$udom);
      if (defined($env{'request.course.id'})) {
          if ($env{'course.'.$env{'request.course.id'}.'.internal.showphoto'}) {
              if ($udom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) {
                  return(&retrievestudentphoto($udom,$unam,$ext));
              } else {
                  my ($result,$perm_reqd)=
- 		    &Apache::lonnet::auto_photo_permission($unam,$udom);
+ 		    &auto_photo_permission($unam,$udom);
                  if ($result eq 'ok') {
                      if (!($perm_reqd eq 'yes')) {
                          return(&retrievestudentphoto($udom,$unam,$ext));
- Line 2489  sub studentphoto {
+ Line 3456  sub studentphoto {
          }
      } else {
          my ($result,$perm_reqd) =
- 	    &Apache::lonnet::auto_photo_permission($unam,$udom);
+ 	    &auto_photo_permission($unam,$udom);
          if ($result eq 'ok') {
              if (!($perm_reqd eq 'yes')) {
                  return(&retrievestudentphoto($udom,$unam,$ext));
- Line 2501  sub studentphoto {
+ Line 3468  sub studentphoto {
  sub retrievestudentphoto {
      my ($udom,$unam,$ext,$type) = @_;
-     my $home=&Apache::lonnet::homeserver($unam,$udom);
+     my $home=&homeserver($unam,$udom);
-     my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext:$type",$home);
+     my $ret=&reply("studentphoto:$udom:$unam:$ext:$type",$home);
      if ($ret eq 'ok') {
          my $url="/uploaded/$udom/$unam/internal/studentphoto.$ext";
          if ($type eq 'thumbnail') {
              $url="/uploaded/$udom/$unam/internal/studentphoto_tn.$ext";
          }
-         my $tokenurl=&Apache::lonnet::tokenwrapper($url);
+         my $tokenurl=&tokenwrapper($url);
          return $tokenurl;
      } else {
          if ($type eq 'thumbnail') {
- Line 2633  sub repcopy {
+ Line 3600  sub repcopy {
  		   mkdir($path,0777);
                 }
             }
-            my $ua=new LWP::UserAgent;
             my $request=new HTTP::Request('GET',"$remoteurl");
-            my $response=$ua->request($request,$transname);
+            my $response;
+            if ($remoteurl =~ m{/raw/}) {
+                $response=&LONCAPA::LWPReq::makerequest($home,$request,$transname,\%perlvar,'',0,1);
+            } else {
+                $response=&LONCAPA::LWPReq::makerequest($home,$request,$transname,\%perlvar,'',1);
+            }
             if ($response->is_error()) {
  	       unlink($transname);
                 my $message=$response->status_line;
- Line 2645  sub repcopy {
+ Line 3616  sub repcopy {
             } else {
  	       if ($remoteurl!~/\.meta$/) {
                    my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
-                   my $mresponse=$ua->request($mrequest,$filename.'.meta');
+                   my $mresponse;
+                   if ($remoteurl =~ m{/raw/}) {
+                       $mresponse = &LONCAPA::LWPReq::makerequest($home,$mrequest,$filename.'.meta',\%perlvar,'',0,1);
+                   } else {
+                       $mresponse = &LONCAPA::LWPReq::makerequest($home,$mrequest,$filename.'.meta',\%perlvar,'',1);
+                   }
                    if ($mresponse->is_error()) {
  		      unlink($filename.'.meta');
                        &logthis(
- Line 2659  sub repcopy {
+ Line 3635  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 {
+         my $defdom = $perlvar{'lonDefDomain'};
+         if (&will_trust('content',$defdom,$udom)) {
+             $answer = reply("unsub:$fname",$home);
+         } else {
+             $answer = 'untrusted';
+         }
+     }
+     return $answer;
+ }
  # ------------------------------------------------ Get server side include body
  sub ssi_body {
      my ($filelink,%form)=@_;
- Line 2687  sub ssi_body {
+ Line 3689  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 2708  sub absolute_url {
+ Line 3728  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);
+     my $lonhost = $perlvar{'lonHostID'};
+     my $islocal;
+     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 '') &&
+         (&allowed('mgr',$env{'request.course.id'}.
+                         ($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:'')))) {
+         $islocal = 1;
+     }
+     $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,
+                                              '','','',$islocal);
      if (wantarray) {
  	return ($response->content, $response);
      } else {
- Line 2731  sub ssi {
+ Line 3768  sub ssi {
  sub externalssi {
      my ($url)=@_;
-     my $ua=new LWP::UserAgent;
      my $request=new HTTP::Request('GET',$url);
-     my $response=$ua->request($request);
+     my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar);
      if (wantarray) {
          return ($response->content, $response);
      } else {
- Line 2741  sub externalssi {
+ Line 3777  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 = &declutter($url);
+                         my $request=new HTTP::Request('HEAD',$protocol.'://'.$hostname.'/raw/'.$uri);
+                         my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,5,0,1);
+                         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 2757  sub allowuploaded {
+ Line 3864  sub allowuploaded {
  #
  # 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.
- Line 2765  sub allowuploaded {
+ Line 3872  sub allowuploaded {
  #  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
  #
- Line 2797  sub can_edit_resource {
+ Line 3904  sub can_edit_resource {
      }
      if ($env{'request.course.id'}) {
-         my $crsedit = &Apache::lonnet::allowed('mdc',$env{'request.course.id'});
+         my $crsedit = &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;
- Line 2826  sub can_edit_resource {
+ Line 3933  sub can_edit_resource {
              }
          } else {
              if ($resurl =~ m{^/?adm/viewclasslist$}) {
-                 unless (&Apache::lonnet::allowed('opa',$env{'request.course.id'})) {
+                 unless (&allowed('opa',$env{'request.course.id'})) {
                      return;
                  }
              } elsif (!$crsedit) {
+                 if ($env{'request.role'} =~ m{^st\./$cdom/$cnum}) {
  #
  # No edit allowed where CC has switched to student role.
  #
-                 return;
+                     return;
+                 } elsif (($resurl !~ m{^/res/$match_domain/$match_username/}) ||
+                          ($resurl =~ m{^/res/lib/templates/})) {
+                     return;
+                 }
              }
          }
      }
- Line 2879  sub can_edit_resource {
+ Line 3991  sub can_edit_resource {
                          $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'}) {
- Line 2890  sub can_edit_resource {
+ Line 4022  sub can_edit_resource {
                  }
              } 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;
+                 $incourse = 1;
-                     if ($env{'form.forceedit'}) {
+                 if ($env{'form.forceedit'}) {
-                         $forceview = 1;
+                     $forceview = 1;
-                     } else {
+                 } else {
-                         $forceedit = 1;
+                     $forceedit = 1;
-                     }
+                 }
-                     $cfile = $resurl;
+                 $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;
- Line 2912  sub can_edit_resource {
+ Line 4052  sub can_edit_resource {
                      $cfile = &clutter($res);
                  } else {
                      $cfile = $env{'form.suppurl'};
-                     $cfile =~ s{^http://}{};
+                     my $escfile = &unescape($cfile);
-                     $cfile = '/adm/wrapper/ext/'.$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'}) {
- Line 2937  sub can_edit_resource {
+ Line 4082  sub can_edit_resource {
                  $cfile=$file;
              }
          }
          if (($cfile ne '') && (!$incourse || $uploaded) &&
              (($home ne '') && ($home ne 'no_host'))) {
              my @ids=&current_machine_ids();
              unless (grep(/^\Q$home\E$/,@ids)) {
- Line 2964  sub in_course {
+ Line 4109  sub in_course {
      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;
- Line 3069  sub process_coursefile {
+ Line 4214  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 3127  sub store_edited_file {
+ Line 4272  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 3152  sub clean_filename {
+ Line 4297  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 3201  sub resizeImage {
+ Line 4354  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, toollogo  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
+ #        $destuname - username for permanent storage of uploaded file
- #        $dsetudom - domain for permanaent storage of uploaded file
+ #        $destudom - domain for permanaent storage of uploaded file
  #        $thumbwidth - width (pixels) of thumbnail to make for uploaded image
  #        $thumbheight - height (pixels) of thumbnail to make for uploaded image
  #        $resizewidth - width (pixels) to which to resize uploaded image
- Line 3230  sub userfileupload {
+ Line 4386  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 3243  sub userfileupload {
+ Line 4407  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 3278  sub userfileupload {
+ Line 4442  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 3353  sub finishuserfileupload {
+ Line 4517  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 3397  sub finishuserfileupload {
+ Line 4561  sub finishuserfileupload {
              }
          }
      }
-     if ($parser eq 'parse') {
+     if (($context ne 'scantron') && ($parser eq 'parse')) {
          if ((ref($mimetype)) && ($$mimetype eq 'text/html')) {
              my $parse_result = &extract_embedded_items($filepath.'/'.$file,
                                                         $allfiles,$codebase);
- Line 3406  sub finishuserfileupload {
+ Line 4570  sub finishuserfileupload {
  	   	         ' for embedded media: '.$parse_result);
              }
          }
+     } elsif (($context eq 'scantron') && (ref($parser) eq 'HASH')) {
+         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 $makethumb;
          my $thumbsize = $thumbwidth.'x'.$thumbheight;
-         system("convert -sample $thumbsize $input $output");
+         if ($context eq 'toollogo') {
-         if (-e $filepath.'/'.'tn-'.$file) {
+             my ($fullwidth,$fullheight) = &check_dimensions($input);
-             $fetchthumb  = 1;
+             if ($fullwidth ne '' && $fullheight ne '') {
+                 if ($fullwidth > $thumbwidth && $fullheight > $thumbheight) {
+                     $makethumb = 1;
+                 }
+             }
+         } else {
+             $makethumb = 1;
+         }
+         if ($makethumb) {
+             my @args = ('convert','-sample',$thumbsize,$input,$output);
+             system({$args[0]} @args);
+             if (-e $filepath.'/'.'tn-'.$file) {
+                 $fetchthumb  = 1;
+             }
          }
      }
- Line 3470  sub extract_embedded_items {
+ Line 4651  sub extract_embedded_items {
  	    }
  	    if (lc($tagname) eq 'a') {
                  unless (($attr->{'href'} =~ /^#/) || ($attr->{'href'} eq '')) {
- 		    &add_filetype($allfiles,$attr->{'href'},'href');
+                     &add_filetype($allfiles,$attr->{'href'},'href');
                  }
  	    }
              if (lc($tagname) eq 'script') {
- Line 3645  sub embedded_dependency {
+ Line 4826  sub embedded_dependency {
      return;
  }
+ sub check_dimensions {
+     my ($inputfile) = @_;
+     my ($fullwidth,$fullheight);
+     if (($inputfile =~ m|^[/\w.\-]+$|) && (-e $inputfile)) {
+         my $mm = new File::MMagic;
+         my $mime_type = $mm->checktype_filename($inputfile);
+         if ($mime_type =~ m{^image/}) {
+             if (open(PIPE,"identify $inputfile 2>&1 |")) {
+                 my $imageinfo = <PIPE>;
+                 if (!close(PIPE)) {
+                     &Apache::lonnet::logthis("Failed to close PIPE opened to retrieve image information for $inputfile");
+                 }
+                 chomp($imageinfo);
+                 my ($fullsize) =
+                     ($imageinfo =~ /^\Q$inputfile\E\s+\w+\s+(\d+x\d+)/);
+                 if ($fullsize) {
+                     ($fullwidth,$fullheight) = split(/x/,$fullsize);
+                 }
+             }
+         }
+     }
+     return ($fullwidth,$fullheight);
+ }
+ 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 3762  sub flushcourselogs {
+ Line 5208  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 remain 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 3788  sub flushcourselogs {
+ Line 5257  sub flushcourselogs {
      foreach my $entry (keys(%userrolehash)) {
          my ($role,$uname,$udom,$runame,$rudom,$rsec)=
  	    split(/\:/,$entry);
-         if (&Apache::lonnet::put('nohist_userroles',
+         if (&put('nohist_userroles',
               { $role.':'.$uname.':'.$udom.':'.$rsec => $userrolehash{$entry} },
                  $rudom,$runame) eq 'ok') {
  	    delete $userrolehash{$entry};
          }
      }
  #
- # 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 3810  sub flushcourselogs {
+ Line 5279  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 3862  sub courseacclog {
+ Line 5340  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 3933  sub userrolelog {
+ Line 5415  sub userrolelog {
           {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}
                      =$tend.':'.$tstart;
      }
-     if ($trole =~ /^(dc|ad|li|au|dg|sc)/ ) {
+     if ($trole =~ /^(dc|ad|li|au|dg|sc|dh|da)/ ) {
         my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
         $domainrolehash
           {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
- Line 3974  sub domainrolelog {
+ Line 5456  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 $domconfiguser = &get_domainconfiguser($cdom);
          my $namespace = 'rolelog';
          my %storehash = (
                             role    => $trole,
- Line 4141  sub get_my_roles {
+ Line 5623  sub get_my_roles {
              } else {
                  my $possdoms = [$domain];
                  if (ref($roledoms) eq 'ARRAY') {
                     push(@{$possdoms},@{$roledoms});
                  }
                  if (&privileged($username,$domain,$possdoms,\@privroles)) {
                      if (!$nothide{$username.':'.$domain}) {
- Line 4160  sub get_my_roles {
+ Line 5642  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 = &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 4173  sub postannounce {
+ Line 5844  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 4236  sub courseiddump {
+ Line 5907  sub courseiddump {
          $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
          $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,
          $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner,
-         $hasuniquecode)=@_;
+         $hasuniquecode,$reqcrsdom,$reqinstcode)=@_;
      my $as_hash = 1;
      my %returnhash;
      if (!$domfilter) { $domfilter=''; }
- Line 4249  sub courseiddump {
+ Line 5920  sub courseiddump {
  	    if (($domfilter eq '') ||
  		(&host_domain($tryserver) eq $domfilter)) {
                  my $rep;
-                 if (grep { $_ eq $tryserver } &current_machine_ids()) {
+                 if (grep { $_ eq $tryserver } current_machine_ids()) {
-                     $rep = &LONCAPA::Lond::dump_course_id_handler(
+                     $rep = LONCAPA::Lond::dump_course_id_handler(
                          join(":", (&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)));
+                                 &escape($creationcontext),$domcloner,$hasuniquecode,
+                                 $reqcrsdom,&escape($reqinstcode))));
                  } else {
                      $rep = &reply('courseiddump:'.&host_domain($tryserver).':'.
                               $sincefilter.':'.&escape($descfilter).':'.
- Line 4270  sub courseiddump {
+ Line 5942  sub courseiddump {
                               $showhidden.':'.$caller.':'.&escape($cloner).':'.
                               &escape($cc_clone).':'.$cloneonly.':'.
                               &escape($createdbefore).':'.&escape($createdafter).':'.
-                              &escape($creationcontext).':'.$domcloner.':'.$hasuniquecode,
+                              &escape($creationcontext).':'.$domcloner.':'.$hasuniquecode.
-                              $tryserver);
+                              ':'.$reqcrsdom.':'.&escape($reqinstcode),$tryserver);
                  }
                  my @pairs=split(/\&/,$rep);
                  foreach my $item (@pairs) {
                      my ($key,$value)=split(/\=/,$item,2);
- Line 4343  sub extract_lastaccess {
+ Line 6015  sub extract_lastaccess {
  sub dcmailput {
      my ($domain,$msgid,$message,$server)=@_;
-     my $status = &Apache::lonnet::critical(
+     my $status = &critical(
         'dcmailput:'.$domain.':'.&escape($msgid).'='.
         &escape($message),$server);
      return $status;
- Line 4399  sub get_domain_roles {
+ Line 6071  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
  {
- Line 4410  my $cachedkey='';
+ Line 6097  my $cachedkey='';
  # The cached times for this user
  my %cachedtimes=();
  # When this was last done
- my $cachedtime=();
+ my $cachedtime='';
  sub load_all_first_access {
-     my ($uname,$udom)=@_;
+     my ($uname,$udom,$ignorecache)=@_;
      if (($cachedkey eq $uname.':'.$udom) &&
-         (abs($cachedtime-time)<5) && (!$env{'form.markaccess'})) {
+         (abs($cachedtime-time)<5) && (!$env{'form.markaccess'}) &&
+         (!$ignorecache)) {
          return;
      }
      $cachedtime=time;
- Line 4424  sub load_all_first_access {
+ Line 6112  sub load_all_first_access {
  }
  sub get_first_access {
-     my ($type,$argsymb,$argmap)=@_;
+     my ($type,$argsymb,$argmap,$ignorecache)=@_;
      my ($symb,$courseid,$udom,$uname)=&whichuser();
      if ($argsymb) { $symb=$argsymb; }
      my ($map,$id,$res)=&decode_symb($symb);
- Line 4436  sub get_first_access {
+ Line 6124  sub get_first_access {
      } else {
  	$res=$symb;
      }
-     &load_all_first_access($uname,$udom);
+     &load_all_first_access($uname,$udom,$ignorecache);
      return $cachedtimes{"$courseid\0$res"};
  }
- Line 4453  sub set_first_access {
+ Line 6141  sub set_first_access {
      }
      $cachedkey='';
      my $firstaccess=&get_first_access($type,$symb,$map);
-     if (!$firstaccess) {
+     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);
- Line 4466  sub set_first_access {
+ Line 6159  sub set_first_access {
                          '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;
      }
- Line 4473  sub set_first_access {
+ Line 6172  sub set_first_access {
  }
  }
- sub checkout {
-     my ($symb,$tuname,$tudom,$tcrsid)=@_;
-     my $now=time;
-     my $lonhost=$perlvar{'lonHostID'};
-     my $infostr=&escape(
-                  'CHECKOUTTOKEN&'.
-                  $tuname.'&'.
-                  $tudom.'&'.
-                  $tcrsid.'&'.
-                  $symb.'&'.
-                  $now.'&'.$ENV{'REMOTE_ADDR'});
-     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' => $ENV{'REMOTE_ADDR'});
-     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 ($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' => $ENV{'REMOTE_ADDR'});
-     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
  sub expirespread {
- Line 4812  sub tmpreset {
+ Line 6426  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 4849  sub tmpstore {
+ Line 6463  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 4893  sub tmprestore {
+ Line 6507  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 4928  sub tmprestore {
+ Line 6542  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 4949  sub store {
+ Line 6563  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 4958  sub store {
+ Line 6572  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 4985  sub cstore {
+ Line 6599  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 4995  sub cstore {
+ Line 6609  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 5151  sub privileged {
+ Line 6765  sub privileged {
      my $now = time;
      my $roles;
      if (ref($possroles) eq 'ARRAY') {
          $roles = $possroles;
      } else {
          $roles = ['dc','su'];
      }
- Line 5175  sub privileged {
+ Line 6789  sub privileged {
          my %rolesdump = &dump("roles", $domain, $username) or return 0;
          my $now = time;
-         for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys %rolesdump}) {
+         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);
              }
          }
- Line 5216  sub privileged_by_domain {
+ Line 6830  sub privileged_by_domain {
                          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};
                      }
                  }
- Line 5264  sub rolesinit {
+ Line 6878  sub rolesinit {
      my %allroles=();
      my %allgroups=();
-     for my $area (grep { ! /^rolesdef_/ } keys %rolesdump) {
+     for my $area (grep { ! /^rolesdef_/ } keys(%rolesdump)) {
          my $role = $rolesdump{$area};
          $area =~ s/\_\w\w$//;
- Line 5337  sub rolesinit {
+ Line 6951  sub rolesinit {
          }
      }
-     @userroles{'user.author', 'user.adv'} = &set_userprivs(\%userroles,
+     @userroles{'user.author','user.adv','user.rar'} = &set_userprivs(\%userroles,
-         \%allroles, \%allgroups);
+                                                           \%allroles, \%allgroups);
      $env{'user.adv'} = $userroles{'user.adv'};
+     $env{'user.rar'} = $userroles{'user.rar'};
      return (\%userroles,\%firstaccenv,\%timerintenv);
  }
- Line 5375  sub custom_roleprivs {
+ Line 6990  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 5383  sub custom_roleprivs {
+ Line 7002  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 5417  sub set_userprivs {
+ Line 7078  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 5464  sub set_userprivs {
+ Line 7126  sub set_userprivs {
                      $thesepriv{$privilege}.=$restrictions;
                  }
                  if ($thesepriv{'adv'} eq 'F') { $adv=1; }
+                 if ($thesepriv{'rar'} eq 'F') { $rar=1; }
              }
          }
          my $thesestr='';
- Line 5472  sub set_userprivs {
+ Line 7135  sub set_userprivs {
  	}
          $userroles->{'user.priv.'.$role} = $thesestr;
      }
-     return ($author,$adv);
+     return ($author,$adv,$rar);
  }
  sub role_status {
- Line 5517  sub role_status {
+ Line 7180  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 5595  sub delete_env_groupprivs {
+ Line 7259  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'},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 5687  sub unserialize {
+ Line 7369  sub unserialize {
      return {} if $rep =~ /^error/;
      my %returnhash=();
-     foreach my $item (split(/\&/,$rep)) {
+ 	foreach my $item (split(/\&/,$rep)) {
-         my ($key, $value) = split(/=/, $item, 2);
+ 	    my ($key, $value) = split(/=/, $item, 2);
-         $key = unescape($key) unless $escapedkeys;
+ 	    $key = unescape($key) unless $escapedkeys;
-         next if $key =~ /^error: 2 /;
+ 	    next if $key =~ /^error: 2 /;
-         $returnhash{$key} = &thaw_unescape($value);
+ 	    $returnhash{$key} = &thaw_unescape($value);
-     }
+ 	}
+     #return %returnhash;
      return \%returnhash;
  }
  # see Lond::dump_with_regexp
  # if $escapedkeys hash keys won't get unescaped.
  sub dump {
-     my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys)=@_;
+     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);
-     my $reply;
+     if ($regexp) {
-     if (grep { $_ eq $uhome } &current_machine_ids()) {
+         $regexp=&escape($regexp);
+     } else {
+         $regexp='.';
+     }
+     if (grep { $_ eq $uhome } current_machine_ids()) {
          # user is hosted on this machine
-         $reply = LONCAPA::Lond::dump_with_regexp(join(':', ($udomain,
+         my $reply = LONCAPA::Lond::dump_with_regexp(join(":", ($udomain,
                      $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});
-         return %{&unserialize($reply, $escapedkeys)};
+         return %{unserialize($reply, $escapedkeys)};
      }
-     if ($regexp) {
+     my $rep;
- 	$regexp=&escape($regexp);
+     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",$uhome);
      my @pairs=split(/\&/,$rep);
      my %returnhash=();
      if (!($rep =~ /^error/ )) {
  	foreach my $item (@pairs) {
  	    my ($key,$value)=split(/=/,$item,2);
-             $key = &unescape($key) unless ($escapedkeys);
+         $key = unescape($key) unless $escapedkeys;
+         #$key = &unescape($key);
  	    next if ($key =~ /^error: 2 /);
  	    $returnhash{$key}=&thaw_unescape($value);
  	}
- Line 5766  sub currentdump {
+ Line 7454  sub currentdump {
     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);
- Line 5776  sub currentdump {
+ Line 7464  sub currentdump {
     #
     my %returnhash=();
     #
-    if ($rep eq "unknown_cmd") {
+    if ($rep eq 'unknown_cmd') {
         # an old lond will not know currentdump
         # Do a dump and make it look like a currentdump
         my @tmp = &dumpstore($courseid,$sdom,$sname,'.');
- Line 5862  sub inc {
+ Line 7550  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 5871  sub put {
+ Line 7559  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 5892  sub newput {
+ Line 7584  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 5906  sub putstore {
+ Line 7598  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'});
+        &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 5999  sub tmpget {
+ Line 7703  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 6014  sub tmpdel {
+ Line 7720  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');
      }
- Line 6034  sub get_timebased_id {
+ Line 7740  sub get_timebased_id {
      if (!$maxtries) {
          $maxtries = 10;
      }
      if (($cdom eq '') || ($cnum eq '')) {
          if ($env{'request.course.id'}) {
              $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
- Line 6052  sub get_timebased_id {
+ Line 7758  sub get_timebased_id {
      my $tries = 0;
  # attempt to get lock on nohist_$namespace file
-     my $gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum);
+     my $gotlock = &newput('nohist_'.$namespace,$lockhash,$cdom,$cnum);
      while (($gotlock ne 'ok') && $tries <$locktries) {
          $tries ++;
          sleep 1;
-         $gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum);
+         $gotlock = &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 %inuse = &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 ++;
              }
- Line 6077  sub get_timebased_id {
+ Line 7788  sub get_timebased_id {
              my %new_item =  (
                                $prefix."\0".$newid => $who,
                              );
-             my $putresult = &Apache::lonnet::put('nohist_'.$namespace,\%new_item,
+             my $putresult = &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
- Line 6092  sub get_timebased_id {
+ Line 7804  sub get_timebased_id {
      } 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,$blockdom) =
-                 &Apache::loncommon::blockcheck(\%setters,'port');
+                 &Apache::loncommon::blockcheck(\%setters,'port',$clientip);
-             if ($startblock && $endblock) {
+             if (($startblock && $endblock) || ($by_ip)) {
                  return 'B';
              }
          }
- Line 6127  sub portfolio_access {
+ Line 7850  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 6136  sub get_portfolio_access {
+ Line 7859  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 6160  sub get_portfolio_access {
+ Line 7883  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 6339  sub is_portfolio_file {
+ Line 8077  sub is_portfolio_file {
      return;
  }
+ sub is_coursetool_logo {
+     my ($uri) = @_;
+     if ($env{'request.course.id'}) {
+         my $courseurl = &courseid_to_courseurl($env{'request.course.id'});
+         if ($uri =~ m{^/*uploaded\Q$courseurl\E/toollogo/\d+/[^/]+$}) {
+             return 1;
+         }
+     }
+     return;
+ }
  sub usertools_access {
      my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref)=@_;
      my ($access,%tools);
- Line 6351  sub usertools_access {
+ Line 8100  sub usertools_access {
                        unofficial => 1,
                        community  => 1,
                        textbook   => 1,
+                       placement  => 1,
+                       lti        => 1,
                   );
      } elsif ($context eq 'requestauthor') {
          %tools = (
- Line 6362  sub usertools_access {
+ Line 8113  sub usertools_access {
                        blog      => 1,
                        webdav    => 1,
                        portfolio => 1,
+                       timezone  => 1,
                   );
      }
      return if (!defined($tools{$tool}));
- Line 6385  sub usertools_access {
+ Line 8137  sub usertools_access {
      my ($toolstatus,$inststatus,$envkey);
      if ($context eq 'requestauthor') {
          $envkey = $context;
      } else {
          $envkey = $context.'.'.$tool;
      }
- Line 6486  sub is_course_owner {
+ Line 8238  sub is_course_owner {
              if ($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'} eq $uname.':'.$udom) {
                  return 1;
              } else {
-                 my %courseinfo = &Apache::lonnet::coursedescription($cdom.'/'.$cnum);
+                 my %courseinfo = &coursedescription($cdom.'/'.$cnum);
                  if ($courseinfo{'internal.courseowner'} eq $uname.':'.$udom) {
                      return 1;
                  }
- Line 6547  sub is_advanced_user {
+ Line 8299  sub is_advanced_user {
  }
  sub check_can_request {
-     my ($dom,$can_request,$request_domains) = @_;
+     my ($dom,$can_request,$request_domains,$uname,$udom) = @_;
      my $canreq = 0;
+     if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {
+         $uname = $env{'user.name'};
+         $udom = $env{'user.domain'};
+     }
      my ($types,$typename) = &Apache::loncommon::course_types();
      my @options = ('approval','validate','autolimit');
      my $optregex = join('|',@options);
      if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) {
+         my %willtrust;
          foreach my $type (@{$types}) {
-             if (&usertools_access($env{'user.name'},
+             if (&usertools_access($uname,$udom,$type,undef,
-                                   $env{'user.domain'},
+                                   'requestcourses')) {
-                                   $type,undef,'requestcourses')) {
                  $canreq ++;
                  if (ref($request_domains) eq 'HASH') {
-                     push(@{$request_domains->{$type}},$env{'user.domain'});
+                     push(@{$request_domains->{$type}},$udom);
                  }
-                 if ($dom eq $env{'user.domain'}) {
+                 if ($dom eq $udom) {
                      $can_request->{$type} = 1;
                  }
              }
-             if ($env{'environment.reqcrsotherdom.'.$type} ne '') {
+             if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '') &&
+                 ($env{'environment.reqcrsotherdom.'.$type} ne '')) {
                  my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type});
                  if (@curr > 0) {
                      foreach my $item (@curr) {
                          if (ref($request_domains) eq 'HASH') {
                              my ($otherdom) = ($item =~ /^($match_domain):($optregex)(=?\d*)$/);
                              if ($otherdom ne '') {
-                                 if (ref($request_domains->{$type}) eq 'ARRAY') {
+                                 unless (exists($willtrust{$otherdom})) {
-                                     unless (grep(/^\Q$otherdom\E$/,@{$request_domains->{$type}})) {
+                                     $willtrust{$otherdom} = &will_trust('reqcrs',$env{'user.domain'},$otherdom);
+                                 }
+                                 if ($willtrust{$otherdom}) {
+                                     if (ref($request_domains->{$type}) eq 'ARRAY') {
+                                         unless (grep(/^\Q$otherdom\E$/,@{$request_domains->{$type}})) {
+                                             push(@{$request_domains->{$type}},$otherdom);
+                                         }
+                                     } else {
                                          push(@{$request_domains->{$type}},$otherdom);
                                      }
-                                 } else {
-                                     push(@{$request_domains->{$type}},$otherdom);
                                  }
                              }
                          }
                      }
-                     unless($dom eq $env{'user.domain'}) {
+                     unless ($dom eq $env{'user.domain'}) {
                          $canreq ++;
                          if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) {
                              $can_request->{$type} = 1;
- Line 6647  sub customaccess {
+ Line 8409  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 6664  sub allowed {
+ Line 8426  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 6675  sub allowed {
+ Line 8437  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 6712  sub allowed {
+ Line 8474  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 6770  sub allowed {
+ Line 8535  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 6783  sub allowed {
+ Line 8548  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 6829  sub allowed {
+ Line 8594  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 6842  sub allowed {
+ Line 8633  sub allowed {
          if ($match) {
              if ($env{'user.priv.'.$env{'request.role'}.'./'}
                    =~/\Q$priv\E\&([^\:]*)/) {
-                 my @blockers = &has_comm_blocking($priv,$symb,$uri);
+                 my $value = $1;
-                 if (@blockers > 0) {
+                 my $deeplinkblock;
-                     $thisallowed = 'B';
+                 unless ($nodeeplinkcheck) {
+                     $deeplinkblock = &deeplink_check($priv,$symb,$uri);
+                 }
+                 if ($deeplinkblock) {
+                     $thisallowed='D';
+                 } elsif ($noblockcheck) {
+                     $thisallowed.=$value;
                  } else {
-                     $thisallowed.=$1;
+                     my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);
+                     if (@blockers > 0) {
+                         $thisallowed = 'B';
+                     } else {
+                         $thisallowed.=$value;
+                     }
                  }
              }
          } else {
- Line 6858  sub allowed {
+ Line 8660  sub allowed {
                      $refuri=&declutter($refuri);
                      my ($match) = &is_on_map($refuri);
                      if ($match) {
-                         my @blockers = &has_comm_blocking($priv,$symb,$refuri);
+                         my $deeplinkblock;
-                         if (@blockers > 0) {
+                         unless ($nodeeplinkcheck) {
-                             $thisallowed = 'B';
+                             $deeplinkblock = &deeplink_check($priv,$symb,$refuri);
-                         } else {
+                         }
+                         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 6874  sub allowed {
+ Line 8686  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.
      if ($thisallowed=~/F/) {
  	return 'F';
- Line 6904  sub allowed {
+ Line 8716  sub allowed {
      if ($env{'request.course.id'}) {
+         if ($priv eq 'bre') {
+             if (&is_coursetool_logo($uri)) {
+                 return 'F';
+             }
+         }
+ # 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 6917  sub allowed {
+ Line 8745  sub allowed {
                 =~/\Q$priv\E\&([^\:]*)/) {
                 my $value = $1;
                 if ($priv eq 'bre') {
-                    my @blockers = &has_comm_blocking($priv,$symb,$uri);
+                    my $deeplinkblock;
-                    if (@blockers > 0) {
+                    unless ($nodeeplinkcheck) {
-                        $thisallowed = 'B';
+                        $deeplinkblock = &deeplink_check($priv,$symb,$uri);
-                    } else {
+                    }
+                    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;
- Line 6929  sub allowed {
+ Line 8767  sub allowed {
                 $checkreferer=0;
             }
         }
         if ($checkreferer) {
  	  my $refuri=$env{'httpref.'.$orguri};
              unless ($refuri) {
- Line 6955  sub allowed {
+ Line 8793  sub allowed {
                    =~/\Q$priv\E\&([^\:]*)/) {
                    my $value = $1;
                    if ($priv eq 'bre') {
-                       my @blockers = &has_comm_blocking($priv,$symb,$refuri);
+                       my $deeplinkblock;
-                       if (@blockers > 0) {
+                       unless ($nodeeplinkcheck) {
-                           $thisallowed = 'B';
+                           $deeplinkblock = &deeplink_check($priv,$symb,$refuri);
-                       } else {
+                       }
+                       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;
- Line 6996  sub allowed {
+ Line 8844  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 7028  sub allowed {
+ Line 8908  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 7040  sub allowed {
+ Line 8920  sub allowed {
  	   }
         }
      }
  #
  # Rest of the restrictions depend on selected course
  #
- Line 7067  sub allowed {
+ Line 8947  sub allowed {
         my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};
         if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}
  	   =~/\Q$rolecode\E/) {
- 	   if (($priv ne 'pch') && ($priv ne 'plc')) {
+ 	   if (($priv ne 'pch') && ($priv ne 'plc') && ($priv ne 'pac')) {
  	       &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
  			'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
  			$env{'request.course.id'});
- Line 7077  sub allowed {
+ Line 8957  sub allowed {
         if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}
  	   =~/\Q$unamedom\E/) {
- 	   if (($priv ne 'pch') && ($priv ne 'plc')) {
+ 	   if (($priv ne 'pch') && ($priv ne 'plc') && ($priv ne 'pac')) {
  	       &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
  			'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
  			$env{'request.course.id'});
- Line 7099  sub allowed {
+ Line 8979  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 7119  sub allowed {
+ Line 9010  sub allowed {
  	return 'A';
      } elsif ($thisallowed eq 'B') {
          return 'B';
+     } elsif ($thisallowed eq 'D') {
+         return 'D';
      }
     return 'F';
  }
- Line 7135  sub constructaccess {
+ Line 9028  sub constructaccess {
      my ($ownername,$ownerdomain,$ownerhome);
      ($ownerdomain,$ownername) =
-         ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)/priv/($match_domain)/($match_username)/});
+         ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)(?:/daxepage|/daxeopen)?/priv/($match_domain)/($match_username)(?:/|$)});
  # The URL does not really point to any authorspace, forget it
      unless (($ownername) && ($ownerdomain)) { return ''; }
- Line 7149  sub constructaccess {
+ Line 9042  sub constructaccess {
         if (exists($env{'user.priv.au./'.$ownerdomain.'/./'})) {
            return ($ownername,$ownerdomain,$ownerhome);
         }
+     } elsif (&is_course($ownerdomain,$ownername)) {
+ # Course Authoring Space?
+         if ($env{'request.course.id'}) {
+             if (($ownername eq $env{'course.'.$env{'request.course.id'}.'.num'}) &&
+                 ($ownerdomain eq $env{'course.'.$env{'request.course.id'}.'.domain'})) {
+                 if (&allowed('mdc',$env{'request.course.id'})) {
+                     $ownerhome = $env{'course.'.$env{'request.course.id'}.'.home'};
+                     return ($ownername,$ownerdomain,$ownerhome);
+                 }
+             }
+         }
+         return '';
      } else {
  # Co-author for this?
          if (exists($env{'user.priv.ca./'.$ownerdomain.'/'.$ownername.'./'}) ||
- Line 7190  sub constructaccess {
+ Line 9095  sub constructaccess {
      return '';
  }
+ # ----------------------------------------------------------- Content Blocking
+ {
+ # Caches for faster Course Contents display where content blocking
+ # is in operation (i.e., interval param set) for timed quiz.
+ #
+ # 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 '') {
- Line 7203  sub get_comm_blocks {
+ Line 9139  sub get_comm_blocks {
      if ((defined($cached)) && (ref($blocksref) eq 'HASH')) {
          %commblocks = %{$blocksref};
      } else {
-         %commblocks = &Apache::lonnet::dump('comm_block',$cdom,$cnum);
+         %commblocks = &dump('comm_block',$cdom,$cnum);
          my $cachetime = 600;
          &do_cache_new('comm_block',$hashid,\%commblocks,$cachetime);
      }
      return %commblocks;
  }
- sub has_comm_blocking {
+ sub get_commblock_resources {
-     my ($priv,$symb,$uri,$blocks) = @_;
+     my ($blocks) = @_;
-     return unless ($env{'request.course.id'});
+     my %blockers = ();
-     return unless ($priv eq 'bre');
+     return %blockers unless ($env{'request.course.id'});
-     return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);
+     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 unless (keys(%commblocks) > 0);
+     return %blockers unless (keys(%commblocks) > 0);
-     if (!$symb) { $symb=&symbread($uri,1); }
-     my ($map,$resid,undef)=&decode_symb($symb);
-     my %tocheck = (
-                     maps      => $map,
-                     resources => $symb,
-                   );
-     my @blockers;
-     my $now = time;
      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);
- Line 7238  sub has_comm_blocking {
+ Line 9172  sub has_comm_blocking {
                  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 ($commblocks{$block}{'blocks'}{'docs'}{'maps'}{$map}) {
+                             if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'maps'}})) {
-                                 unless (grep(/^\Q$block\E$/,@blockers)) {
+                                 $blockers{$block}{maps} = $commblocks{$block}{'blocks'}{'docs'}{'maps'};
-                                     push(@blockers,$block);
-                                 }
                              }
                          }
                          if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') {
-                             if ($commblocks{$block}{'blocks'}{'docs'}{'resources'}{$symb}) {
+                             if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'resources'}})) {
-                                 unless (grep(/^\Q$block\E$/,@blockers)) {
+                                 $blockers{$block}{'resources'} = $commblocks{$block}{'blocks'}{'docs'}{'resources'};
-                                     push(@blockers,$block);
-                                 }
                              }
                          }
                      }
- Line 7256  sub has_comm_blocking {
+ Line 9186  sub has_comm_blocking {
              }
          } elsif ($block =~ /^firstaccess____(.+)$/) {
              my $item = $1;
-             my @to_test;
              if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
                  if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
-                     my $check_interval;
+                     my (@interval,$mapname);
-                     if (&check_docs_block($commblocks{$block}{'blocks'}{'docs'},\%tocheck)) {
+                     my $type = 'map';
-                         my @interval;
+                     if ($item eq 'course') {
-                         my $type = 'map';
+                         $type = 'course';
-                         if ($item eq 'course') {
+                         @interval=&EXT("resource.0.interval");
-                             $type = 'course';
+                     } else {
-                             @interval=&EXT("resource.0.interval");
+                         if ($item =~ /___\d+___/) {
+                             $type = 'resource';
+                             @interval=&EXT("resource.0.interval",$item);
                          } else {
-                             if ($item =~ /___\d+___/) {
+                             $mapname = &deversion($item);
-                                 $type = 'resource';
+                             if (ref($navmap)) {
-                                 @interval=&EXT("resource.0.interval",$item);
+                                 my $timelimit = $navmap->get_mapparam(undef,$mapname,'0.interval');
-                                 if (ref($navmap)) {
+                                 @interval = ($timelimit,'map');
-                                     my $res = $navmap->getBySymb($item);
+                             }
-                                     push(@to_test,$res);
+                         }
-                                 }
+                     }
-                             } else {
+                     if ($interval[0] =~ /^(\d+)/) {
-                                 my $mapsymb = &symbread($item,1);
+                         my $timelimit = $1;
-                                 if ($mapsymb) {
+                         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);
-                                         @to_test = $mapres->retrieveResources($mapres,undef,0,1);
+                                         if (ref($mapres)) {
-                                         foreach my $res (@to_test) {
+                                             my $first = $mapres->map_start();
-                                             my $symb = $res->symb();
+                                             my $finish = $mapres->map_finish();
-                                             next if ($symb eq $mapsymb);
+                                             my $it = $navmap->getIterator($first,$finish,undef,0,0);
-                                             if ($symb ne '') {
+                                             if (ref($it)) {
-                                                 @interval=&EXT("resource.0.interval",$symb);
+                                                 my $res;
-                                                 last;
+                                                 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 ($interval[0] =~ /\d+/) {
+                                          if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'maps'}})) {
-                             my $first_access;
+                                              $blockers{$block}{'maps'} = $commblocks{$block}{'blocks'}{'docs'}{'maps'};
-                             if ($type eq 'resource') {
+                                          }
-                                 $first_access=&get_first_access($interval[1],$item);
+                                     }
-                             } elsif ($type eq 'map') {
+                                     if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') {
-                                 $first_access=&get_first_access($interval[1],undef,$item);
+                                         if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'resources'}})) {
-                             } else {
+                                             $blockers{$block}{'resources'} = $commblocks{$block}{'blocks'}{'docs'}{'resources'};
-                                 $first_access=&get_first_access($interval[1]);
-                             }
-                             if ($first_access) {
-                                 my $timesup = $first_access+$interval[0];
-                                 if ($timesup > $now) {
-                                     foreach my $res (@to_test) {
-                                         if ($res->is_problem()) {
-                                             if ($res->completable()) {
-                                                 unless (grep(/^\Q$block\E$/,@blockers)) {
-                                                     push(@blockers,$block);
-                                                 }
-                                                 last;
-                                             }
                                          }
                                      }
                                  }
- Line 7322  sub has_comm_blocking {
+ Line 9271  sub has_comm_blocking {
              }
          }
      }
-     return @blockers;
+     return %blockers;
  }
- sub check_docs_block {
+ sub has_comm_blocking {
-     my ($docsblock,$tocheck) =@_;
+     my ($priv,$symb,$uri,$ignoresymbdb,$noenccheck,$blocked,$blocks) = @_;
-     if ((ref($docsblock) ne 'HASH') || (ref($tocheck) ne 'HASH')) {
+     my @blockers;
-         return;
+     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'};
      }
-     if (ref($docsblock->{'maps'}) eq 'HASH') {
+     return if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseurl} =~/evb\&([^\:]*)/);
-         if ($tocheck->{'maps'}) {
+     my %blockinfo;
-             if ($docsblock->{'maps'}{$tocheck->{'maps'}}) {
+     if (ref($blocks) eq 'HASH') {
-                 return 1;
+         %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);
+                         }
+                     }
+                 }
              }
          }
      }
-     if (ref($docsblock->{'resources'}) eq 'HASH') {
+     unless ($noblock) {
-         if ($tocheck->{'resources'}) {
+         return @blockers;
-             if ($docsblock->{'resources'}{$tocheck->{'resources'}}) {
+     }
-                 return 1;
+     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;
+     return if ($allow);
+     return 1;
  }
+ # -------------------------------- Deversion and split uri into path an filename
  #
- #   Removes the versino from a URI and
+ #   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 7416  sub get_symb_from_alias {
+ Line 9493  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 7444  sub definerole {
+ Line 9521  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 7463  sub metadata_query {
+ Line 9548  sub metadata_query {
      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).':::'.&escape($domains),$server);
- Line 7530  sub update_allusers_table {
+ Line 9615  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 7551  sub fetch_enrollment_query {
+ Line 9638  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 7579  sub fetch_enrollment_query {
+ Line 9666  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 7596  sub fetch_enrollment_query {
+ Line 9683  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 7723  sub auto_validate_instcode {
+ Line 9816  sub auto_validate_instcode {
      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 {
      my ($cnum,$cdom,$authparam,$udom) = @_;
      my ($homeserver,$response);
- Line 7994  sub auto_validate_class_sec {
+ Line 10106  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) = @_;
- Line 8010  sub auto_crsreq_update {
+ Line 10181  sub auto_crsreq_update {
                              ':'.&escape($action).':'.&escape($ownername).':'.
                              &escape($ownerdomain).':'.&escape($fullname).':'.
                              &escape($title).':'.&escape($code).':'.
-                             &escape($accessstart).':'.&escape($accessend).':'.$info,$homeserver);
+                             &escape($accessstart).':'.&escape($accessend).':'.$info,
+                             $homeserver);
          unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
              my @items = split(/&/,$response);
              foreach my $item (@items) {
- Line 8022  sub auto_crsreq_update {
+ Line 10194  sub auto_crsreq_update {
      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 8169  sub plaintext {
+ Line 10442  sub plaintext {
      my %rolenames = (
                        Course    => 'std',
                        Community => 'alt1',
+                       Placement => 'std',
                      );
      if ($cid ne '') {
          if ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '') {
- Line 8202  sub assignrole {
+ Line 10476  sub assignrole {
      if ($role =~ /^cr\//) {
          my $cwosec=$url;
          $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
- 	unless (&allowed('ccr',$cwosec)) {
+         if ((!&allowed('ccr',$cwosec)) && (!&allowed('ccr',$udom))) {
             my $refused = 1;
             if ($context eq 'requestcourses') {
                 if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {
- Line 8250  sub assignrole {
+ Line 10524  sub assignrole {
              }
              if ($refused) {
                  my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
-                 if (!$selfenroll && $context eq 'course') {
+                 if (!$selfenroll && (($context eq 'course') || ($context eq 'ltienroll' && $env{'request.lti.login'}))) {
                      my %crsenv;
                      if ($role eq 'cc' || $role eq 'co') {
                          %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
- Line 8270  sub assignrole {
+ Line 10544  sub assignrole {
                              }
                          }
                      }
-                 } elsif (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
+                 } elsif (($selfenroll == 1) && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
-                     $refused = '';
+                     if ($role eq 'st') {
+                         $refused = '';
+                     } elsif (($context eq 'ltienroll') && ($env{'request.lti.login'})) {
+                         $refused = '';
+                     }
                  } elsif ($context eq 'requestcourses') {
                      my @possroles = ('st','ta','ep','in','cc','co');
                      if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {
- Line 8290  sub assignrole {
+ Line 10568  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 = '';
- Line 8298  sub assignrole {
+ Line 10576  sub assignrole {
                              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;
                                  }
- Line 8386  sub assignrole {
+ Line 10664  sub assignrole {
              &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 '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 8409  sub autoupdate_coowners {
+ Line 10688  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 8426  sub autoupdate_coowners {
+ Line 10717  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 8476  sub store_coowners {
+ Line 10765  sub store_coowners {
      }
      if (($putresult eq 'ok') || ($delresult eq 'ok')) {
          my %crsinfo =
-             &Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.');
+             &courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.');
          if (ref($crsinfo{$cid}) eq 'HASH') {
              $crsinfo{$cid}{'co-owners'} = \@newcoowners;
-             my $cidput = &Apache::lonnet::courseidput($cdom,\%crsinfo,$chome,'notime');
+             my $cidput = &courseidput($cdom,\%crsinfo,$chome,'notime');
          }
      }
  }
- Line 8490  sub store_coowners {
+ Line 10779  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 8536  sub modifyuser {
+ Line 10841  sub modifyuser {
      my $newuser;
      if ($uhome eq 'no_host') {
          $newuser = 1;
+         unless (($umode && ($upass ne '')) || ($umode eq 'localauth') ||
+                 ($umode eq 'lti')) {
+             return 'error: more information needed to create new user';
+         }
      }
  # ----------------------------------------------------------------- Create User
      if (($uhome eq 'no_host') &&
- 	(($umode && $upass) || ($umode eq 'localauth'))) {
+ 	(($umode && $upass) || ($umode eq 'localauth') || ($umode eq 'lti'))) {
          my $unhome='';
          if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) {
              $unhome = $desiredhome;
- Line 8581  sub modifyuser {
+ Line 10890  sub modifyuser {
                    'current user id "'.$uidhash{$uname}.'".';
            }
         } else {
- 	  &idput($udom,($uname => $uid));
+ 	  &idput($udom,{$uname => $uid},$uhome,'ids');
         }
      }
  # -------------------------------------------------------------- Add names, etc
- Line 8677  sub modifyuser {
+ Line 10986  sub modifyuser {
          return 'error: '.$reply;
      }
      if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) {
-         &Apache::lonnet::devalidate_cache_new('emailscache',$uname.':'.$udom);
+         &devalidate_cache_new('emailscache',$uname.':'.$udom);
      }
      my $sqlresult = &update_allusers_table($uname,$udom,\%names);
      &devalidate_cache_new('namescache',$uname.':'.$udom);
- Line 8691  sub modifyuser {
+ Line 11000  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,$credits)=@_;
+         $selfenroll,$context,$inststatus,$credits,$instsec)=@_;
      if (!$cid) {
  	unless ($cid=$env{'request.course.id'}) {
  	    return 'not_in_class';
- Line 8706  sub modifystudent {
+ Line 11015  sub modifystudent {
      # student's environment
      $uid = undef if (!$forceid);
      $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
- 					$gene,$usec,$end,$start,$type,$locktype,
+                                         $gene,$usec,$end,$start,$type,$locktype,
-                                         $cid,$selfenroll,$context,$credits);
+                                         $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,$credits) = @_;
+         $locktype,$cid,$selfenroll,$context,$credits,$instsec) = @_;
      my ($cdom,$cnum,$chome);
      if (!$cid) {
  	unless ($cid=$env{'request.course.id'}) {
- Line 8757  sub modify_student_enrollment {
+ Line 11066  sub modify_student_enrollment {
      }
      my $fullname = &format_name($first,$middle,$last,$gene,'lastname');
      my $user = "$uname:$udom";
-     my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum);
+     my %old_entry = &get('classlist',[$user],$cdom,$cnum);
      my $reply=cput('classlist',
  		   {$user =>
- 			join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits) },
+ 			join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits,$instsec) },
  		   $cdom,$cnum);
      if (($reply eq 'ok') || ($reply eq 'delayed')) {
          &devalidate_getsection_cache($udom,$uname,$cid);
- Line 8827  sub writecoursepref {
+ Line 11136  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 8886  sub createcourse {
+ Line 11200  sub createcourse {
          }
      }
      my %host_servers =
-         &Apache::lonnet::get_servers($udom,'library');
+         &get_servers($udom,'library');
      unless ($host_servers{$course_server}) {
          return 'error: invalid home server for course: '.$course_server;
      }
- Line 8984  sub is_course {
+ Line 11298  sub is_course {
      my ($cdom, $cnum) = scalar(@_) == 1 ?
           ($_[0] =~ /^($match_domain)_($match_courseid)$/)  :  @_;
-     return unless $cdom and $cnum;
+     return unless (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/));
+     my $uhome=&homeserver($cnum,$cdom);
-     my %courses = &courseiddump($cdom, '.', 1, '.', '.', $cnum, undef, undef,
+     my $iscourse;
-         '.');
+     if (grep { $_ eq $uhome } current_machine_ids()) {
+         $iscourse = &LONCAPA::Lond::is_course($cdom,$cnum);
-     return unless(exists($courses{$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 unless ($iscourse);
      return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum;
  }
- Line 9006  sub store_userdata {
+ Line 11333  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 9125  sub save_selected_files {
+ Line 11452  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 9139  sub save_selected_files {
+ Line 11466  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 9149  sub files_in_path {
+ Line 11476  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 9171  sub files_not_in_path {
+ Line 11498  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 9188  sub files_not_in_path {
+ Line 11515  sub files_not_in_path {
      return (@return_files);
  }
+ #------------------------------Submitted/Handedback Portfolio Files Versioning
+ sub portfiles_versioning {
+     my ($symb,$domain,$stu_name,$portfiles,$versioned_portfiles) = @_;
+     my $portfolio_root = '/userfiles/portfolio';
+     return unless ((ref($portfiles) eq 'ARRAY') && (ref($versioned_portfiles) eq 'ARRAY'));
+     foreach my $file (@{$portfiles}) {
+         &unmark_as_readonly($domain,$stu_name,[$symb,$env{'request.course.id'}],$file);
+         my ($directory,$answer_file) =($file =~ /^(.*?)([^\/]*)$/);
+         my ($answer_name,$answer_ver,$answer_ext) = &file_name_version_ext($answer_file);
+         my $getpropath = 1;
+         my ($dir_list,$listerror) = &dirlist($portfolio_root.$directory,$domain,
+                                              $stu_name,$getpropath);
+         my $version = &get_next_version($answer_name,$answer_ext,$dir_list);
+         my $new_answer =
+             &version_selected_portfile($domain,$stu_name,$directory,$answer_file,$version);
+         if ($new_answer ne 'problem getting file') {
+             push(@{$versioned_portfiles}, $directory.$new_answer);
+             &mark_as_readonly($domain,$stu_name,[$directory.$new_answer],
+                               [$symb,$env{'request.course.id'},'graded']);
+         }
+     }
+ }
+ sub get_next_version {
+     my ($answer_name, $answer_ext, $dir_list) = @_;
+     my $version;
+     if (ref($dir_list) eq 'ARRAY') {
+         foreach my $row (@{$dir_list}) {
+             my ($file) = split(/\&/,$row,2);
+             my ($file_name,$file_version,$file_ext) =
+                 &file_name_version_ext($file);
+             if (($file_name eq $answer_name) &&
+                 ($file_ext eq $answer_ext)) {
+                      # gets here if filename and extension match,
+                      # regardless of version
+                 if ($file_version ne '') {
+                     # a versioned file is found  so save it for later
+                     if ($file_version > $version) {
+                         $version = $file_version;
+                     }
+                 }
+             }
+         }
+     }
+     $version ++;
+     return($version);
+ }
+ sub version_selected_portfile {
+     my ($domain,$stu_name,$directory,$file_name,$version) = @_;
+     my ($answer_name,$answer_ver,$answer_ext) =
+         &file_name_version_ext($file_name);
+     my $new_answer;
+     $env{'form.copy'} =
+         &getfile("/uploaded/$domain/$stu_name/portfolio$directory$file_name");
+     if($env{'form.copy'} eq '-1') {
+         $new_answer = 'problem getting file';
+     } else {
+         $new_answer = $answer_name.'.'.$version.'.'.$answer_ext;
+         my $copy_result =
+             &finishuserfileupload($stu_name,$domain,'copy',
+                                   '/portfolio'.$directory.$new_answer);
+     }
+     undef($env{'form.copy'});
+     return ($new_answer);
+ }
+ sub file_name_version_ext {
+     my ($file)=@_;
+     my @file_parts = split(/\./, $file);
+     my ($name,$version,$ext);
+     if (@file_parts > 1) {
+         $ext=pop(@file_parts);
+         if (@file_parts > 1 && $file_parts[-1] =~ /^\d+$/) {
+             $version=pop(@file_parts);
+         }
+         $name=join('.',@file_parts);
+     } else {
+         $name=join('.',@file_parts);
+     }
+     return($name,$version,$ext);
+ }
  #----------------------------------------------Get portfolio file permissions
  sub get_portfile_permissions {
- Line 9284  sub modify_access_controls {
+ Line 11695  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 9332  sub modify_access_controls {
+ Line 11743  sub modify_access_controls {
  }
  sub make_public_indefinitely {
-     my ($requrl) = @_;
+     my (@requrl) = @_;
+     return &automated_portfile_access('public',\@requrl);
+ }
+ sub automated_portfile_access {
+     my ($accesstype,$addsref,$delsref,$info) = @_;
+     unless (($accesstype eq 'public') || ($accesstype eq 'ip')) {
+         return 'invalid';
+     }
+     my %urls;
+     if (ref($addsref) eq 'ARRAY') {
+         foreach my $requrl (@{$addsref}) {
+             if (&is_portfolio_url($requrl)) {
+                 unless (exists($urls{$requrl})) {
+                     $urls{$requrl} = 'add';
+                 }
+             }
+         }
+     }
+     if (ref($delsref) eq 'ARRAY') {
+         foreach my $requrl (@{$delsref}) {
+             if (&is_portfolio_url($requrl)) {
+                 unless (exists($urls{$requrl})) {
+                     $urls{$requrl} = 'delete';
+                 }
+             }
+         }
+     }
+     unless (keys(%urls)) {
+         return 'invalid';
+     }
+     my $ip;
+     if ($accesstype eq 'ip') {
+         if (ref($info) eq 'HASH') {
+             if ($info->{'ip'} ne '') {
+                 $ip = $info->{'ip'};
+             }
+         }
+         if ($ip eq '') {
+             return 'invalid';
+         }
+     }
+     my $errors;
      my $now = time;
-     my $action = 'activate';
+     my %current_perms;
-     my $aclnum = 0;
+     foreach my $requrl (sort(keys(%urls))) {
-     if (&is_portfolio_url($requrl)) {
+         my $action;
+         if ($urls{$requrl} eq 'add') {
+             $action = 'activate';
+         } else {
+             $action = 'none';
+         }
+         my $aclnum = 0;
          my (undef,$udom,$unum,$file_name,$group) =
              &parse_portfolio_url($requrl);
-         my $current_perms = &get_portfile_permissions($udom,$unum);
+         unless (exists($current_perms{$unum.':'.$udom})) {
-         my %access_controls = &get_access_controls($current_perms,
+             $current_perms{$unum.':'.$udom} = &get_portfile_permissions($udom,$unum);
+         }
+         my %access_controls = &get_access_controls($current_perms{$unum.':'.$udom},
                                                     $group,$file_name);
          foreach my $key (keys(%{$access_controls{$file_name}})) {
              my ($num,$scope,$end,$start) =
                  ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
-             if ($scope eq 'public') {
+             if ($scope eq $accesstype) {
-                 if ($start <= $now && $end == 0) {
+                 if (($start <= $now) && ($end == 0)) {
-                     $action = 'none';
+                     if ($accesstype eq 'ip') {
-                 } else {
+                         if (ref($access_controls{$file_name}{$key}) eq 'HASH') {
+                             if (ref($access_controls{$file_name}{$key}{'ip'}) eq 'ARRAY') {
+                                 if (grep(/^\Q$ip\E$/,@{$access_controls{$file_name}{$key}{'ip'}})) {
+                                     if ($urls{$requrl} eq 'add') {
+                                         $action = 'none';
+                                         last;
+                                     } else {
+                                         $action = 'delete';
+                                         $aclnum = $num;
+                                         last;
+                                     }
+                                 }
+                             }
+                         }
+                     } elsif ($accesstype eq 'public') {
+                         if ($urls{$requrl} eq 'add') {
+                             $action = 'none';
+                             last;
+                         } else {
+                             $action = 'delete';
+                             $aclnum = $num;
+                             last;
+                         }
+                     }
+                 } elsif ($accesstype eq 'public') {
                      $action = 'update';
                      $aclnum = $num;
+                     last;
                  }
-                 last;
              }
          }
          if ($action eq 'none') {
-              return 'ok';
+             next;
          } else {
              my %changes;
              my $newend = 0;
              my $newstart = $now;
-             my $newkey = $aclnum.':public_'.$newend.'_'.$newstart;
+             my $newkey = $aclnum.':'.$accesstype.'_'.$newend.'_'.$newstart;
              $changes{$action}{$newkey} = {
-                 type => 'public',
+                 type => $accesstype,
                  time => {
                      start => $newstart,
                      end   => $newend,
                  },
              };
+             if ($accesstype eq 'ip') {
+                 $changes{$action}{$newkey}{'ip'} = [$ip];
+             }
              my ($outcome,$deloutcome,$new_values,$translation) =
                  &modify_access_controls($file_name,\%changes,$udom,$unum);
-             return $outcome;
+             unless ($outcome eq 'ok') {
+                 $errors .= $outcome.' ';
+             }
          }
+     }
+     if ($errors) {
+         $errors =~ s/\s$//;
+         return $errors;
      } else {
-         return 'invalid';
+         return 'ok';
      }
  }
- Line 9579  sub dirlist {
+ Line 12073  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 9652  sub stat_file {
+ Line 12163  sub stat_file {
      return ();
  }
+ # --------------------------------------------------------- recursedirs
+ # Recursive function to traverse either a specific user's Authoring Space
+ # or corresponding Published Resource Space, and populate the hash ref:
+ # $dirhashref with URLs of all directories, and if $filehashref hash
+ # ref arg is provided, the URLs of any files, excluding versioned, .meta,
+ # or .rights files in resource space, and .meta, .save, .log, .bak and
+ # .rights files in Authoring Space.
+ #
+ # Inputs:
+ #
+ # $is_home - true if current server is home server for user's space
+ # $recurse - if true will also traverse subdirectories recursively
+ # $include - reference to hash containing allowed file extensions.  If provided,
+ #             files which do not have a matching extension will be ignored.
+ # $exclude - reference to hash containing excluded file extensions.  If provided,
+ #             files which have a matching extension will be ignored.
+ # $nonemptydir - if true, will only populate $fileshashref hash entry for a particular
+ #             directory with first file found (with acceptable extension).
+ # $addtopdir - if true, set $dirhashref->{'/'} = 1
+ # $toppath - Top level directory (i.e., /res/$dom/$uname or /priv/$dom/$uname
+ # $relpath - Current path (relative to top level).
+ # $dirhashref - reference to hash to populate with URLs of directories (Required)
+ # $filehashref - reference to hash to populate with URLs of files (Optional)
+ #
+ # Returns: nothing
+ #
+ # Side Effects: populates $dirhashref, and $filehashref (if provided).
+ #
+ # Currently used by interface/londocs.pm to create linked select boxes for
+ # directory and filename to import a Course "Author" resource into a course, and
+ # also to create linked select boxes for Authoring Space and Directory to choose
+ # save location for creation of a new "standard" problem from the Course Editor.
+ #
+ sub recursedirs {
+     my ($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$relpath,$dirhashref,$filehashref) = @_;
+     return unless (ref($dirhashref) eq 'HASH');
+     my $docroot = $perlvar{'lonDocRoot'};
+     my $currpath = $docroot.$toppath;
+     if ($relpath ne '') {
+         $currpath .= "/$relpath";
+     }
+     my ($savefile,$checkinc,$checkexc);
+     if (ref($filehashref)) {
+         $savefile = 1;
+     }
+     if (ref($include) eq 'HASH') {
+         $checkinc = 1;
+     }
+     if (ref($exclude) eq 'HASH') {
+         $checkexc = 1;
+     }
+     if ($is_home) {
+         if ((-e $currpath) && (opendir(my $dirh,$currpath))) {
+             my $filecount = 0;
+             foreach my $item (sort { lc($a) cmp lc($b) } grep(!/^\.+$/,readdir($dirh))) {
+                 next if ($item eq '');
+                 if (-d "$currpath/$item") {
+                     my $newpath;
+                     if ($relpath ne '') {
+                         $newpath = "$relpath/$item";
+                     } else {
+                         $newpath = $item;
+                     }
+                     $dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;
+                     if ($recurse) {
+                         &recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$newpath,$dirhashref,$filehashref);
+                     }
+                 } elsif (($savefile) || ($relpath eq '')) {
+                     next if ($nonemptydir && $filecount);
+                     if ($checkinc || $checkexc) {
+                         my ($extension) = ($item =~ /\.(\w+)$/);
+                         if ($checkinc) {
+                             next unless ($extension && $include->{$extension});
+                         }
+                         if ($checkexc) {
+                             next if ($extension && $exclude->{$extension});
+                         }
+                     }
+                     if (($relpath eq '') && (!exists($dirhashref->{'/'}))) {
+                         $dirhashref->{'/'} = 1;
+                     }
+                     if ($savefile) {
+                         if ($relpath eq '') {
+                             $filehashref->{'/'}{$item} = 1;
+                         } else {
+                             $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;
+                         }
+                     }
+                     $filecount ++;
+                 }
+             }
+             closedir($dirh);
+         }
+     } else {
+         my ($dirlistref,$listerror) =
+             &dirlist($toppath.$relpath);
+         my @dir_lines;
+         my $dirptr=16384;
+         if (ref($dirlistref) eq 'ARRAY') {
+             my $filecount = 0;
+             foreach my $dir_line (sort
+                               {
+                                   my ($afile)=split('&',$a,2);
+                                   my ($bfile)=split('&',$b,2);
+                                   return (lc($afile) cmp lc($bfile));
+                               } (@{$dirlistref})) {
+                 my ($item,$dom,undef,$testdir,undef,undef,undef,undef,$size,undef,$mtime,undef,undef,undef,$obs,undef) =
+                     split(/\&/,$dir_line,16);
+                 $item =~ s/\s+$//;
+                 next if (($item =~ /^\.\.?$/) || ($obs));
+                 if ($dirptr&$testdir) {
+                     my $newpath;
+                     if ($relpath) {
+                         $newpath = "$relpath/$item";
+                     } else {
+                         $newpath = $item;
+                     }
+                     $dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;
+                     if ($recurse) {
+                         &recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$newpath,$dirhashref,$filehashref);
+                     }
+                 } elsif (($savefile) || ($relpath eq '')) {
+                     next if ($nonemptydir && $filecount);
+                     if ($checkinc || $checkexc) {
+                         my $extension;
+                         if ($checkinc) {
+                             next unless ($extension && $include->{$extension});
+                         }
+                         if ($checkexc) {
+                             next if ($extension && $exclude->{$extension});
+                         }
+                     }
+                     if (($relpath eq '') && (!exists($dirhashref->{'/'}))) {
+                         $dirhashref->{'/'} = 1;
+                     }
+                     if ($savefile) {
+                         if ($relpath eq '') {
+                             $filehashref->{'/'}{$item} = 1;
+                         } else {
+                             $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;
+                         }
+                     }
+                     $filecount ++;
+                 }
+             }
+         }
+     }
+     if ($addtopdir) {
+         if (($relpath eq '') && (!exists($dirhashref->{'/'}))) {
+             $dirhashref->{'/'} = 1;
+         }
+     }
+     return;
+ }
+ sub priv_exclude {
+     return {
+              meta => 1,
+              save => 1,
+              log => 1,
+              bak => 1,
+              rights => 1,
+              DS_Store => 1,
+            };
+ }
  # -------------------------------------------------------- Value of a Condition
  # gets the value of a specific preevaluated condition
- Line 9796  sub get_userresdata {
+ Line 12474  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 9813  sub get_userresdata {
+ Line 12493  sub get_userresdata {
  #  Parameters:
  #     $name      - Course/user name.
  #     $domain    - Name of the domain the user/course is registered on.
- #     $type      - Type of thing $name is (must be 'course' or 'user'
+ #     $type      - Type of thing $name is (must be 'course' or 'user')
+ #     $mapp      - decluttered URL of enclosing map
+ #     $recursed  - Ref to scalar -- set to 1, if nested maps have been recursed.
+ #     $recurseup - Ref to array of map URLs, starting with map containing
+ #                  $mapp up through hierarchy of nested maps to top level map.
+ #     $courseid  - CourseID (first part of param identifier).
+ #     $modifier  - Middle part of param identifier.
+ #     $what      - Last part of param identifier.
  #     @which     - Array of names of resources desired.
  #  Returns:
  #     The value of the first reasource in @which that is found in the
- Line 9823  sub get_userresdata {
+ Line 12510  sub get_userresdata {
  #     'user', an undefined  reference is returned.
  #     If none of the resources are found, an undef is returned
  sub resdata {
-     my ($name,$domain,$type,@which)=@_;
+     my ($name,$domain,$type,$mapp,$recursed,$recurseup,$courseid,
+         $modifier,$what,@which)=@_;
      my $result;
      if ($type eq 'course') {
  	$result=&get_courseresdata($name,$domain);
- Line 9832  sub resdata {
+ Line 12520  sub resdata {
      }
      if (!ref($result)) { return $result; }
      foreach my $item (@which) {
- 	if (defined($result->{$item->[0]})) {
+         if ($item->[1] eq 'course') {
+             if ((ref($recurseup) eq 'ARRAY') && (ref($recursed) eq 'SCALAR')) {
+                 unless ($$recursed) {
+                     @{$recurseup} = &get_map_hierarchy($mapp,$courseid);
+                     $$recursed = 1;
+                 }
+                 foreach my $item (@${recurseup}) {
+                     my $norecursechk=$courseid.$modifier.$item.'___(all).'.$what;
+                     last if (defined($result->{$norecursechk}));
+                     my $recursechk=$courseid.$modifier.$item.'___(rec).'.$what;
+                     if (defined($result->{$recursechk})) { return [$result->{$recursechk},'map']; }
+                 }
+             }
+         }
+         if (defined($result->{$item->[0]})) {
  	    return [$result->{$item->[0]},$item->[1]];
  	}
      }
      return undef;
  }
- sub get_numsuppfiles {
+ sub get_domain_lti {
-     my ($cnum,$cdom,$ignorecache)=@_;
+     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}};
+             }
+         }
+         my $cachetime = 24*60*60;
+         &do_cache_new($cachename,$cdom,\%lti,$cachetime);
+     }
+     return %lti;
+ }
+ sub get_course_lti {
+     my ($cnum,$cdom,$context) = @_;
+     my ($name,$cachename,%lti);
+     if ($context eq 'consumer') {
+         $name = 'ltitools';
+         $cachename = 'courseltitools';
+     } elsif ($context eq 'provider') {
+         $name = 'lti';
+         $cachename = 'courselti';
+     } else {
+         return %lti;
+     }
+     my $hashid=$cdom.'_'.$cnum;
+     my ($result,$cached)=&is_cached_new($cachename,$hashid);
+     if (defined($cached)) {
+         if (ref($result) eq 'HASH') {
+             %lti = %{$result};
+         }
+     } else {
+         %lti = &dump($name,$cdom,$cnum,undef,undef,undef,1);
+         my $cachetime = 24*60*60;
+         &do_cache_new($cachename,$hashid,\%lti,$cachetime);
+     }
+     return %lti;
+ }
+ 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 $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 $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 ($suppcount,$cached);
+     my ($showsupp,$cached);
      unless ($ignorecache) {
-         ($suppcount,$cached) = &is_cached_new('suppcount',$hashid);
+         ($showsupp,$cached) = &is_cached_new('showsupp',$hashid);
      }
      unless (defined($cached)) {
          my $chome=&homeserver($cnum,$cdom);
          unless ($chome eq 'no_host') {
-             ($suppcount,my $errors) = (0,0);
+             my ($supplemental) = &Apache::loncommon::get_supplemental($cnum,$cdom,$ignorecache,$possdel);
-             my $suppmap = 'supplemental.sequence';
+             if (ref($supplemental) eq 'HASH') {
-             ($suppcount,$errors) =
+                 if ((ref($supplemental->{'ids'}) eq 'HASH') && (ref($supplemental->{'hidden'}) eq 'HASH')) {
-                 &Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount,$errors);
+                     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('suppcount',$hashid,$suppcount,600);
+         &do_cache_new('showsupp',$hashid,$showsupp,600);
      }
-     return $suppcount;
+     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 9887  sub EXT_cache_set {
+ Line 12751  sub EXT_cache_set {
  # --------------------------------------------------------- Value of a Variable
  sub EXT {
-     my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid)=@_;
+     my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid,$recurseupref)=@_;
      unless ($varname) { return ''; }
      #get real user name/domain, courseid and symb
      my $courseid;
- Line 9919  sub EXT {
+ Line 12783  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 10040  sub EXT {
+ Line 12904  sub EXT {
              }
          }
- 	my ($section, $group, @groups);
+ 	my ($section, $group, @groups, @recurseup, $recursed);
- 	my ($courselevelm,$courselevel);
+         if (ref($recurseupref) eq 'ARRAY') {
+             @recurseup = @{$recurseupref};
+             $recursed = 1;
+         }
+ 	my ($courselevelm,$courseleveli,$courselevel,$mapp);
          if (($courseid eq '') && ($cid)) {
              $courseid = $cid;
          }
  	if (($symbparm && $courseid) &&
- 	    (($courseid eq $env{'request.course.id'}) || ($courseid eq $cid))) {
+ 	    (($courseid eq $env{'request.course.id'}) || ($courseid eq $cid)))  {
  	    #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
  # ----------------------------------------------------- Cascading lookup scheme
  	    my $symbp=$symbparm;
- 	    my $mapp=&deversion((&decode_symb($symbp))[0]);
+ 	    $mapp=&deversion((&decode_symb($symbp))[0]);
  	    my $symbparm=$symbp.'.'.$spacequalifierrest;
+             my $recurseparm=$mapp.'___(rec).'.$spacequalifierrest;
  	    my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
  	    if (($env{'user.name'} eq $uname) &&
  		($env{'user.domain'} eq $udom)) {
  		$section=$env{'request.course.sec'};
- Line 10073  sub EXT {
+ Line 12940  sub EXT {
  	    my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
  	    my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;
+             my $secleveli=$courseid.'.['.$section.'].'.$recurseparm;
  	    my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;
  	    $courselevel=$courseid.'.'.$spacequalifierrest;
  	    my $courselevelr=$courseid.'.'.$symbparm;
+             $courseleveli=$courseid.'.'.$recurseparm;
  	    $courselevelm=$courseid.'.'.$mapparm;
  # ----------------------------------------------------------- first, check user
- 	    my $userreply=&resdata($uname,$udom,'user',
+ 	    my $userreply=&resdata($uname,$udom,'user',$mapp,\$recursed,
+                                    \@recurseup,$courseid,'.',$spacequalifierrest,
  				       ([$courselevelr,'resource'],
  					[$courselevelm,'map'     ],
+                                         [$courseleveli,'map'     ],
  					[$courselevel, 'course'  ]));
  	    if (defined($userreply)) { return &get_reply($userreply); }
- Line 10091  sub EXT {
+ Line 12962  sub EXT {
              my $coursereply;
              if (@groups > 0) {
                  $coursereply = &check_group_parms($courseid,\@groups,$symbparm,
-                                        $mapparm,$spacequalifierrest);
+                                        $recurseparm,$mapparm,$spacequalifierrest,
-                 if (defined($coursereply)) { return &get_reply($coursereply); }
+                                        $mapp,\$recursed,\@recurseup);
+                 if (defined($coursereply)) { return &get_reply($coursereply); }
              }
  	    $coursereply=&resdata($env{'course.'.$courseid.'.num'},
  				  $env{'course.'.$courseid.'.domain'},
- 				  'course',
+ 				  'course',$mapp,\$recursed,\@recurseup,
+                                   $courseid,'.['.$section.'].',$spacequalifierrest,
  				  ([$seclevelr,   'resource'],
  				   [$seclevelm,   'map'     ],
+                                    [$secleveli,   'map'     ],
  				   [$seclevel,    'course'  ],
  				   [$courselevelr,'resource']));
  	    if (defined($coursereply)) { return &get_reply($coursereply); }
- Line 10116  sub EXT {
+ Line 12990  sub EXT {
  	    if ($thisparm) { return &get_reply([$thisparm,'resource']); }
  	}
  # ------------------------------------------ fourth, look in resource metadata
- 	$spacequalifierrest=~s/\./\_/;
+         my $what = $spacequalifierrest;
+ 	$what=~s/\./\_/;
  	my $filename;
  	if (!$symbparm) { $symbparm=&symbread(); }
  	if ($symbparm) {
- Line 10125  sub EXT {
+ Line 13000  sub EXT {
  	} else {
  	    $filename=$env{'request.filename'};
  	}
- 	my $metadata=&metadata($filename,$spacequalifierrest);
+         my $toolsymb;
+         if (($filename =~ /ext\.tool$/) && ($what ne '0_gradable')) {
+             $toolsymb = $symbparm;
+         }
+ 	my $metadata=&metadata($filename,$what,$toolsymb);
  	if (defined($metadata)) { return &get_reply([$metadata,'resource']); }
- 	$metadata=&metadata($filename,'parameter_'.$spacequalifierrest);
+ 	$metadata=&metadata($filename,'parameter_'.$what,$toolsymb);
  	if (defined($metadata)) { return &get_reply([$metadata,'resource']); }
- # ---------------------------------------------- fourth, look in rest of course
+ # ----------------------------------------------- fifth, look in rest of course
  	if ($symbparm && defined($courseid) &&
  	    $courseid eq $env{'request.course.id'}) {
  	    my $coursereply=&resdata($env{'course.'.$courseid.'.num'},
  				     $env{'course.'.$courseid.'.domain'},
- 				     'course',
+ 				     'course',$mapp,\$recursed,\@recurseup,
+                                      $courseid,'.',$spacequalifierrest,
  				     ([$courselevelm,'map'   ],
+                                       [$courseleveli,'map'   ],
  				      [$courselevel, 'course']));
  	    if (defined($coursereply)) { return &get_reply($coursereply); }
  	}
- Line 10151  sub EXT {
+ Line 13032  sub EXT {
  	    if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); }
  	}
  	if ($recurse) { return undef; }
- 	my $pack_def=&packages_tab_default($filename,$varname);
+ 	my $pack_def=&packages_tab_default($filename,$varname,$toolsymb);
  	if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); }
  # ---------------------------------------------------- Any other user namespace
      } elsif ($realm eq 'environment') {
- Line 10176  sub EXT {
+ Line 13057  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 10193  sub get_reply {
+ Line 13078  sub get_reply {
  }
  sub check_group_parms {
-     my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;
+     my ($courseid,$groups,$symbparm,$recurseparm,$mapparm,$what,$mapp,
-     my @groupitems = ();
+         $recursed,$recurseupref) = @_;
-     my $resultitem;
+     my @levels = ([$symbparm,'resource'],[$mapparm,'map'],[$recurseparm,'map'],
-     my @levels = ([$symbparm,'resource'],[$mapparm,'map'],[$what,'course']);
+                   [$what,'course']);
+     my $coursereply;
      foreach my $group (@{$groups}) {
+         my @groupitems = ();
          foreach my $level (@levels) {
               my $item = $courseid.'.['.$group.'].'.$level->[0];
               push(@groupitems,[$item,$level->[1]]);
          }
+         my $coursereply = &resdata($env{'course.'.$courseid.'.num'},
+                                    $env{'course.'.$courseid.'.domain'},
+                                    'course',$mapp,$recursed,$recurseupref,
+                                    $courseid,'.['.$group.'].',$what,
+                                    @groupitems);
+         last if (defined($coursereply));
      }
-     my $coursereply = &resdata($env{'course.'.$courseid.'.num'},
-                             $env{'course.'.$courseid.'.domain'},
-                                      'course',@groupitems);
      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 10216  sub sort_course_groups { # Sort groups b
+ Line 13130  sub sort_course_groups { # Sort groups b
  }
  sub packages_tab_default {
-     my ($uri,$varname)=@_;
+     my ($uri,$varname,$toolsymb)=@_;
      my (undef,$part,$name)=split(/\./,$varname);
      my (@extension,@specifics,$do_default);
-     foreach my $package (split(/,/,&metadata($uri,'packages'))) {
+     foreach my $package (split(/,/,&metadata($uri,'packages',$toolsymb))) {
  	my ($pack_type,$pack_part)=split(/_/,$package,2);
  	if ($pack_type eq 'default') {
  	    $do_default=1;
- Line 10287  sub add_prefix_and_part {
+ Line 13201  sub add_prefix_and_part {
  my %metaentry;
  my %importedpartids;
+ my %importedrespids;
  sub metadata {
-     my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
+     my ($uri,$what,$toolsymb,$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{/(smppg|bulletinboard)$})) ||
+ 	     ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard|ext\.tool)$})) ||
          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {
  	return undef;
      }
- Line 10312  sub metadata {
+ Line 13227  sub metadata {
  	my ($result,$cached)=&is_cached_new('meta',$uri);
  	if (defined($cached)) { return $result->{':'.$what}; }
      }
+ #
+ # If the uri is for an external tool the file from
+ # which metadata should be retrieved depends on whether
+ # the tool had been configured to be gradable (set in the Course
+ # Editor or Resource Editor).
+ #
+ # If a valid symb has been included as the third arg in the call
+ # to &metadata() that can be used to retrieve the value of
+ # parameter_0_gradable set for the resource, and included in the
+ # uploaded map containing the tool. The value is retrieved via
+ # &EXT(), if a valid symb is available.  Otherwise the value of
+ # gradable in the exttool_$marker.db file for the tool instance
+ # is retrieved via &get().
+ #
+ # When lonuserstate::traceroute() calls lonnet::EXT() for
+ # hiddenresource and encrypturl (during course initialization)
+ # the map-level parameter for resource.0.gradable included in the
+ # uploaded map containing the tool will not yet have been stored
+ # in the user_course_parms.db file for the user's session, so in
+ # this case fall back to retrieving gradable status from the
+ # exttool_$marker.db file.
+ #
+ # In order to avoid an infinite loop, &metadata() will return
+ # before a call to &EXT(), if the uri is for an external tool
+ # and the $what for which metadata is being requested is
+ # parameter_0_gradable or 0_gradable.
+ #
+     if ($uri =~ /ext\.tool$/) {
+         if (($what eq 'parameter_0_gradable') || ($what eq '0_gradable')) {
+             return;
+         } else {
+             my ($checked,$use_passback);
+             if ($toolsymb ne '') {
+                 (undef,undef,my $tooluri) = &decode_symb($toolsymb);
+                 if (($tooluri eq $uri) && (&EXT('resource.0.gradable',$toolsymb))) {
+                     $checked = 1;
+                     if (&EXT('resource.0.gradable',$toolsymb) =~ /^yes$/i) {
+                         $use_passback = 1;
+                     }
+                 }
+             }
+             unless ($checked) {
+                 my ($ignore,$cdom,$cnum,$marker) = split(m{/},$uri);
+                 $marker=~s/\D//g;
+                 if ($marker) {
+                     my %toolsettings=&get('exttool_'.$marker,['gradable'],$cdom,$cnum);
+                     $use_passback = $toolsettings{'gradable'};
+                 }
+             }
+             if ($use_passback) {
+                 $filename = '/home/httpd/html/res/lib/templates/LTIpassback.tool';
+             } else {
+                 $filename = '/home/httpd/html/res/lib/templates/LTIstandard.tool';
+             }
+         }
+     }
      {
  # 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 10411  sub metadata {
+ Line 13387  sub metadata {
                          my $dir=$filename;
                          $dir=~s|[^/]*$||;
                          $location=&filelocation($dir,$location);
+                         my $importid=$token->[2]->{'id'};
                          my $importmode=$token->[2]->{'importmode'};
-                         if ($importmode eq 'problem') {
+ #
- # Import as problem/response
+ # Check metadata for imported file to
-                            $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
+ # see if it contained response items
-                         } elsif ($importmode eq 'part') {
+ #
+                         my ($origfile,@libfilekeys);
+                         my %currmetaentry = %metaentry;
+                         @libfilekeys = split(/,/,&metadata($location,'keys',undef,undef,undef,
+                                                            $depthcount+1));
+                         if (grep(/^responseorder$/,@libfilekeys)) {
+                             my $libresponseorder = &metadata($location,'responseorder',undef,undef,
+                                                              undef,$depthcount+1);
+                             if ($libresponseorder ne '') {
+                                 if ($#origfiletagids<0) {
+                                     undef(%importedrespids);
+                                     undef(%importedpartids);
+                                 }
+                                 my @respids = split(/\s*,\s*/,$libresponseorder);
+                                 if (@respids) {
+                                     $importedrespids{$importid} = join(',',map { $importid.'_'.$_ } @respids);
+                                 }
+                                 if ($importedrespids{$importid} ne '') {
+                                     $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 'part') {
  # Import as part(s)
                             $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);
+                                }
+                            }
+                            my @impfilepartids;
+ # If <partorder> tag is included in metadata for the imported file
+ # get the parts in the imported file from that.
+                            if (grep(/^partorder$/,@libfilekeys)) {
+                                %currmetaentry = %metaentry;
+                                my $libpartorder = &metadata($location,'partorder',undef,undef,undef,
+                                                             $depthcount+1);
+                                %metaentry = %currmetaentry;
+                                undef(%currmetaentry);
+                                if ($libpartorder ne '') {
+                                    @impfilepartids=split(/\s*,\s*/,$libpartorder);
+                                }
+                            } else {
+ # If no <partorder> tag available, load and inspect imported file
+                                my $impfile=&getfile($location);
+                                @impfilepartids=($impfile=~/<part[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
                             }
- # Load and inspect imported file
-                            my $impfile=&getfile($location);
-                            my @impfilepartids=($impfile=~/<part[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
                             if ($#impfilepartids>=0) {
  # This problem had parts
                                 $importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids);
- Line 10442  sub metadata {
+ Line 13468  sub metadata {
                                 $importedpartids{$token->[2]->{'id'}}=$token->[2]->{'id'};
                             }
                          } else {
+ # Import as problem or as normal import
+                             $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
+                             unless ($importmode eq 'problem') {
  # Normal import
-                            $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
+                                 if (defined($token->[2]->{'id'})) {
-                            if (defined($token->[2]->{'id'})) {
+                                     $unikey.='_'.$token->[2]->{'id'};
-                               $unikey.='_'.$token->[2]->{'id'};
+                                 }
-                            }
+                             }
+ # Check metadata for imported file to
+ # see if it contained parts
+                             if (grep(/^partorder$/,@libfilekeys)) {
+                                 %currmetaentry = %metaentry;
+                                 my $libpartorder = &metadata($location,'partorder',undef,undef,undef,
+                                                              $depthcount+1);
+                                 %metaentry = %currmetaentry;
+                                 undef(%currmetaentry);
+                                 if ($libpartorder ne '') {
+                                     $importedparts = 1;
+                                     $importedpartids{$token->[2]->{'id'}}=$libpartorder;
+                                 }
+                             }
                          }
  			if ($depthcount<20) {
  			    my $metadata =
- 				&metadata($uri,'keys', $location,$unikey,
+ 				&metadata($uri,'keys',$toolsymb,$location,$unikey,
  					  $depthcount+1);
  			    foreach my $meta (split(',',$metadata)) {
  				$metaentry{':'.$meta}=$metaentry{':'.$meta};
  				$metathesekeys{$meta}=1;
  			    }
                          }
  		    } else {
  #
- Line 10526  sub metadata {
+ Line 13566  sub metadata {
  		$dir=~s|[^/]*$||;
  		$location=&filelocation($dir,$location);
  		my $rights_metadata =
- 		    &metadata($uri,'keys',$location,'_rights',
+ 		    &metadata($uri,'keys',$toolsymb,$location,'_rights',
  			      $depthcount+1);
  		foreach my $rights (split(',',$rights_metadata)) {
  		    #$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights};
- Line 10540  sub metadata {
+ Line 13580  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 rebuil 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
+                         if ($importedpartids{$origid} ne '') {
+                             $metaentry{':partorder'}.=','.$importedpartids{$origid};
+                         }
+                     }
+                     if ($importedresponses) {
+ # We have imported responses at this position
+                         if ($importedrespids{$origid} ne '') {
+                             $metaentry{':responseorder'}.=','.$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);
+         unless ($liburi) {
+ 	    &do_cache_new('meta',$uri,\%metaentry,$cachetime);
+         }
  # this is the end of "was not already recently cached
      }
      return $metaentry{':'.$what};
- Line 10715  sub get_reservable_slots {
+ Line 13786  sub get_reservable_slots {
  sub get_course_slots {
      my ($cnum,$cdom) = @_;
      my $hashid=$cnum.':'.$cdom;
-     my ($result,$cached) = &Apache::lonnet::is_cached_new('allslots',$hashid);
+     my ($result,$cached) = &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 %slots=&dump('slots',$cdom,$cnum);
          my ($tmp) = keys(%slots);
          if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
              &do_cache_new('allslots',$hashid,\%slots,600);
- Line 10767  sub get_coursechange {
+ Line 13838  sub get_coursechange {
  }
  sub devalidate_coursechange_cache {
-     my ($cnum,$cdom)=@_;
+     my ($cdom,$cnum)=@_;
-     my $hashid=$cnum.':'.$cdom;
+     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 10818  sub symbverify {
+ Line 13946  sub symbverify {
      if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
                              &GDBM_READER(),0640)) {
-         my $noclutter;
          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://};
-                 $noclutter = 1;
              }
          }
          my $ids;
-         if ($noclutter) {
+         if ($map =~ m{^uploaded/.+\.page$}) {
-             $ids=$bighash{'ids_'.$thisurl};
+             $ids=$bighash{'ids_'.&clutter_with_no_wrapper($thisurl)};
          } else {
              $ids=$bighash{'ids_'.&clutter($thisurl)};
          }
          unless ($ids) {
              my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl;
              $ids=$bighash{$idkey};
          }
          if ($ids) {
- Line 10850  sub symbverify {
+ Line 13976  sub symbverify {
                     if (ref($encstate)) {
                         $$encstate = $bighash{'encrypted_'.$id};
                     }
-                    if (($env{'request.role.adv'}) ||
+ 		   if (($env{'request.role.adv'}) ||
-                        ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) ||
+ 		       ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) ||
                         ($thisurl eq '/adm/navmaps')) {
-                        $okay=1;
+ 		       $okay=1;
                         last;
-                    }
+ 		   }
-                }
+ 	       }
-            }
+ 	   }
          }
  	untie(%bighash);
      }
- Line 10929  sub deversion {
+ Line 14055  sub deversion {
  # ------------------------------------------------------ Return symb list entry
  sub symbread {
-     my ($thisfn,$donotrecurse)=@_;
+     my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles,
-     my $cache_str;
+         $ignoresymbdb,$noenccheck)=@_;
-     if ($thisfn ne '') {
+     my $cache_str='request.symbread.cached.'.$thisfn;
-         $cache_str='request.symbread.cached.'.$thisfn;
+     if (defined($env{$cache_str})) {
-         if ($env{$cache_str} ne '') {
+         unless (ref($possibles) eq 'HASH') {
-             return $env{$cache_str};
+             if ($ignorecachednull) {
+                 return $env{$cache_str} unless ($env{$cache_str} eq '');
+             } else {
+                 return $env{$cache_str};
+             }
          }
-    } else {
+     }
  # no filename provided? try from environment
+     unless ($thisfn) {
          if ($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 10955  sub symbread {
+ Line 14086  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 10997  sub symbread {
+ Line 14129  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 11016  sub symbread {
+ Line 14187  sub symbread {
                       $syval='';
                   }
  	      }
-               untie(%bighash)
+               untie(%bighash);
             }
          }
          if ($syval) {
- Line 11169  sub rndseed {
+ Line 14340  sub rndseed {
  	$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 11354  sub rndseed_CODE_64bit5 {
+ Line 14526  sub rndseed_CODE_64bit5 {
  sub setup_random_from_rndseed {
      my ($rndseed)=@_;
      if ($rndseed =~/([,:])/) {
- 	my ($num1,$num2) = map { abs($_); } (split(/[,:]/,$rndseed));
+         my ($num1,$num2) = map { abs($_); } (split(/[,:]/,$rndseed));
          if ((!$num1) || (!$num2) || ($num1 > 2147483562) || ($num2 > 2147483398)) {
              &Math::Random::random_set_seed_from_phrase($rndseed);
          } else {
- Line 11538  sub repcopy_userfile {
+ Line 14710  sub repcopy_userfile {
      }
  # now the path exists for sure
  # get a user agent
-     my $ua=new LWP::UserAgent;
      my $transferfile=$file.'.in.transfer';
  # FIXME: this should flock
      if (-e $transferfile) { return 'ok'; }
      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);
+     my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,$transferfile,\%perlvar,'',0,1);
  # did it work?
      if ($response->is_error()) {
  	unlink($transferfile);
- Line 11571  sub tokenwrapper {
+ Line 14743  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 11589  sub getuploaded {
+ Line 14762  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);
+     my $response=&LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,'',0,1);
      $$rtncode = $response->code;
      if (! $response->is_success()) {
  	return 'failed';
- Line 11611  sub readfile {
+ Line 14784  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 11724  sub machine_ids {
+ Line 14897  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 11745  sub default_login_domain {
+ Line 14923  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 $url = $protocol{$lonhost}.'://'.$hostname.'/index.html';
+         my $request=new HTTP::Request('HEAD',$url);
+         my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,'','','',1);
+         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 = &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 = &host_domain($lonid);
+         if ($dom ne '') {
+             my $cachetime = 60*60*24;
+             my %domconfig =
+                 &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 = &host_domain($lonid);
+         if ($dom ne '') {
+             my $cachetime = 60*60*24;
+             my %domconfig =
+                 &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 (&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 = &host_domain($lonid);
+     if ($dom ne '') {
+         my $cachetime = 60*60*24;
+         my %domconfig =
+             &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 {
- Line 11795  sub clutter {
+ Line 15259  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 11860  sub get_dns {
+ Line 15326  sub get_dns {
      my ($url,$func,$ignore_cache,$nocache,$hashref) = @_;
      if (!$ignore_cache) {
  	my ($content,$cached)=
- 	    &Apache::lonnet::is_cached_new('dns',$url);
+ 	    &is_cached_new('dns',$url);
  	if ($cached) {
  	    &$func($content,$hashref);
  	    return;
- Line 11868  sub get_dns {
+ Line 15334  sub get_dns {
      }
      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) = sort { $b cmp $a } keys(%alldns);
- 	my $ua=new LWP::UserAgent;
+         my ($contents,@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")) {
-         unless ($nocache) {
+                 @content = <$config>;
- 	    &do_cache_new('dns',$url,\@content,30*24*60*60);
+                 close($config);
+             }
+             if ($url eq '/adm/dns/loncapaCRL') {
+                 $contents = join('',@content);
+             }
+         } else {
+ 	    my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
+             my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0);
+             delete($alldns{$dns});
+ 	    next if ($response->is_error());
+             if ($url eq '/adm/dns/loncapaCRL') {
+                 $contents = $response->content;
+             } else {
+                 @content = split("\n",$response->content);
+             }
+         }
+         if ($url eq '/adm/dns/loncapaCRL') {
+             return &$func($contents);
+         } else {
+ 	    unless ($nocache) {
+ 	        &do_cache_new('dns',$url,\@content,30*24*60*60);
+ 	    }
+ 	    &$func(\@content,$hashref);
+             return;
+         }
+     }
+     my $which = (split('/',$url,4))[3];
+     if ($which eq 'loncapaCRL') {
+         my $diskfile = "$perlvar{'lonCertificateDirectory'}/$perlvar{'lonnetCertRevocationList'}";
+         if (-e $diskfile) {
+             &logthis("unable to contact DNS, on disk file $diskfile not updated");
+         } else {
+             &logthis("unable to contact DNS, no on disk file $diskfile available");
+         }
+     } else {
+         &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");
+         if (open(my $config,"<","$perlvar{'lonTabDir'}/dns_$which.tab")) {
+             my @content = <$config>;
+             close($config);
+             &$func(\@content,$hashref);
          }
- 	&$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");
-     my @content = <$config>;
-     &$func(\@content,$hashref);
      return;
  }
  # ------------------------------------------------------Get DNS checksums file
  sub parse_dns_checksums_tab {
      my ($lines,$hashref) = @_;
-     my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});
+     my $lonhost = $perlvar{'lonHostID'};
+     my $machine_dom = &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;
              }
- Line 11931  sub parse_dns_checksums_tab {
+ Line 15449  sub parse_dns_checksums_tab {
  sub fetch_dns_checksums {
      my %checksums;
-     my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});
+     my $machine_dom = &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,
- Line 11939  sub fetch_dns_checksums {
+ Line 15457  sub fetch_dns_checksums {
      return \%checksums;
  }
+ sub fetch_crl_pemfile {
+     return &get_dns("/adm/dns/loncapaCRL",\&save_crl_pem,1,1);
+ }
+ sub save_crl_pem {
+     my ($content) = @_;
+     my ($msg,$hadchanges);
+     if ($content ne '') {
+         my $now = time;
+         my $lonca = $perlvar{'lonCertificateDirectory'}.'/'.$perlvar{'lonnetCertificateAuthority'};
+         my $tmpcrl = $tmpdir.'/'.$perlvar{'lonnetCertRevocationList'}.'_'.$now.'.'.$$.'.tmp';
+         if (open(my $fh,'>',"$tmpcrl")) {
+             print $fh $content;
+             close($fh);
+             if (-e $lonca) {
+                 if (open(PIPE,"openssl crl -in $tmpcrl -inform pem -CAfile $lonca -noout 2>&1 |")) {
+                     my $check = <PIPE>;
+                     close(PIPE);
+                     chomp($check);
+                     if ($check eq 'verify OK') {
+                         my $dest = "$perlvar{'lonCertificateDirectory'}/$perlvar{'lonnetCertRevocationList'}";
+                         my $backup;
+                         if (-e $dest) {
+                             if (&File::Copy::move($dest,"$dest.bak")) {
+                                 $backup = 'ok';
+                             }
+                         }
+                         if (&File::Copy::move($tmpcrl,$dest)) {
+                             $msg = 'ok';
+                             if ($backup) {
+                                 my (%oldnums,%newnums);
+                                 if (open(PIPE, "openssl crl -inform PEM -text -noout -in $dest.bak |grep 'Serial Number' |")) {
+                                     while (<PIPE>) {
+                                         $oldnums{(split(/:/))[1]} = 1;
+                                     }
+                                     close(PIPE);
+                                 }
+                                 if (open(PIPE, "openssl crl -inform PEM -text -noout -in $dest |grep 'Serial Number' |")) {
+                                     while(<PIPE>) {
+                                         $newnums{(split(/:/))[1]} = 1;
+                                     }
+                                     close(PIPE);
+                                 }
+                                 foreach my $key (sort {$b <=> $a } (keys(%newnums))) {
+                                     unless (exists($oldnums{$key})) {
+                                         $hadchanges = 1;
+                                         last;
+                                     }
+                                 }
+                                 unless ($hadchanges) {
+                                     foreach my $key (sort {$b <=> $a } (keys(%oldnums))) {
+                                         unless (exists($newnums{$key})) {
+                                             $hadchanges = 1;
+                                             last;
+                                         }
+                                     }
+                                 }
+                             }
+                         }
+                     } else {
+                         unlink($tmpcrl);
+                     }
+                 } else {
+                     unlink($tmpcrl);
+                 }
+             } else {
+                 unlink($tmpcrl);
+             }
+         }
+     }
+     return ($msg,$hadchanges);
+ }
+ 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",
+     } elsif ($command eq 'loncapaCRL') {
+         $dir = $perlvar{'lonCertificateDirectory'};
+         $file = $perlvar{'lonnetCertRevocationList'};
+     }
+     return ($dir,$file);
+ }
  # ------------------------------------------------------------ Read domain file
  {
      my $loaded;
- Line 11967  sub fetch_dns_checksums {
+ Line 15576  sub fetch_dns_checksums {
      }
      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 12022  sub fetch_dns_checksums {
+ Line 15631  sub fetch_dns_checksums {
  	    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 12046  sub fetch_dns_checksums {
+ Line 15670  sub fetch_dns_checksums {
  	&purge_remembered();
  	&reset_domain_info();
  	&reset_hosts_ip_info();
+         undef(%internetdom);
  	undef(%name_to_host);
  	undef(%hostname);
  	undef(%hostdom);
- Line 12054  sub fetch_dns_checksums {
+ Line 15679  sub fetch_dns_checksums {
      }
      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 12077  sub fetch_dns_checksums {
+ Line 15702  sub fetch_dns_checksums {
      }
      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 12087  sub fetch_dns_checksums {
+ Line 15713  sub fetch_dns_checksums {
          return %hostdom;
      }
+     sub all_host_intdom {
+         &load_hosts_tab() if (!$loaded);
+         return %internetdom;
+     }
      sub is_library {
  	&load_hosts_tab() if (!$loaded);
- Line 12199  sub fetch_dns_checksums {
+ Line 15830  sub fetch_dns_checksums {
      }
      sub get_iphost {
- 	my ($ignore_cache) = @_;
+ 	my ($ignore_cache,$nocache) = @_;
  	if (!$ignore_cache) {
  	    if (%iphost) {
  		return %iphost;
  	    }
  	    my ($ip_info,$cached)=
- 		&Apache::lonnet::is_cached_new('iphost','iphost');
+ 		&is_cached_new('iphost','iphost');
  	    if ($cached) {
  		%iphost      = %{$ip_info->[0]};
  		%name_to_ip  = %{$ip_info->[1]};
- Line 12218  sub fetch_dns_checksums {
+ Line 15849  sub fetch_dns_checksums {
  	# get yesterday's info for fallback
  	my %old_name_to_ip;
  	my ($ip_info,$cached)=
- 	    &Apache::lonnet::is_cached_new('iphost','iphost');
+ 	    &is_cached_new('iphost','iphost');
  	if ($cached) {
  	    %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 12248  sub fetch_dns_checksums {
+ Line 15879  sub fetch_dns_checksums {
  	    }
  	    push(@{$iphost{$ip}},@{$name_to_host{$name}});
  	}
- 	&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 12283  sub fetch_dns_checksums {
+ Line 15916  sub fetch_dns_checksums {
          my ($lonid) = @_;
          return if ($lonid eq '');
          my ($idnref,$cached)=
-             &Apache::lonnet::is_cached_new('internetnames',$lonid);
+             &is_cached_new('internetnames',$lonid);
          if ($cached) {
              return $idnref;
          }
- Line 12315  sub all_loncaparevs {
+ Line 15948  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 2.11);
  }
- # ------------------------------------------------------- Read loncaparev table
+ # ---------------------------------------------------------- Read loncaparev table
  {
      sub load_loncaparevs {
          if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") {
-             if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) {
+             if (open(my $config,"<","$perlvar{'lonTabDir'}/loncaparevs.tab")) {
                  while (my $configline=<$config>) {
                      chomp($configline);
                      my ($hostid,$loncaparev)=split(/:/,$configline);
- Line 12331  sub all_loncaparevs {
+ Line 15964  sub all_loncaparevs {
      }
  }
- # ----------------------------------------------------- Read serverhostID table
+ # ---------------------------------------------------------- Read serverhostID table
  {
      sub load_serverhomeIDs {
          if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") {
-             if (open(my $config,"<$perlvar{'lonTabDir'}/serverhomeIDs.tab")) {
+             if (open(my $config,"<","$perlvar{'lonTabDir'}/serverhomeIDs.tab")) {
                  while (my $configline=<$config>) {
                      chomp($configline);
                      my ($name,$id)=split(/:/,$configline);
- Line 12360  BEGIN {
+ Line 15993  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 12374  BEGIN {
+ Line 16007  BEGIN {
  }
  # ------------------------------------------------------------ Read permissions
  {
-     open(my $config,"<$perlvar{'lonTabDir'}/roles.tab");
+     open(my $config,"<","$perlvar{'lonTabDir'}/roles.tab");
      while (my $configline=<$config>) {
  	chomp($configline);
- Line 12388  BEGIN {
+ Line 16021  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 12408  BEGIN {
+ Line 16041  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 12423  BEGIN {
+ Line 16056  BEGIN {
      close($config);
  }
- # --------------------------------------------------------- Read loncaparev table
+ # ---------------------------------------------------------- Read loncaparev table
  &load_loncaparevs();
- # ------------------------------------------------------- Read serverhostID table
+ # ---------------------------------------------------------- Read serverhostID table
  &load_serverhomeIDs();
- Line 12441  BEGIN {
+ Line 16074  BEGIN {
                  my $item = $token->[1];
                  my $name = $token->[2]{'name'};
                  my $value = $token->[2]{'value'};
-                 if ($item ne '' && $name ne '' && $value ne '') {
+                 my $valuematch = $token->[2]{'valuematch'};
+                 my $namematch = $token->[2]{'namematch'};
+                 if ($item eq 'parameter') {
+                     if (($namematch ne '') || (($name ne '') && ($value ne '' || $valuematch ne ''))) {
+                         my $release = $parser->get_text();
+                         $release =~ s/(^\s*|\s*$ )//gx;
+                         $needsrelease{$item.':'.$name.':'.$value.':'.$valuematch.':'.$namematch} = $release;
+                     }
+                 } elsif ($item ne '' && $name ne '') {
                      my $release = $parser->get_text();
                      $release =~ s/(^\s*|\s*$ )//gx;
                      $needsrelease{$item.':'.$name.':'.$value} = $release;
- Line 12454  BEGIN {
+ Line 16095  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 12473  BEGIN {
+ Line 16114  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 12631  were new keys. I.E. 1:foo will become 1:
+ Line 16282  were new keys. I.E. 1:foo will become 1:
  Calling convention:
   my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname);
-  &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname);
+  &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$laststore);
  For more detailed information, see lonnet specific documentation.
- Line 12714  the answer, and also caches if there is
+ Line 16365  the answer, and also caches if there is
  =item *
  X<idget()>
- B<idget($udom,@ids)>: find the usernames behind a list of IDs
+ B<idget($udom,$idsref,$namespace)>: find the usernames behind either
- (IDs are a unique resource in a domain, there must be only 1 ID per
+ a list of student/employee IDs or clicker IDs
- username, and only 1 username per ID in a specific domain) (returns
+ (student/employee IDs are a unique resource in a domain, there must be
- hash: id=>name,id=>name)
+ only 1 ID per username, and only 1 username per ID in a specific domain).
+ clickerIDs are not necessarily unique, as students might share clickers.
+ (returns hash: id=>name,id=>name)
  =item *
  X<idrget()>
- Line 12726  usernames (returns hash: name=>id,name=>
+ Line 16379  usernames (returns hash: name=>id,name=>
  =item *
  X<idput()>
- B<idput($udom,%ids)>: store away a list of names and associated IDs
+ B<idput($udom,$idsref,$uhome,$namespace)>: store away a list of
+ names and associated student/employee IDs or clicker IDs.
+ =item *
+ X<iddel()>
+ B<iddel($udom,$idshashref,$uhome,$namespace)>: delete unwanted
+ student/employee ID or clicker ID username look-ups from domain.
+ The homeserver ($uhome) and namespace ($namespace) are optional.
+ If no $uhome is provided, it will be determined usig &homeserver()
+ for each user.  If no $namespace is provided, the default is ids.
+ =item *
+ X<updateclickers()>
+ B<updateclickers($udom,$action,$idshashref,$uhome,$critical)>: update
+ clicker ID-to-username look-ups in clickers.db on library server.
+ Permitted actions are add or del (i.e., add or delete). The
+ clickers.db contains clickerID as keys (escaped), and each corresponding
+ value is an escaped comma-separated list of usernames (for whom the
+ library server is the homeserver), who registered that particular ID.
+ If $critical is true, the update will be sent via &critical, otherwise
+ &reply() will be used.
  =item *
  X<rolesinit()>
- Line 12767  escaped strings of the action recorded i
+ Line 16440  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 *
- Line 12792  in which case the null string is returne
+ Line 16482  in which case the null string is returne
  =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 12825  provided for types, will default to retu
+ Line 16516  provided for types, will default to retu
  =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
- Line 12998  Inputs:
+ Line 16689  Inputs:
  =item $credits, number of credits student will earn from this class
+ =item $instsec, institutional course section code for student
  =back
- Line 13063  data base, returning a hash that is keye
+ Line 16756  data base, returning a hash that is keye
  values that are the resource value.  I believe that the timestamps and
  versions are also returned.
- get_numsuppfiles($cnum,$cdom) : retrieve number of files in a course's
- supplemental content area. This routine caches the number of files for
-minutes.
  =back
  =head2 Course Modification
- Line 13101  Returns:
+ Line 16790  Returns:
  =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
  =over 4
- Line 13152  condval($condidx) : value of condition i
+ Line 16923  condval($condidx) : value of condition i
  =item *
- metadata($uri,$what,$liburi,$prefix,$depthcount) : request a
+ metadata($uri,$what,$toolsymb,$liburi,$prefix,$depthcount) : request a
  resource's metadata, $what should be either a specific key, or either
  'keys' (to get a list of possible keys) or 'packages' to get a list of
- packages that this resource currently uses, the last 3 arguments are only used internally for recursive metadata.
+ packages that this resource currently uses, the last 3 arguments are
+ only used internally for recursive metadata.
+ the toolsymb is only used where the uri is for an external tool (for which
+ the uri as well as the symb are guaranteed to be unique).
- this function automatically caches all requests
+ this function automatically caches all requests except any made recursively
+ to retrieve a list of metadata keys for an imported library file ($liburi is
+ defined).
  =item *
- Line 13167  will be stored for query
+ Line 16944  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 *
- Line 13177  and is a possible symb for the URL in $t
+ Line 16967  and is a possible symb for the URL in $t
  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 existence of
  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 13232  expirespread($uname,$udom,$stype,$usymb)
+ Line 17022  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 --
- Line 13246  when viewing in course context.
+ Line 17036  when viewing in course context.
           $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.
- Line 13268  homeserver.
+ Line 17058  homeserver.
  =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 13299  $range should be either an integer '100'
+ Line 17095  $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 13412  server ($udom and $uhome are optional)
+ Line 17209  server ($udom and $uhome are optional)
  =item *
  get_domain_defaults($target_domain,$ignore_cache) : returns hash with defaults
  for: authentication, language, quotas, timezone, date locale, and portal URL in
  the target domain.
- Line 13446  requestcourses: ability to request cours
+ Line 17243  requestcourses: ability to request cours
  =over
  =item
- official, unofficial, community, textbook
+ official, unofficial, community, textbook, placement
  =back
- Line 13467  for course's uploaded content.
+ Line 17264  for course's uploaded content.
  =over
  =item
- canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota, communityquota, textbookquota
+ canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota,
+ communityquota, textbookquota, placementquota
  =back
- Line 13477  on your servers.
+ Line 17275  on your servers.
  =over
  =item
  remotesessions, hostedsessions
  =back
- Line 13485  remotesessions, hostedsessions
+ Line 17283  remotesessions, hostedsessions
  =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.
- Line 13771  userspace, probably shouldn't be called
+ Line 17569  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 13916  Returns:
+ Line 17715  Returns:
  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)
- Line 13928  Args: (first three required; six others
+ Line 17727  Args: (first three required; six others
 . 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:

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

Removed from v.1.1172.2.52
changed lines
	Added in v.1.1511