[BACK]Return to lonnet.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / lonnet / perl

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.1276 and 1.1524

version 1.1276, 2014/12/21 16:26:36 version 1.1524, 2024/03/29 17:32:03
Line 71  delayed. Line 71  delayed.
 package Apache::lonnet;  package Apache::lonnet;
   
 use strict;  use strict;
 use LWP::UserAgent();  
 use HTTP::Date;  use HTTP::Date;
 use Image::Magick;  use Image::Magick;
   use CGI::Cookie;
   
 use Encode;  use Encode;
   
 use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir  use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $deftex
             $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease              $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease
             %managerstab);              %managerstab $passwdmin);
   
 my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,  my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
     %userrolehash, $processmarker, $dumpcount, %coursedombuf,      %userrolehash, $processmarker, $dumpcount, %coursedombuf,
Line 92  use GDBM_File; Line 91  use GDBM_File;
 use HTML::LCParser;  use HTML::LCParser;
 use Fcntl qw(:flock);  use Fcntl qw(:flock);
 use Storable qw(thaw nfreeze);  use Storable qw(thaw nfreeze);
 use Time::HiRes qw( gettimeofday tv_interval );  use Time::HiRes qw( sleep gettimeofday tv_interval );
 use Cache::Memcached;  use Cache::Memcached;
 use Digest::MD5;  use Digest::MD5;
 use Math::Random;  use Math::Random;
 use File::MMagic;  use File::MMagic;
   use Net::CIDR;
   use Sys::Hostname::FQDN();
 use LONCAPA qw(:DEFAULT :match);  use LONCAPA qw(:DEFAULT :match);
 use LONCAPA::Configuration;  use LONCAPA::Configuration;
 use LONCAPA::lonmetadata;  use LONCAPA::lonmetadata;
 use LONCAPA::Lond;  use LONCAPA::Lond;
   use LONCAPA::LWPReq;
   use LONCAPA::transliterate;
   
 use File::Copy;  use File::Copy;
   
 my $readit;  my $readit;
 my $max_connection_retries = 10;     # Or some such value.  my $max_connection_retries = 20;     # Or some such value.
   
 require Exporter;  require Exporter;
   
Line 127  our @EXPORT = qw(%env); Line 130  our @EXPORT = qw(%env);
  $logid ++;   $logid ++;
         my $now = time();          my $now = time();
  my $id=$now.'00000'.$$.'00000'.$logid;   my $id=$now.'00000'.$$.'00000'.$logid;
           my $ip = &get_requestor_ip();
         my $logentry = {           my $logentry = { 
                           $id => {                            $id => {
                                    'exe_uname' => $env{'user.name'},                                     'exe_uname' => $env{'user.name'},
                                    'exe_udom'  => $env{'user.domain'},                                     'exe_udom'  => $env{'user.domain'},
                                    'exe_time'  => $now,                                     'exe_time'  => $now,
                                    'exe_ip'    => $ENV{'REMOTE_ADDR'},                                     'exe_ip'    => $ip,
                                    'delflag'   => $delflag,                                     'delflag'   => $delflag,
                                    'logentry'  => $storehash,                                     'logentry'  => $storehash,
                                    'uname'     => $uname,                                     'uname'     => $uname,
Line 146  our @EXPORT = qw(%env); Line 150  our @EXPORT = qw(%env);
 sub logtouch {  sub logtouch {
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     unless (-e "$execdir/logs/lonnet.log") {      unless (-e "$execdir/logs/lonnet.log") {
  open(my $fh,">>$execdir/logs/lonnet.log");   open(my $fh,">>","$execdir/logs/lonnet.log");
  close $fh;   close $fh;
     }      }
     my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];      my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];
Line 158  sub logthis { Line 162  sub logthis {
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     my $now=time;      my $now=time;
     my $local=localtime($now);      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.   my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string.
  print $fh $logstring;   print $fh $logstring;
  close($fh);   close($fh);
Line 171  sub logperm { Line 175  sub logperm {
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     my $now=time;      my $now=time;
     my $local=localtime($now);      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";   print $fh "$now:$message:$local\n";
  close($fh);   close($fh);
     }      }
Line 184  sub create_connection { Line 188  sub create_connection {
      Type    => SOCK_STREAM,       Type    => SOCK_STREAM,
      Timeout => 10);       Timeout => 10);
     return 0 if (!$client);      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>;      my $result = <$client>;
     chomp($result);      chomp($result);
     return 1 if ($result eq 'done');      return 1 if ($result eq 'done');
Line 229  sub get_server_distarch { Line 233  sub get_server_distarch {
     return;      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 {  sub get_server_loncaparev {
     my ($dom,$lonhost,$ignore_cache,$caller) = @_;      my ($dom,$lonhost,$ignore_cache,$caller) = @_;
     if (defined($lonhost)) {      if (defined($lonhost)) {
Line 263  sub get_server_loncaparev { Line 315  sub get_server_loncaparev {
             $answer = &reply('serverloncaparev',$lonhost);              $answer = &reply('serverloncaparev',$lonhost);
             if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) {              if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) {
                 if ($caller eq 'loncron') {                  if ($caller eq 'loncron') {
                     my $ua=new LWP::UserAgent;                      my $hostname = &hostname($lonhost);
                     $ua->timeout(4);  
                     my $protocol = $protocol{$lonhost};                      my $protocol = $protocol{$lonhost};
                     $protocol = 'http' if ($protocol ne 'https');                      $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 $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()) {                      unless ($response->is_error()) {
                         my $content = $response->content;                          my $content = $response->content;
                         if ($content =~ /<p>VERSION\:\s*([\w.\-]+)<\/p>/) {                          if ($content =~ /<p>VERSION\:\s*([\w.\-]+)<\/p>/) {
Line 364  sub remote_devalidate_cache { Line 415  sub remote_devalidate_cache {
     return $response;      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  # -------------------------------------------------- Non-critical communication
 sub subreply {  sub subreply {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
Line 375  sub subreply { Line 483  sub subreply {
   
     my $lockfile=$peerfile.".lock";      my $lockfile=$peerfile.".lock";
     while (-e $lockfile) { # Need to wait for the lockfile to disappear.      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      # 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.      # or loncnew child is listening so we can connect or everything's dead.
Line 393  sub subreply { Line 501  sub subreply {
  } else {   } else {
     &create_connection(&hostname($server),$server);      &create_connection(&hostname($server),$server);
  }   }
         sleep(1); # Try again later if failed connection.          sleep(0.1); # Try again later if failed connection.
     }      }
     my $answer;      my $answer;
     if ($client) {      if ($client) {
Line 412  sub reply { Line 520  sub reply {
     unless (defined(&hostname($server))) { return 'no_such_host'; }      unless (defined(&hostname($server))) { return 'no_such_host'; }
     my $answer=subreply($cmd,$server);      my $answer=subreply($cmd,$server);
     if (($answer=~/^refused/) || ($answer=~/^rejected/)) {      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;      return $answer;
 }  }
Line 422  sub reply { Line 549  sub reply {
   
 sub reconlonc {  sub reconlonc {
     my ($lonid) = @_;      my ($lonid) = @_;
     my $hostname = &hostname($lonid);  
     if ($lonid) {      if ($lonid) {
           my $hostname = &hostname($lonid);
  my $peerfile="$perlvar{'lonSockDir'}/$hostname";   my $peerfile="$perlvar{'lonSockDir'}/$hostname";
  if ($hostname && -e $peerfile) {   if ($hostname && -e $peerfile) {
     &logthis("Trying to reconnect lonc for $lonid ($hostname)");      &logthis("Trying to reconnect lonc for $lonid ($hostname)");
Line 441  sub reconlonc { Line 568  sub reconlonc {
   
     &logthis("Trying to reconnect lonc");      &logthis("Trying to reconnect lonc");
     my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";      my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
     if (open(my $fh,"<$loncfile")) {      if (open(my $fh,"<",$loncfile)) {
  my $loncpid=<$fh>;   my $loncpid=<$fh>;
         chomp($loncpid);          chomp($loncpid);
         if (kill 0 => $loncpid) {          if (kill 0 => $loncpid) {
     &logthis("lonc at pid $loncpid responding, sending USR1");      &logthis("lonc at pid $loncpid responding, sending USR1");
             kill USR1 => $loncpid;              kill USR1 => $loncpid;
             sleep 1;              sleep 1;
          } else {          } else {
     &logthis(      &logthis(
                "<font color=\"blue\">WARNING:".                 "<font color=\"blue\">WARNING:".
                " lonc at pid $loncpid not responding, giving up</font>");                 " lonc at pid $loncpid not responding, giving up</font>");
Line 469  sub critical { Line 596  sub critical {
     }      }
     my $answer=reply($cmd,$server);      my $answer=reply($cmd,$server);
     if ($answer eq 'con_lost') {      if ($answer eq 'con_lost') {
  &reconlonc("$perlvar{'lonSockDir'}/$server");   &reconlonc($server);
  my $answer=reply($cmd,$server);   my $answer=reply($cmd,$server);
         if ($answer eq 'con_lost') {          if ($answer eq 'con_lost') {
             my $now=time;              my $now=time;
Line 481  sub critical { Line 608  sub critical {
             $dumpcount++;              $dumpcount++;
             {              {
  my $dfh;   my $dfh;
  if (open($dfh,">$dfilename")) {   if (open($dfh,">",$dfilename)) {
     print $dfh "$cmd\n";       print $dfh "$cmd\n"; 
     close($dfh);      close($dfh);
  }   }
             }              }
             sleep 2;              sleep 1;
             my $wcmd='';              my $wcmd='';
             {              {
  my $dfh;   my $dfh;
  if (open($dfh,"<$dfilename")) {   if (open($dfh,"<",$dfilename)) {
     $wcmd=<$dfh>;       $wcmd=<$dfh>; 
     close($dfh);      close($dfh);
  }   }
Line 606  sub transfer_profile_to_env { Line 733  sub transfer_profile_to_env {
   
 # ---------------------------------------------------- Check for valid session   # ---------------------------------------------------- Check for valid session 
 sub 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'));      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') {      if ($name eq 'lonDAV') {
         $lonidsdir=$r->dir_config('lonDAVsessDir');          $lonidsdir=$r->dir_config('lonDAVsessDir');
     } else {      } else {
         $lonidsdir=$r->dir_config('lonIDsDir');          $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");      my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
     return undef if (!$opened);      return undef if (!$opened);
Line 635  sub check_for_valid_session { Line 792  sub check_for_valid_session {
   
     if (!defined($disk_env{'user.name'})      if (!defined($disk_env{'user.name'})
  || !defined($disk_env{'user.domain'})) {   || !defined($disk_env{'user.domain'})) {
           untie(%disk_env);
  return undef;   return undef;
     }      }
   
     if (ref($userhashref) eq 'HASH') {      if (ref($userhashref) eq 'HASH') {
         $userhashref->{'name'} = $disk_env{'user.name'};          $userhashref->{'name'} = $disk_env{'user.name'};
         $userhashref->{'domain'} = $disk_env{'user.domain'};          $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;      return $handle;
 }  }
Line 666  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  # ---------------------------------------------------------- Append Environment
   
 sub appenv {  sub appenv {
Line 691  sub appenv { Line 889  sub appenv {
                 $env{$key}=$newenv->{$key};                  $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';      return 'ok';
Line 816  sub userload { Line 1017  sub userload {
  while ($filename=readdir(LONIDS)) {   while ($filename=readdir(LONIDS)) {
     next if ($filename eq '.' || $filename eq '..');      next if ($filename eq '.' || $filename eq '..');
     next if ($filename =~ /publicuser_\d+\.id/);      next if ($filename =~ /publicuser_\d+\.id/);
               next if ($filename =~ /^[a-f0-9]+_linked\.id$/);
     my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];      my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
     if ($curtime-$mtime < 1800) { $numusers++; }      if ($curtime-$mtime < 1800) { $numusers++; }
  }   }
Line 833  sub userload { Line 1035  sub userload {
 # ------------------------------ Find server with least workload from spare.tab  # ------------------------------ Find server with least workload from spare.tab
   
 sub spareserver {  sub spareserver {
     my ($loadpercent,$userloadpercent,$want_server_name,$udom) = @_;      my ($r,$loadpercent,$userloadpercent,$want_server_name,$udom) = @_;
     my $spare_server;      my $spare_server;
     if ($userloadpercent !~ /\d/) { $userloadpercent=0; }      if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
     my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent       my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent 
                                                      :  $userloadpercent;                                                       :  $userloadpercent;
     my ($uint_dom,$remotesessions);      my ($uint_dom,$remotesessions);
     if (($udom ne '') && (&domain($udom) ne '')) {      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'};          $remotesessions = $udomdefaults{'remotesessions'};
     }      }
     my $spareshash = &this_host_spares($udom);      my $spareshash = &this_host_spares($udom);
     if (ref($spareshash) eq 'HASH') {      if (ref($spareshash) eq 'HASH') {
         if (ref($spareshash->{'primary'}) eq 'ARRAY') {          if (ref($spareshash->{'primary'}) eq 'ARRAY') {
             foreach my $try_server (@{ $spareshash->{'primary'} }) {              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) =          ($spare_server, $lowest_load) =
             &compare_server_load($try_server, $spare_server, $lowest_load);              &compare_server_load($try_server, $spare_server, $lowest_load);
             }              }
Line 863  sub spareserver { Line 1063  sub spareserver {
         if (!$found_server) {          if (!$found_server) {
             if (ref($spareshash->{'default'}) eq 'ARRAY') {               if (ref($spareshash->{'default'}) eq 'ARRAY') { 
         foreach my $try_server (@{ $spareshash->{'default'} }) {          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) =              ($spare_server, $lowest_load) =
         &compare_server_load($try_server, $spare_server, $lowest_load);          &compare_server_load($try_server, $spare_server, $lowest_load);
                 }                  }
Line 875  sub spareserver { Line 1073  sub spareserver {
     }      }
   
     if (!$want_server_name) {      if (!$want_server_name) {
         my $protocol = 'http';  
         if ($protocol{$spare_server} eq 'https') {  
             $protocol = $protocol{$spare_server};  
         }  
         if (defined($spare_server)) {          if (defined($spare_server)) {
             my $hostname = &hostname($spare_server);              my $hostname = &hostname($spare_server);
             if (defined($hostname)) {              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;          $spare_server = $protocol.'://'.$hostname;
             }              }
         }          }
Line 948  sub find_existing_session { Line 1148  sub find_existing_session {
     return;      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  # -------------------------------- ask if server already has a session for user
 sub has_user_session {  sub has_user_session {
     my ($lonid,$udom,$uname) = @_;      my ($lonid,$udom,$uname) = @_;
Line 971  sub choose_server { Line 1268  sub choose_server {
         unless (defined($cached)) {          unless (defined($cached)) {
             my $cachetime = 60*60*24;              my $cachetime = 60*60*24;
             my %domconfig =              my %domconfig =
                 &Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom);                  &get_dom('configuration',['loadbalancing'],$udom);
             if (ref($domconfig{'loadbalancing'}) eq 'HASH') {              if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
                 $balancers = &do_cache_new('loadbalancing',$udom,$domconfig{'loadbalancing'},                  $balancers = &do_cache_new('loadbalancing',$udom,$domconfig{'loadbalancing'},
                                            $cachetime);                                             $cachetime);
Line 983  sub choose_server { Line 1280  sub choose_server {
             if (ref($balancers) eq 'HASH') {              if (ref($balancers) eq 'HASH') {
                 next if (exists($balancers->{$lonhost}));                  next if (exists($balancers->{$lonhost}));
             }              }
         }             }
         my $loginvia;          my $loginvia;
         if ($checkloginvia) {          if ($checkloginvia) {
             $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};              $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};
Line 1011  sub choose_server { Line 1308  sub choose_server {
     if ($login_host ne '') {      if ($login_host ne '') {
         $hostname = &hostname($login_host);          $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  # --------------------------------------------- Try to change a user's password
Line 1049  sub changepass { Line 1368  sub changepass {
     } elsif ($answer =~ "invalid_client") {      } elsif ($answer =~ "invalid_client") {
         &logthis("$server refused to change $uname in $udom password because ".          &logthis("$server refused to change $uname in $udom password because ".
                  "it was a reset by e-mail originating from an invalid server.");                   "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;      return $answer;
 }  }
Line 1058  sub changepass { Line 1380  sub changepass {
 sub queryauthenticate {  sub queryauthenticate {
     my ($uname,$udom)=@_;      my ($uname,$udom)=@_;
     my $uhome=&homeserver($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");   &logthis("User $uname at $udom is unknown when looking for authentication mechanism");
  return 'no_host';   return 'no_host';
     }      }
Line 1107  sub authenticate { Line 1429  sub authenticate {
     }      }
     if ($answer eq 'non_authorized') {      if ($answer eq 'non_authorized') {
  &logthis("User $uname at $udom rejected by $uhome");   &logthis("User $uname at $udom rejected by $uhome");
  return 'no_host';    return 'no_host';
     }      }
     &logthis("User $uname at $udom threw error $answer when checking authentication mechanism");      &logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
     return 'no_host';      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 {  sub can_host_session {
     my ($udom,$lonhost,$remoterev,$remotesessions,$hostedsessions) = @_;      my ($udom,$lonhost,$remoterev,$remotesessions,$hostedsessions) = @_;
     my $canhost = 1;      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) eq 'HASH') {
         if (ref($remotesessions->{'excludedomain'}) eq 'ARRAY') {          if (ref($remotesessions->{'excludedomain'}) eq 'ARRAY') {
             if (grep(/^\Q$host_idn\E$/,@{$remotesessions->{'excludedomain'}})) {              if (grep(/^\Q$host_idn\E$/,@{$remotesessions->{'excludedomain'}})) {
Line 1152  sub can_host_session { Line 1497  sub can_host_session {
     }      }
     if ($canhost) {      if ($canhost) {
         if (ref($hostedsessions) eq 'HASH') {          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 (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') {
                 if (($uint_dom ne '') &&                   if (($uint_dom ne '') && 
                     (grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'excludedomain'}}))) {                      (grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'excludedomain'}}))) {
Line 1178  sub can_host_session { Line 1523  sub can_host_session {
 sub spare_can_host {  sub spare_can_host {
     my ($udom,$uint_dom,$remotesessions,$try_server)=@_;      my ($udom,$uint_dom,$remotesessions,$try_server)=@_;
     my $canhost=1;      my $canhost=1;
     my @intdoms;      my $try_server_hostname = &hostname($try_server);
     my $internet_names = &Apache::lonnet::get_internet_names($try_server);      my $serverhomeID = &get_server_homeID($try_server_hostname);
     if (ref($internet_names) eq 'ARRAY') {      my $serverhomedom = &host_domain($serverhomeID);
         @intdoms = @{$internet_names};      my %defdomdefaults = &get_domain_defaults($serverhomedom);
       if (ref($defdomdefaults{'offloadnow'}) eq 'HASH') {
           if ($defdomdefaults{'offloadnow'}{$try_server}) {
               $canhost = 0;
           }
     }      }
     unless (grep(/^\Q$uint_dom\E$/,@intdoms)) {      if ($canhost) {
         my $serverhomeID = &Apache::lonnet::get_server_homeID($try_server);          if (ref($defdomdefaults{'offloadoth'}) eq 'HASH') {
         my $serverhomedom = &Apache::lonnet::host_domain($serverhomeID);              if ($defdomdefaults{'offloadoth'}{$try_server}) {
         my %defdomdefaults = &Apache::lonnet::get_domain_defaults($serverhomedom);                  unless (&shared_institution($udom,$try_server)) {
         my $remoterev = &Apache::lonnet::get_server_loncaparev(undef,$try_server);                      $canhost = 0;
         $canhost = &can_host_session($udom,$try_server,$remoterev,                  }
                                      $remotesessions,              }
                                      $defdomdefaults{'hostedsessions'});          }
       }
       if (($canhost) && ($uint_dom)) {
           my @intdoms;
           my $internet_names = &get_internet_names($try_server);
           if (ref($internet_names) eq 'ARRAY') {
               @intdoms = @{$internet_names};
           }
           unless (grep(/^\Q$uint_dom\E$/,@intdoms)) {
               my $remoterev = &get_server_loncaparev(undef,$try_server);
               $canhost = &can_host_session($udom,$try_server,$remoterev,
                                            $remotesessions,
                                            $defdomdefaults{'hostedsessions'});
           }
     }      }
     return $canhost;      return $canhost;
 }  }
Line 1228  sub spares_for_offload  { Line 1590  sub spares_for_offload  {
     } else {      } else {
         my $cachetime = 60*60*24;          my $cachetime = 60*60*24;
         my %domconfig =          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'}) eq 'HASH') {
             if (ref($domconfig{'usersessions'}{'spares'}) eq 'HASH') {              if (ref($domconfig{'usersessions'}{'spares'}) eq 'HASH') {
                 if (ref($domconfig{'usersessions'}{'spares'}{$lonhost_in_use}) eq 'HASH') {                  if (ref($domconfig{'usersessions'}{'spares'}{$lonhost_in_use}) eq 'HASH') {
Line 1275  sub get_lonbalancer_config { Line 1637  sub get_lonbalancer_config {
 }  }
   
 sub check_loadbalancing {  sub check_loadbalancing {
     my ($uname,$udom) = @_;      my ($uname,$udom,$caller) = @_;
     my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom,      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 $lonhost = $perlvar{'lonHostID'};
     my @hosts = &current_machine_ids();      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 $serverhomedom = &host_domain($lonhost);
       my $domneedscache;
     my $cachetime = 60*60*24;      my $cachetime = 60*60*24;
   
     if (($uintdom ne '') && ($uintdom eq $intdom)) {      if (($uintdom ne '') && ($uintdom eq $intdom)) {
Line 1296  sub check_loadbalancing { Line 1658  sub check_loadbalancing {
     my ($result,$cached)=&is_cached_new('loadbalancing',$dom_in_use);      my ($result,$cached)=&is_cached_new('loadbalancing',$dom_in_use);
     unless (defined($cached)) {      unless (defined($cached)) {
         my %domconfig =          my %domconfig =
             &Apache::lonnet::get_dom('configuration',['loadbalancing'],$dom_in_use);              &get_dom('configuration',['loadbalancing'],$dom_in_use);
         if (ref($domconfig{'loadbalancing'}) eq 'HASH') {          if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
             $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime);              $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime);
           } else {
               $domneedscache = $dom_in_use;
         }          }
     }      }
     if (ref($result) eq 'HASH') {      if (ref($result) eq 'HASH') {
         ($is_balancer,$currtargets,$currrules) =           ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers) =
             &check_balancer_result($result,@hosts);              &check_balancer_result($result,@hosts);
         if ($is_balancer) {          if ($is_balancer) {
             if (ref($currrules) eq 'HASH') {              if (ref($currrules) eq 'HASH') {
Line 1355  sub check_loadbalancing { Line 1719  sub check_loadbalancing {
         ($result,$cached)=&is_cached_new('loadbalancing',$serverhomedom);          ($result,$cached)=&is_cached_new('loadbalancing',$serverhomedom);
         unless (defined($cached)) {          unless (defined($cached)) {
             my %domconfig =              my %domconfig =
                 &Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom);                  &get_dom('configuration',['loadbalancing'],$serverhomedom);
             if (ref($domconfig{'loadbalancing'}) eq 'HASH') {              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') {          if (ref($result) eq 'HASH') {
             ($is_balancer,$currtargets,$currrules) =               ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers) =
                 &check_balancer_result($result,@hosts);                  &check_balancer_result($result,@hosts);
             if ($is_balancer) {              if ($is_balancer) {
                 if (ref($currrules) eq 'HASH') {                  if (ref($currrules) eq 'HASH') {
Line 1377  sub check_loadbalancing { Line 1743  sub check_loadbalancing {
                 $is_balancer = 1;                  $is_balancer = 1;
                 $offloadto = &this_host_spares($dom_in_use);                  $offloadto = &this_host_spares($dom_in_use);
             }              }
               unless (defined($cached)) {
                   $domneedscache = $serverhomedom;
               }
         }          }
     } else {      } else {
         if ($perlvar{'lonBalancer'} eq 'yes') {          if ($perlvar{'lonBalancer'} eq 'yes') {
             $is_balancer = 1;              $is_balancer = 1;
             $offloadto = &this_host_spares($dom_in_use);              $offloadto = &this_host_spares($dom_in_use);
         }          }
           unless (defined($cached)) {
               $domneedscache = $serverhomedom;
           }
     }      }
     if ($is_balancer) {      if ($domneedscache) {
           &do_cache_new('loadbalancing',$domneedscache,$is_balancer,$cachetime);
       }
       if (($is_balancer) && ($caller ne 'switchserver')) {
         my $lowest_load = 30000;          my $lowest_load = 30000;
         if (ref($offloadto) eq 'HASH') {          if (ref($offloadto) eq 'HASH') {
             if (ref($offloadto->{'primary'}) eq 'ARRAY') {              if (ref($offloadto->{'primary'}) eq 'ARRAY') {
Line 1413  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 {  sub check_balancer_result {
     my ($result,@hosts) = @_;      my ($result,@hosts) = @_;
     my ($is_balancer,$currtargets,$currrules);      my ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers);
     if (ref($result) eq 'HASH') {      if (ref($result) eq 'HASH') {
         if ($result->{'lonhost'} ne '') {          if ($result->{'lonhost'} ne '') {
             my $currbalancer = $result->{'lonhost'};              my $currbalancer = $result->{'lonhost'};
Line 1438  sub check_balancer_result { Line 1817  sub check_balancer_result {
                 $currtargets = $result->{'targets'};                  $currtargets = $result->{'targets'};
                 $currrules = $result->{'rules'};                  $currrules = $result->{'rules'};
             }              }
               $dom_balancers = $currbalancer;
         } else {          } 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 {  sub get_loadbalancer_targets {
Line 1468  sub get_loadbalancer_targets { Line 1852  sub get_loadbalancer_targets {
             }              }
         } elsif ($rule_in_effect eq 'externalbalancer') {          } elsif ($rule_in_effect eq 'externalbalancer') {
             my %domconfig =              my %domconfig =
                 &Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom);                  &get_dom('configuration',['loadbalancing'],$udom);
             if (ref($domconfig{'loadbalancing'}) eq 'HASH') {              if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
                 if ($domconfig{'loadbalancing'}{'lonhost'} ne '') {                  if ($domconfig{'loadbalancing'}{'lonhost'} ne '') {
                     if (&hostname($domconfig{'loadbalancing'}{'lonhost'}) ne '') {                      if (&hostname($domconfig{'loadbalancing'}{'lonhost'}) ne '') {
Line 1522  sub internet_dom_servers { Line 1906  sub internet_dom_servers {
     return %uniqservers;      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  # ---------------------- Find the homebase for a user from domain's lib servers
   
 my %homecache;  my %homecache;
Line 1547  sub homeserver { Line 2026  sub homeserver {
     return 'no_host';      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 {  sub idget {
     my ($udom,@ids)=@_;      my ($udom,$idsref,$namespace)=@_;
     my %returnhash=();      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');      my %servers = &get_servers($udom,'library');
     foreach my $tryserver (keys(%servers)) {      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=();   my @answer=();
  if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {   if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {
     @answer=split(/\&/,$reply);      @answer=split(/\&/,$reply);
Line 1565  sub idget { Line 2060  sub idget {
  my $i;   my $i;
  for ($i=0;$i<=$#ids;$i++) {   for ($i=0;$i<=$#ids;$i++) {
     if ($answer[$i]) {      if ($answer[$i]) {
  $returnhash{$ids[$i]}=$answer[$i];   $returnhash{$ids[$i]}=&unescape($answer[$i]);
     }       }
  }   }
     }       }
     return %returnhash;      return %returnhash;
 }  }
   
Line 1583  sub idrget { Line 2078  sub idrget {
     return %returnhash;      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 {  sub idput {
     my ($udom,%ids)=@_;      my ($udom,$idsref,$uhom,$namespace)=@_;
     my %servers=();      my %servers=();
       my %ids=();
       my %byid = ();
       if (ref($idsref) eq 'HASH') {
           %ids=%{$idsref};
       }
       if ($namespace eq '') {
           $namespace = 'ids'; 
       }
     foreach my $uname (keys(%ids)) {      foreach my $uname (keys(%ids)) {
  &cput('environment',{'id'=>$ids{$uname}},$udom,$uname);   &cput('environment',{'id'=>$ids{$uname}},$udom,$uname);
         my $uhom=&homeserver($uname,$udom);          if ($uhom eq '') {
               $uhom=&homeserver($uname,$udom);
           }
         if ($uhom ne 'no_host') {          if ($uhom ne 'no_host') {
             my $id=&escape($ids{$uname});  
             $id=~tr/A-Z/a-z/;  
             my $esc_unam=&escape($uname);              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 {              } 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)) {      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 {  sub iddel {
     my ($udom,$idshashref,$uhome)=@_;      my ($udom,$idshashref,$uhome,$namespace)=@_;
     my %result=();      my %result=();
     unless (ref($idshashref) eq 'HASH') {      my %ids=();
       my %byid = ();
       if (ref($idshashref) eq 'HASH') {
           %ids=%{$idshashref};
       } else {
         return %result;          return %result;
     }      }
       if ($namespace eq '') {
           $namespace = 'ids';
       }
     my %servers=();      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);                  $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)) {      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;      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  # ------------------------------dump from db file owned by domainconfig user
 sub dump_dom {  sub dump_dom {
     my ($namespace, $udom, $regexp) = @_;      my ($namespace, $udom, $regexp) = @_;
Line 1651  sub dump_dom { Line 2227  sub dump_dom {
 # ------------------------------------------ get items from domain db files     # ------------------------------------------ get items from domain db files   
   
 sub get_dom {  sub get_dom {
     my ($namespace,$storearr,$udom,$uhome)=@_;      my ($namespace,$storearr,$udom,$uhome,$encrypt)=@_;
     return if ($udom eq 'public');      return if ($udom eq 'public');
     my $items='';      my $items='';
     foreach my $item (@$storearr) {      foreach my $item (@$storearr) {
Line 1674  sub get_dom { Line 2250  sub get_dom {
         }          }
     }      }
     if ($udom && $uhome && ($uhome ne 'no_host')) {      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;          my %returnhash;
         if ($rep eq '' || $rep =~ /^error: 2 /) {          if ($rep eq '' || $rep =~ /^error: 2 /) {
             return %returnhash;              return %returnhash;
Line 1697  sub get_dom { Line 2283  sub get_dom {
 # -------------------------------------------- put items in domain db files   # -------------------------------------------- put items in domain db files 
   
 sub put_dom {  sub put_dom {
     my ($namespace,$storehash,$udom,$uhome)=@_;      my ($namespace,$storehash,$udom,$uhome,$encrypt)=@_;
     if (!$udom) {      if (!$udom) {
         $udom=$env{'user.domain'};          $udom=$env{'user.domain'};
         if (defined(&domain($udom,'primary'))) {          if (defined(&domain($udom,'primary'))) {
Line 1718  sub put_dom { Line 2304  sub put_dom {
             $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';              $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
         }          }
         $items=~s/\&$//;          $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 {      } else {
         &logthis("put_dom failed - no homeserver and/or domain");          &logthis("put_dom failed - no homeserver and/or domain");
     }      }
Line 1752  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   # ----------------------------------construct domainconfig user for a domain 
 sub get_domainconfiguser {  sub get_domainconfiguser {
     my ($udom) = @_;      my ($udom) = @_;
Line 1761  sub get_domainconfiguser { Line 2402  sub get_domainconfiguser {
 sub retrieve_inst_usertypes {  sub retrieve_inst_usertypes {
     my ($udom) = @_;      my ($udom) = @_;
     my (%returnhash,@order);      my (%returnhash,@order);
     my %domdefs = &Apache::lonnet::get_domain_defaults($udom);      my %domdefs = &get_domain_defaults($udom);
     if ((ref($domdefs{'inststatustypes'}) eq 'HASH') &&       if ((ref($domdefs{'inststatustypes'}) eq 'HASH') && 
         (ref($domdefs{'inststatusorder'}) eq 'ARRAY')) {          (ref($domdefs{'inststatusorder'}) eq 'ARRAY')) {
         return ($domdefs{'inststatustypes'},$domdefs{'inststatusorder'});          return ($domdefs{'inststatustypes'},$domdefs{'inststatusorder'});
Line 1794  sub retrieve_inst_usertypes { Line 2435  sub retrieve_inst_usertypes {
   
 sub is_domainimage {  sub is_domainimage {
     my ($url) = @_;      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 '') {          if (&domain($1) ne '') {
             return '1';              return '1';
         }          }
Line 1809  sub inst_directory_query { Line 2450  sub inst_directory_query {
     my $homeserver = &domain($udom,'primary');      my $homeserver = &domain($udom,'primary');
     my $outcome;      my $outcome;
     if ($homeserver ne '') {      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:".   my $queryid=&reply("querysend:instdirsearch:".
    &escape($srch->{'srchby'}).':'.     &escape($srch->{'srchby'}).':'.
    &escape($srch->{'srchterm'}).':'.     &escape($srch->{'srchterm'}).':'.
    &escape($srch->{'srchtype'}),$homeserver);     &escape($srch->{'srchtype'}),$homeserver);
  my $host=&hostname($homeserver);   my $host=&hostname($homeserver);
  if ($queryid !~/^\Q$host\E\_/) {   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;      return;
  }   }
  my $response = &get_query_reply($queryid);   my $response = &get_query_reply($queryid);
Line 1850  sub usersearch { Line 2501  sub usersearch {
     my $query = 'usersearch';      my $query = 'usersearch';
     foreach my $tryserver (keys(%libserv)) {      foreach my $tryserver (keys(%libserv)) {
         if (&host_domain($tryserver) eq $dom) {          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 $host=&hostname($tryserver);
             my $queryid=              my $queryid=
                 &reply("querysend:".&escape($query).':'.                  &reply("querysend:".&escape($query).':'.
Line 1935  sub get_instuser { Line 2594  sub get_instuser {
     return ($outcome,%userinfo);      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 {  sub inst_rulecheck {
     my ($udom,$uname,$id,$item,$rules) = @_;      my ($udom,$uname,$id,$item,$rules) = @_;
     my %returnhash;      my %returnhash;
Line 1957  sub inst_rulecheck { Line 2673  sub inst_rulecheck {
                     $response=&unescape(&reply('instselfcreatecheck:'.                      $response=&unescape(&reply('instselfcreatecheck:'.
                                                &escape($udom).':'.&escape($uname).                                                 &escape($udom).':'.&escape($uname).
                                               ':'.$rulestr,$homeserver));                                                ':'.$rulestr,$homeserver));
                   } elsif ($item eq 'unamemap') {
                       $response=&unescape(&reply('instunamemapcheck:'.
                                                  &escape($udom).':'.&escape($uname).
                                                 ':'.$rulestr,$homeserver));
                 }                  }
                 if ($response ne 'refused') {                  if ($response ne 'refused') {
                     my @pairs=split(/\&/,$response);                      my @pairs=split(/\&/,$response);
Line 1986  sub inst_userrules { Line 2706  sub inst_userrules {
             } elsif ($check eq 'email') {              } elsif ($check eq 'email') {
                 $response=&reply('instemailrules:'.&escape($udom),                  $response=&reply('instemailrules:'.&escape($udom),
                                  $homeserver);                                   $homeserver);
               } elsif ($check eq 'unamemap') {
                   $response=&reply('unamemaprules:'.&escape($udom),
                                    $homeserver); 
             } else {              } else {
                 $response=&reply('instuserrules:'.&escape($udom),                  $response=&reply('instuserrules:'.&escape($udom),
                                  $homeserver);                                   $homeserver);
Line 2027  sub get_domain_defaults { Line 2750  sub get_domain_defaults {
     }      }
     my %domdefaults;      my %domdefaults;
     my %domconfig =      my %domconfig =
          &Apache::lonnet::get_dom('configuration',['defaults','quotas',           &get_dom('configuration',['defaults','quotas',
                                   'requestcourses','inststatus',                                    'requestcourses','inststatus',
                                   'coursedefaults','usersessions',                                    'coursedefaults','usersessions',
                                   'requestauthor','selfenrollment',                                    'requestauthor','authordefaults',
                                   'coursecategories'],$domain);                                    'selfenrollment','coursecategories',
     my @coursetypes = ('official','unofficial','community','textbook');                                    'ssl','autoenroll','trust',
                                     'helpsettings','wafproxy',
                                     'ltisec','toolsec','privacy'],$domain);
       my @coursetypes = ('official','unofficial','community','textbook','placement');
     if (ref($domconfig{'defaults'}) eq 'HASH') {      if (ref($domconfig{'defaults'}) eq 'HASH') {
         $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};           $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; 
         $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};          $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
Line 2040  sub get_domain_defaults { Line 2766  sub get_domain_defaults {
         $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};          $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};
         $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};          $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};
         $domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_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 {      } else {
         $domdefaults{'lang_def'} = &domain($domain,'lang_def');          $domdefaults{'lang_def'} = &domain($domain,'lang_def');
         $domdefaults{'auth_def'} = &domain($domain,'auth_def');          $domdefaults{'auth_def'} = &domain($domain,'auth_def');
Line 2051  sub get_domain_defaults { Line 2783  sub get_domain_defaults {
         } else {          } else {
             $domdefaults{'defaultquota'} = $domconfig{'quotas'};              $domdefaults{'defaultquota'} = $domconfig{'quotas'};
         }          }
         my @usertools = ('aboutme','blog','webdav','portfolio');          my @usertools = ('aboutme','blog','webdav','portfolio','portaccess');
         foreach my $item (@usertools) {          foreach my $item (@usertools) {
             if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {              if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {
                 $domdefaults{$item} = $domconfig{'quotas'}{$item};                  $domdefaults{$item} = $domconfig{'quotas'}{$item};
Line 2062  sub get_domain_defaults { Line 2794  sub get_domain_defaults {
         }          }
     }      }
     if (ref($domconfig{'requestcourses'}) eq 'HASH') {      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};              $domdefaults{$item} = $domconfig{'requestcourses'}{$item};
         }          }
     }      }
     if (ref($domconfig{'requestauthor'}) eq 'HASH') {      if (ref($domconfig{'requestauthor'}) eq 'HASH') {
         $domdefaults{'requestauthor'} = $domconfig{'requestauthor'};          $domdefaults{'requestauthor'} = $domconfig{'requestauthor'};
     }      }
       if (ref($domconfig{'authordefaults'}) eq 'HASH') {
           foreach my $item ('nocodemirror','copyright','sourceavail','domcoordacc','editors') {
               if ($item eq 'editors') {
                   if (ref($domconfig{'authordefaults'}{'editors'}) eq 'ARRAY') {
                       $domdefaults{$item} = join(',',@{$domconfig{'authordefaults'}{'editors'}});
                   }
               } else {
                   $domdefaults{$item} = $domconfig{'authordefaults'}{$item};
               }
           }
       }
     if (ref($domconfig{'inststatus'}) eq 'HASH') {      if (ref($domconfig{'inststatus'}) eq 'HASH') {
         foreach my $item ('inststatustypes','inststatusorder','inststatusguest') {          foreach my $item ('inststatustypes','inststatusorder','inststatusguest') {
             $domdefaults{$item} = $domconfig{'inststatus'}{$item};              $domdefaults{$item} = $domconfig{'inststatus'}{$item};
Line 2076  sub get_domain_defaults { Line 2819  sub get_domain_defaults {
     }      }
     if (ref($domconfig{'coursedefaults'}) eq 'HASH') {      if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
         $domdefaults{'canuse_pdfforms'} = $domconfig{'coursedefaults'}{'canuse_pdfforms'};          $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) {          foreach my $type (@coursetypes) {
             if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {              if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {
                 unless ($type eq 'community') {                  unless ($type eq 'community') {
Line 2085  sub get_domain_defaults { Line 2834  sub get_domain_defaults {
             if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {              if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {
                 $domdefaults{$type.'quota'} = $domconfig{'coursedefaults'}{'uploadquota'}{$type};                  $domdefaults{$type.'quota'} = $domconfig{'coursedefaults'}{'uploadquota'}{$type};
             }              }
               if (ref($domconfig{'coursedefaults'}{'coursequota'}) eq 'HASH') {
                   $domdefaults{$type.'coursequota'} = $domconfig{'coursedefaults'}{'coursequota'}{$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'}{'crsauthor'}) eq 'HASH') {
                   $domdefaults{$type.'crsauthor'} = $domconfig{'coursedefaults'}{'crsauthor'}{$type};
               } else {
                   $domdefaults{$type.'crsauthor'} = 1;
               }
           }
           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') {      if (ref($domconfig{'usersessions'}) eq 'HASH') {
Line 2094  sub get_domain_defaults { Line 2883  sub get_domain_defaults {
         if (ref($domconfig{'usersessions'}{'hosted'}) eq 'HASH') {          if (ref($domconfig{'usersessions'}{'hosted'}) eq 'HASH') {
             $domdefaults{'hostedsessions'} = $domconfig{'usersessions'}{'hosted'};              $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'}) eq 'HASH') {
         if (ref($domconfig{'selfenrollment'}{'admin'}) eq 'HASH') {          if (ref($domconfig{'selfenrollment'}{'admin'}) eq 'HASH') {
Line 2126  sub get_domain_defaults { Line 2921  sub get_domain_defaults {
     if (ref($domconfig{'coursecategories'}) eq 'HASH') {      if (ref($domconfig{'coursecategories'}) eq 'HASH') {
         $domdefaults{'catauth'} = 'std';          $domdefaults{'catauth'} = 'std';
         $domdefaults{'catunauth'} = 'std';          $domdefaults{'catunauth'} = 'std';
         if ($domconfig{'coursecategories'}{'auth'}) {           if ($domconfig{'coursecategories'}{'auth'}) {
             $domdefaults{'catauth'} = $domconfig{'coursecategories'}{'auth'};              $domdefaults{'catauth'} = $domconfig{'coursecategories'}{'auth'};
         }          }
         if ($domconfig{'coursecategories'}{'unauth'}) {          if ($domconfig{'coursecategories'}{'unauth'}) {
             $domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'};              $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{'ltisec'}{'suggested'}) eq 'HASH') {
               my %suggestions = %{$domconfig{'ltisec'}{'suggested'}};
               foreach my $item (keys(%{$domconfig{'ltisec'}{'suggested'}})) {
                   unless (ref($domconfig{'ltisec'}{'suggested'}{$item}) eq 'HASH') {
                       delete($suggestions{$item});
                   }
               }
               if (keys(%suggestions)) {
                   $domdefaults{'linkprotsuggested'} = \%suggestions;
               }
           }
       }
       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'};
               }
           }
       }
       if (ref($domconfig{'privacy'}) eq 'HASH') {
           if (ref($domconfig{'privacy'}{'approval'}) eq 'HASH') {
               foreach my $domtype ('instdom','extdom') {
                   if (ref($domconfig{'privacy'}{'approval'}{$domtype}) eq 'HASH') {
                       foreach my $roletype ('domain','author','course','community') {
                           if ($domconfig{'privacy'}{'approval'}{$domtype}{$roletype} eq 'user') {
                               $domdefaults{'userapprovals'} = 1;
                               last;
                           }
                       }
                   }
                   last if ($domdefaults{'userapprovals'});
               }
           }
       }
     &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);      &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);
     return %domdefaults;      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  # --------------------------------------------------- Assign a key to a student
   
 sub assign_access_key {  sub assign_access_key {
Line 2285  sub courseid_to_courseurl { Line 3286  sub courseid_to_courseurl {
  return "/$cdom/$cnum";   return "/$cdom/$cnum";
     }      }
   
     my %courseinfo=&Apache::lonnet::coursedescription($courseid);      my %courseinfo=&coursedescription($courseid);
     if (exists($courseinfo{'num'})) {      if (exists($courseinfo{'num'})) {
  return "/$courseinfo{'domain'}/$courseinfo{'num'}";   return "/$courseinfo{'domain'}/$courseinfo{'num'}";
     }      }
Line 2373  sub make_key { Line 3374  sub make_key {
 sub devalidate_cache_new {  sub devalidate_cache_new {
     my ($name,$id,$debug) = @_;      my ($name,$id,$debug) = @_;
     if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }      if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }
       my $remembered_id=$name.':'.$id;
     $id=&make_key($name,$id);      $id=&make_key($name,$id);
     $memcache->delete($id);      $memcache->delete($id);
     delete($remembered{$id});      delete($remembered{$remembered_id});
     delete($accessed{$id});      delete($accessed{$remembered_id});
 }  }
   
 sub is_cached_new {  sub is_cached_new {
     my ($name,$id,$debug) = @_;      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++;   $hits++;
  return ($remembered{$id},1);   return ($remembered{$remembered_id},1);
     }      }
       $id=&make_key($name,$id);
     my $value = $memcache->get($id);      my $value = $memcache->get($id);
     if (!(defined($value))) {      if (!(defined($value))) {
  if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }   if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }
Line 2397  sub is_cached_new { Line 3400  sub is_cached_new {
  if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); }   if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); }
  $value=undef;   $value=undef;
     }      }
     &make_room($id,$value,$debug);      &make_room($remembered_id,$value,$debug);
     if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }      if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }
     return ($value,1);      return ($value,1);
 }  }
   
 sub do_cache_new {  sub do_cache_new {
     my ($name,$id,$value,$time,$debug) = @_;      my ($name,$id,$value,$time,$debug) = @_;
       my $remembered_id=$name.':'.$id;
     $id=&make_key($name,$id);      $id=&make_key($name,$id);
     my $setvalue=$value;      my $setvalue=$value;
     if (!defined($setvalue)) {      if (!defined($setvalue)) {
Line 2419  sub do_cache_new { Line 3423  sub do_cache_new {
  $memcache->disconnect_all();   $memcache->disconnect_all();
     }      }
     # need to make a copy of $value      # need to make a copy of $value
     &make_room($id,$value,$debug);      &make_room($remembered_id,$value,$debug);
     return $value;      return $value;
 }  }
   
 sub make_room {  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;                                      : $value;
     if ($to_remember<0) { return; }      if ($to_remember<0) { return; }
     $accessed{$id}=[&gettimeofday()];      $accessed{$remembered_id}=[&gettimeofday()];
     if (scalar(keys(%remembered)) <= $to_remember) { return; }      if (scalar(keys(%remembered)) <= $to_remember) { return; }
     my $to_kick;      my $to_kick;
     my $max_time=0;      my $max_time=0;
Line 2480  sub userenvironment { Line 3484  sub userenvironment {
 # ---------------------------------------------------------- Get a studentphoto  # ---------------------------------------------------------- Get a studentphoto
 sub studentphoto {  sub studentphoto {
     my ($udom,$unam,$ext) = @_;      my ($udom,$unam,$ext) = @_;
     my $home=&Apache::lonnet::homeserver($unam,$udom);      my $home=&homeserver($unam,$udom);
     if (defined($env{'request.course.id'})) {      if (defined($env{'request.course.id'})) {
         if ($env{'course.'.$env{'request.course.id'}.'.internal.showphoto'}) {          if ($env{'course.'.$env{'request.course.id'}.'.internal.showphoto'}) {
             if ($udom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) {              if ($udom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) {
                 return(&retrievestudentphoto($udom,$unam,$ext));                   return(&retrievestudentphoto($udom,$unam,$ext)); 
             } else {              } else {
                 my ($result,$perm_reqd)=                  my ($result,$perm_reqd)=
     &Apache::lonnet::auto_photo_permission($unam,$udom);      &auto_photo_permission($unam,$udom);
                 if ($result eq 'ok') {                  if ($result eq 'ok') {
                     if (!($perm_reqd eq 'yes')) {                      if (!($perm_reqd eq 'yes')) {
                         return(&retrievestudentphoto($udom,$unam,$ext));                          return(&retrievestudentphoto($udom,$unam,$ext));
Line 2497  sub studentphoto { Line 3501  sub studentphoto {
         }          }
     } else {      } else {
         my ($result,$perm_reqd) =           my ($result,$perm_reqd) = 
     &Apache::lonnet::auto_photo_permission($unam,$udom);      &auto_photo_permission($unam,$udom);
         if ($result eq 'ok') {          if ($result eq 'ok') {
             if (!($perm_reqd eq 'yes')) {              if (!($perm_reqd eq 'yes')) {
                 return(&retrievestudentphoto($udom,$unam,$ext));                  return(&retrievestudentphoto($udom,$unam,$ext));
Line 2509  sub studentphoto { Line 3513  sub studentphoto {
   
 sub retrievestudentphoto {  sub retrievestudentphoto {
     my ($udom,$unam,$ext,$type) = @_;      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') {      if ($ret eq 'ok') {
         my $url="/uploaded/$udom/$unam/internal/studentphoto.$ext";          my $url="/uploaded/$udom/$unam/internal/studentphoto.$ext";
         if ($type eq 'thumbnail') {          if ($type eq 'thumbnail') {
             $url="/uploaded/$udom/$unam/internal/studentphoto_tn.$ext";               $url="/uploaded/$udom/$unam/internal/studentphoto_tn.$ext"; 
         }          }
         my $tokenurl=&Apache::lonnet::tokenwrapper($url);          my $tokenurl=&tokenwrapper($url);
         return $tokenurl;          return $tokenurl;
     } else {      } else {
         if ($type eq 'thumbnail') {          if ($type eq 'thumbnail') {
Line 2641  sub repcopy { Line 3645  sub repcopy {
    mkdir($path,0777);     mkdir($path,0777);
                }                 }
            }             }
            my $ua=new LWP::UserAgent;  
            my $request=new HTTP::Request('GET',"$remoteurl");             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()) {             if ($response->is_error()) {
        unlink($transname);         unlink($transname);
                my $message=$response->status_line;                 my $message=$response->status_line;
Line 2653  sub repcopy { Line 3661  sub repcopy {
            } else {             } else {
        if ($remoteurl!~/\.meta$/) {         if ($remoteurl!~/\.meta$/) {
                   my $mrequest=new HTTP::Request('GET',$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()) {                    if ($mresponse->is_error()) {
       unlink($filename.'.meta');        unlink($filename.'.meta');
                       &logthis(                        &logthis(
Line 2667  sub repcopy { Line 3680  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  # ------------------------------------------------ Get server side include body
 sub ssi_body {  sub ssi_body {
     my ($filelink,%form)=@_;      my ($filelink,%form)=@_;
Line 2695  sub ssi_body { Line 3734  sub ssi_body {
 # --------------------------------------------------------- Server Side Include  # --------------------------------------------------------- Server Side Include
   
 sub absolute_url {  sub absolute_url {
     my ($host_name) = @_;      my ($host_name,$unalias,$keep_proto) = @_;
     my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');      my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');
     if ($host_name eq '') {      if ($host_name eq '') {
  $host_name = $ENV{'SERVER_NAME'};   $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;      return $protocol.$host_name;
 }  }
   
Line 2716  sub absolute_url { Line 3773  sub absolute_url {
 sub ssi {  sub ssi {
   
     my ($fn,%form)=@_;      my ($fn,%form)=@_;
     my $ua=new LWP::UserAgent;      my ($host,$request,$response);
     my $request;      $host = &absolute_url('',1);
   
     $form{'no_update_last_known'}=1;      $form{'no_update_last_known'}=1;
     &Apache::lonenc::check_encrypt(\$fn);      &Apache::lonenc::check_encrypt(\$fn);
     if (%form) {      if (%form) {
       $request=new HTTP::Request('POST',&absolute_url().$fn);        $request=new HTTP::Request('POST',$host.$fn);
       $request->content(join('&',map {         $request->content(join('&',map { 
             my $name = escape($_);              my $name = escape($_);
             "$name=" . ( ref($form{$_}) eq 'ARRAY'               "$name=" . ( ref($form{$_}) eq 'ARRAY' 
Line 2730  sub ssi { Line 3787  sub ssi {
             : &escape($form{$_}) );                  : &escape($form{$_}) );    
         } keys(%form)));          } keys(%form)));
     } else {      } else {
       $request=new HTTP::Request('GET',&absolute_url().$fn);        $request=new HTTP::Request('GET',$host.$fn);
     }      }
   
     $request->header(Cookie => $ENV{'HTTP_COOKIE'});      $request->header(Cookie => $ENV{'HTTP_COOKIE'});
     my $response= $ua->request($request);      my $lonhost = $perlvar{'lonHostID'};
     my $content = $response->content;      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) {      if (wantarray) {
  return ($content, $response);   return ($response->content, $response);
     } else {      } else {
  return $content;   return $response->content;
     }      }
 }  }
   
 sub externalssi {  sub externalssi {
     my ($url)=@_;      my ($url)=@_;
     my $ua=new LWP::UserAgent;  
     my $request=new HTTP::Request('GET',$url);      my $request=new HTTP::Request('GET',$url);
     my $response=$ua->request($request);      my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar);
     if (wantarray) {      if (wantarray) {
         return ($response->content, $response);          return ($response->content, $response);
     } else {      } else {
Line 2757  sub externalssi { Line 3822  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  # -------------------------------- Allow a /uploaded/ URI to be vouched for
   
 sub allowuploaded {  sub allowuploaded {
Line 2812  sub can_edit_resource { Line 3948  sub can_edit_resource {
         }          }
     }      }
   
   #
   # For /adm/viewcoauthors can only edit if author or co-author who is manager.
   #
   
       if (($resurl eq '/adm/viewcoauthors') && ($cnum ne '') && ($cdom ne '')) {
           if (((&allowed('cca',"$cdom/$cnum")) ||
                (&allowed('caa',"$cdom/$cnum"))) ||
                ((&allowed('vca',"$cdom/$cnum") ||
                  &allowed('vaa',"$cdom/$cnum")) &&
                 ($env{"environment.internal.manager./$cdom/$cnum"}))) {
               $home = $env{'user.home'};
               $cfile = $resurl;
               if ($env{'form.forceedit'}) {
                   $forceview = 1;
               } else {
                   $forceedit = 1;
               }
               return ($cfile,$home,$switchserver,$forceedit,$forceview);
           } else {
               return;
           }
       }
   
     if ($env{'request.course.id'}) {      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 ($group ne '') {
 # if this is a group homepage or group bulletin board, check group privs  # if this is a group homepage or group bulletin board, check group privs
             my $allowed = 0;              my $allowed = 0;
Line 2842  sub can_edit_resource { Line 4001  sub can_edit_resource {
             }              }
         } else {          } else {
             if ($resurl =~ m{^/?adm/viewclasslist$}) {              if ($resurl =~ m{^/?adm/viewclasslist$}) {
                 unless (&Apache::lonnet::allowed('opa',$env{'request.course.id'})) {                  unless (&allowed('opa',$env{'request.course.id'})) {
                     return;                      return;
                 }                  }
             } elsif (!$crsedit) {              } elsif (!$crsedit) {
                   if ($env{'request.role'} =~ m{^st\./$cdom/$cnum}) {
 #  #
 # No edit allowed where CC has switched to student role.  # 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 2875  sub can_edit_resource { Line 4039  sub can_edit_resource {
                     $forceedit = 1;                      $forceedit = 1;
                 }                  }
                 $cfile = $resurl;                  $cfile = $resurl;
             } elsif (($resurl ne '') && (&is_on_map($resurl))) {               } elsif (($resurl ne '') && (&is_on_map($resurl))) {
                 if ($resurl =~ m{^/adm/$match_domain/$match_username/\d+/smppg|bulletinboard$}) {                  if ($resurl =~ m{^/adm/$match_domain/$match_username/\d+/smppg|bulletinboard$}) {
                     $incourse = 1;                      $incourse = 1;
                     if ($env{'form.forceedit'}) {                      if ($env{'form.forceedit'}) {
Line 2895  sub can_edit_resource { Line 4059  sub can_edit_resource {
                         $forceedit = 1;                          $forceedit = 1;
                     }                      }
                     $cfile = $resurl;                      $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$}) {                  } elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
                     $incourse = 1;                      $incourse = 1;
                     if ($env{'form.forceedit'}) {                      if ($env{'form.forceedit'}) {
Line 2912  sub can_edit_resource { Line 4096  sub can_edit_resource {
                     $cfile = $template;                      $cfile = $template;
                 }                  }
             } elsif (($resurl =~ m{^/adm/wrapper/ext/}) && ($env{'form.folderpath'} =~ /^supplemental/)) {              } 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'})) {              } elsif (($resurl eq '/adm/extresedit') && ($symb || $env{'form.folderpath'})) {
                 $incourse = 1;                  $incourse = 1;
                 $forceview = 1;                  $forceview = 1;
Line 2928  sub can_edit_resource { Line 4120  sub can_edit_resource {
                     $cfile = &clutter($res);                      $cfile = &clutter($res);
                 } else {                  } else {
                     $cfile = $env{'form.suppurl'};                      $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$}) {              } elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
                 if ($env{'form.forceedit'}) {                  if ($env{'form.forceedit'}) {
Line 3085  sub process_coursefile { Line 4282  sub process_coursefile {
                                  $home);                                   $home);
             }              }
         } elsif ($action eq 'uploaddoc') {          } elsif ($action eq 'uploaddoc') {
             open(my $fh,'>'.$filepath.'/'.$fname);              open(my $fh,'>',$filepath.'/'.$fname);
             print $fh $env{'form.'.$source};              print $fh $env{'form.'.$source};
             close($fh);              close($fh);
             if ($parser eq 'parse') {              if ($parser eq 'parse') {
Line 3143  sub store_edited_file { Line 4340  sub store_edited_file {
     ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);      ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);
     $fpath=$docudom.'/'.$docuname.'/'.$fpath;      $fpath=$docudom.'/'.$docuname.'/'.$fpath;
     my $filepath = &build_filepath($fpath);      my $filepath = &build_filepath($fpath);
     open(my $fh,'>'.$filepath.'/'.$fname);      open(my $fh,'>',$filepath.'/'.$fname);
     print $fh $content;      print $fh $content;
     close($fh);      close($fh);
     my $home=&homeserver($docuname,$docudom);      my $home=&homeserver($docuname,$docudom);
Line 3168  sub clean_filename { Line 4365  sub clean_filename {
     }      }
 # Replace spaces by underscores  # Replace spaces by underscores
     $fname=~s/\s+/\_/g;      $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  # Replace all other weird characters by nothing
     $fname=~s{[^/\w\.\-]}{}g;      $fname=~s{[^/\w\.\-]}{}g;
 # Replace all .\d. sequences with _\d. so they no longer look like version  # Replace all .\d. sequences with _\d. so they no longer look like version
 # numbers  # numbers
     $fname=~s/\.(\d+)(?=\.)/_$1/g;      $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;      return $fname;
 }  }
   
 # This Function checks if an Image's dimensions exceed either $resizewidth (width)   # 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   # 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   # image with the same aspect ratio as the original, but with dimensions which do 
Line 3217  sub resizeImage { Line 4422  sub resizeImage {
 # input: $formname - the contents of the file are in $env{"form.$formname"}  # input: $formname - the contents of the file are in $env{"form.$formname"}
 #                    the desired filename is in $env{"form.$formname.filename"}  #                    the desired filename is in $env{"form.$formname.filename"}
 #        $context - possible values: coursedoc, existingfile, overwrite,   #        $context - possible values: coursedoc, existingfile, overwrite, 
 #                                    canceloverwrite, or ''.   #                                    canceloverwrite, scantron, toollogo  or ''.
 #                   if 'coursedoc': upload to the current course  #                   if 'coursedoc': upload to the current course
 #                   if 'existingfile': write file to tmp/overwrites directory   #                   if 'existingfile': write file to tmp/overwrites directory 
 #                   if 'canceloverwrite': delete file written to tmp/overwrites directory  #                   if 'canceloverwrite': delete file written to tmp/overwrites directory
 #                   $context is passed as argument to &finishuserfileupload  #                   $context is passed as argument to &finishuserfileupload
 #        $subdir - directory in userfile to store the file into  #        $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  #        $allfiles - reference to hash for embedded objects
 #        $codebase - reference to hash for codebase of java 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   #        $thumbwidth - width (pixels) of thumbnail to make for uploaded image 
 #        $thumbheight - height (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  #        $resizewidth - width (pixels) to which to resize uploaded image
Line 3246  sub userfileupload { Line 4454  sub userfileupload {
     $fname=&clean_filename($fname);      $fname=&clean_filename($fname);
     # See if there is anything left      # See if there is anything left
     unless ($fname) { return 'error: no uploaded file'; }      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      # Files uploaded to help request form, or uploaded to "create course" page are handled differently
     if ((($formname eq 'screenshot') && ($subdir eq 'helprequests')) ||      if ((($formname eq 'screenshot') && ($subdir eq 'helprequests')) ||
         (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) ||          (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) ||
Line 3259  sub userfileupload { Line 4475  sub userfileupload {
                          '_'.$env{'user.domain'}.'/pending';                           '_'.$env{'user.domain'}.'/pending';
         } elsif (($context eq 'existingfile') || ($context eq 'canceloverwrite')) {          } elsif (($context eq 'existingfile') || ($context eq 'canceloverwrite')) {
             my ($docuname,$docudom);              my ($docuname,$docudom);
             if ($destudom) {              if ($destudom =~ /^$match_domain$/) {
                 $docudom = $destudom;                  $docudom = $destudom;
             } else {              } else {
                 $docudom = $env{'user.domain'};                  $docudom = $env{'user.domain'};
             }              }
             if ($destuname) {              if ($destuname =~ /^$match_username$/) {
                 $docuname = $destuname;                  $docuname = $destuname;
             } else {              } else {
                 $docuname = $env{'user.name'};                  $docuname = $env{'user.name'};
Line 3294  sub userfileupload { Line 4510  sub userfileupload {
                 mkdir($fullpath,0777);                  mkdir($fullpath,0777);
             }              }
         }          }
         open(my $fh,'>'.$fullpath.'/'.$fname);          open(my $fh,'>',$fullpath.'/'.$fname);
         print $fh $env{'form.'.$formname};          print $fh $env{'form.'.$formname};
         close($fh);          close($fh);
         if ($context eq 'existingfile') {          if ($context eq 'existingfile') {
Line 3369  sub finishuserfileupload { Line 4585  sub finishuserfileupload {
   
 # Save the file  # Save the file
     {      {
  if (!open(FH,'>'.$filepath.'/'.$file)) {   if (!open(FH,'>',$filepath.'/'.$file)) {
     &logthis('Failed to create '.$filepath.'/'.$file);      &logthis('Failed to create '.$filepath.'/'.$file);
     print STDERR ('Failed to create '.$filepath.'/'.$file."\n");      print STDERR ('Failed to create '.$filepath.'/'.$file."\n");
     return '/adm/notfound.html';      return '/adm/notfound.html';
Line 3413  sub finishuserfileupload { Line 4629  sub finishuserfileupload {
             }              }
         }          }
     }      }
     if ($parser eq 'parse') {      if (($context ne 'scantron') && ($parser eq 'parse')) {
         if ((ref($mimetype)) && ($$mimetype eq 'text/html')) {          if ((ref($mimetype)) && ($$mimetype eq 'text/html')) {
             my $parse_result = &extract_embedded_items($filepath.'/'.$file,              my $parse_result = &extract_embedded_items($filepath.'/'.$file,
                                                        $allfiles,$codebase);                                                         $allfiles,$codebase);
Line 3422  sub finishuserfileupload { Line 4638  sub finishuserfileupload {
            ' for embedded media: '.$parse_result);              ' 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+$/)) {      if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
         my $input = $filepath.'/'.$file;          my $input = $filepath.'/'.$file;
         my $output = $filepath.'/'.'tn-'.$file;          my $output = $filepath.'/'.'tn-'.$file;
           my $makethumb; 
         my $thumbsize = $thumbwidth.'x'.$thumbheight;          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 3661  sub embedded_dependency { Line 4894  sub embedded_dependency {
     return;      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 {  sub removeuploadedurl {
     my ($url)=@_;      my ($url)=@_;
     my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);          my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);    
Line 3778  sub flushcourselogs { Line 5276  sub flushcourselogs {
             if (! defined($dom) || $dom eq '' ||               if (! defined($dom) || $dom eq '' || 
                 ! defined($name) || $name eq '') {                  ! defined($name) || $name eq '') {
                 my $cid = $env{'request.course.id'};                  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'};                  $dom  = $env{'request.'.$cid.'.domain'};
                 $name = $env{'request.'.$cid.'.num'};                  $name = $env{'request.'.$cid.'.num'};
             }              }
Line 3804  sub flushcourselogs { Line 5325  sub flushcourselogs {
     foreach my $entry (keys(%userrolehash)) {      foreach my $entry (keys(%userrolehash)) {
         my ($role,$uname,$udom,$runame,$rudom,$rsec)=          my ($role,$uname,$udom,$runame,$rudom,$rsec)=
     split(/\:/,$entry);      split(/\:/,$entry);
         if (&Apache::lonnet::put('nohist_userroles',          if (&put('nohist_userroles',
              { $role.':'.$uname.':'.$udom.':'.$rsec => $userrolehash{$entry} },               { $role.':'.$uname.':'.$udom.':'.$rsec => $userrolehash{$entry} },
                 $rudom,$runame) eq 'ok') {                  $rudom,$runame) eq 'ok') {
     delete $userrolehash{$entry};      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 = ();      my %domrolebuffer = ();
     foreach my $entry (keys(%domainrolehash)) {      foreach my $entry (keys(%domainrolehash)) {
Line 3826  sub flushcourselogs { Line 5347  sub flushcourselogs {
         delete $domainrolehash{$entry};          delete $domainrolehash{$entry};
     }      }
     foreach my $dom (keys(%domrolebuffer)) {      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)) {   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);   &logthis('Put of domain roles failed for '.$dom.' and  '.$tryserver);
     }      }
         }          }
Line 3878  sub courseacclog { Line 5408  sub courseacclog {
                 if ($formitem =~ /^HWFILE(?:SIZE|TOOBIG)/) {                  if ($formitem =~ /^HWFILE(?:SIZE|TOOBIG)/) {
                     $what.=':'.$formitem.'='.$env{$key};                      $what.=':'.$formitem.'='.$env{$key};
                 } elsif ($formitem !~ /^HWFILE(?:[^.]+)$/) {                  } elsif ($formitem !~ /^HWFILE(?:[^.]+)$/) {
                     $what.=':'.$formitem.'='.$env{$key};                      if ($formitem eq 'proctorpassword') {
                           $what.=':'.$formitem.'=' . '*' x length($env{$key});
                       } else {
                           $what.=':'.$formitem.'='.$env{$key};
                       }
                 }                  }
             }              }
         }          }
Line 3949  sub userrolelog { Line 5483  sub userrolelog {
          {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}           {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}
                     =$tend.':'.$tstart;                      =$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);         my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
        $domainrolehash         $domainrolehash
          {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}           {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
Line 3958  sub userrolelog { Line 5492  sub userrolelog {
 }  }
   
 sub courserolelog {  sub courserolelog {
     my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_;      my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,
           $context,$othdomby,$requester)=@_;
     if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {      if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {
         my $cdom = $1;          my $cdom = $1;
         my $cnum = $2;          my $cnum = $2;
Line 3971  sub courserolelog { Line 5506  sub courserolelog {
                            selfenroll => $selfenroll,                             selfenroll => $selfenroll,
                            context    => $context,                             context    => $context,
                         );                          );
           if ($othdomby) {
               if ($othdomby eq 'othdombydc') {
                   $storehash{'approval'} = 'domain';
               } elsif ($othdomby eq 'othdombyuser') {
                   $storehash{'approval'} = 'user'; 
               }
               if ($requester ne '') {
                   $storehash{'requester'} = $requester;
               }
           }
         if ($trole eq 'gr') {          if ($trole eq 'gr') {
             $namespace = 'groupslog';              $namespace = 'groupslog';
             $storehash{'group'} = $sec;              $storehash{'group'} = $sec;
         } else {          } else {
             $storehash{'section'} = $sec;              $storehash{'section'} = $sec;
               my ($curruserdomstr,$newuserdomstr);
               if (exists($env{'course.'.$cdom.'_'.$cnum.'.internal.userdomains'})) {
                   $curruserdomstr = $env{'course.'.$env{'request.course.id'}.'.internal.userdomains'};
               } else {
                   my %courseinfo = &coursedescription($cdom.'/'.$cnum);
                   $curruserdomstr = $courseinfo{'internal.userdomains'};
               }
               if ($curruserdomstr ne '') {
                   my @udoms = split(/,/,$curruserdomstr);
                   unless (grep(/^\Q$domain\E/,@udoms)) {
                       push(@udoms,$domain);
                       $newuserdomstr = join(',',sort(@udoms));
                   }
               } else {
                   $newuserdomstr = $domain;
               }
               if ($newuserdomstr ne '') {
                   my $putresult = &put('environment',{ 'internal.userdomains' => $newuserdomstr },
                                        $cdom,$cnum);
                   if ($putresult eq 'ok') {
                       unless (($selfenroll) || ($context eq 'selfenroll')) { 
                           if (($context eq 'createcourse') || ($context eq 'requestcourses') ||
                               ($context eq 'automated') || ($context eq 'domain')) {
                               $env{'course.'.$cdom.'_'.$cnum.'.internal.userdomains'} = $newuserdomstr;
                           } elsif ($env{'request.course.id'} eq $cdom.'_'.$cnum) {
                               &appenv({'course.'.$cdom.'_'.$cnum.'.internal.userdomains' => $newuserdomstr});
                           }
                       }
                   }
               }
         }          }
         &write_log('course',$namespace,\%storehash,$delflag,$username,          &write_log('course',$namespace,\%storehash,$delflag,$username,
                    $domain,$cnum,$cdom);                     $domain,$cnum,$cdom);
Line 3987  sub courserolelog { Line 5562  sub courserolelog {
 }  }
   
 sub domainrolelog {  sub domainrolelog {
     my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_;      my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,
           $context,$othdomby,$requester)=@_;
     if ($area =~ m{^/($match_domain)/$}) {      if ($area =~ m{^/($match_domain)/$}) {
         my $cdom = $1;          my $cdom = $1;
         my $domconfiguser = &Apache::lonnet::get_domainconfiguser($cdom);          my $domconfiguser = &get_domainconfiguser($cdom);
         my $namespace = 'rolelog';          my $namespace = 'rolelog';
         my %storehash = (          my %storehash = (
                            role    => $trole,                             role    => $trole,
Line 3998  sub domainrolelog { Line 5574  sub domainrolelog {
                            end     => $tend,                             end     => $tend,
                            context => $context,                             context => $context,
                         );                          );
           if ($othdomby) {
               if ($othdomby eq 'othdombydc') {
                   $storehash{'approval'} = 'domain';
               } elsif ($othdomby eq 'othdombyuser') {
                   $storehash{'approval'} = 'user';
               }
               if ($requester ne '') {
                   $storehash{'requester'} = $requester;
               }
           }
         &write_log('domain',$namespace,\%storehash,$delflag,$username,          &write_log('domain',$namespace,\%storehash,$delflag,$username,
                    $domain,$domconfiguser,$cdom);                     $domain,$domconfiguser,$cdom);
     }      }
Line 4006  sub domainrolelog { Line 5592  sub domainrolelog {
 }  }
   
 sub coauthorrolelog {  sub coauthorrolelog {
     my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_;      my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,
           $context,$othdomby,$requester)=@_;
     if ($area =~ m{^/($match_domain)/($match_username)$}) {      if ($area =~ m{^/($match_domain)/($match_username)$}) {
         my $audom = $1;          my $audom = $1;
         my $auname = $2;          my $auname = $2;
Line 4017  sub coauthorrolelog { Line 5604  sub coauthorrolelog {
                            end     => $tend,                             end     => $tend,
                            context => $context,                             context => $context,
                         );                          );
           if ($othdomby) {
               if ($othdomby eq 'othdombydc') {
                   $storehash{'approval'} = 'domain';
               } elsif ($othdomby eq 'othdombyuser') {
                   $storehash{'approval'} = 'user';
               }
               if ($requester ne '') {
                   $storehash{'requester'} = $requester;
               }
           }
         &write_log('author',$namespace,\%storehash,$delflag,$username,          &write_log('author',$namespace,\%storehash,$delflag,$username,
                    $domain,$auname,$audom);                     $domain,$auname,$audom);
     }      }
Line 4176  sub get_my_roles { Line 5773  sub get_my_roles {
     return %returnhash;      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  # ----------------------------------------------------- Frontpage Announcements
 #  #
 #  #
Line 4189  sub postannounce { Line 5975  sub postannounce {
   
 sub getannounce {  sub getannounce {
   
     if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) {      if (open(my $fh,"<",$perlvar{'lonDocRoot'}.'/announcement.txt')) {
  my $announcement='';   my $announcement='';
  while (my $line = <$fh>) { $announcement .= $line; }   while (my $line = <$fh>) { $announcement .= $line; }
  close($fh);   close($fh);
Line 4252  sub courseiddump { Line 6038  sub courseiddump {
         $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,          $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
         $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,          $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,
         $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner,          $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner,
         $hasuniquecode)=@_;          $hasuniquecode,$reqcrsdom,$reqinstcode)=@_;
     my $as_hash = 1;      my $as_hash = 1;
     my %returnhash;      my %returnhash;
     if (!$domfilter) { $domfilter=''; }      if (!$domfilter) { $domfilter=''; }
Line 4275  sub courseiddump { Line 6061  sub courseiddump {
                                 &escape($catfilter), $showhidden, $caller,                                   &escape($catfilter), $showhidden, $caller, 
                                 &escape($cloner), &escape($cc_clone), $cloneonly,                                   &escape($cloner), &escape($cc_clone), $cloneonly, 
                                 &escape($createdbefore), &escape($createdafter),                                   &escape($createdbefore), &escape($createdafter), 
                                 &escape($creationcontext), $domcloner, $hasuniquecode)));                                  &escape($creationcontext),$domcloner,$hasuniquecode,
                                   $reqcrsdom,&escape($reqinstcode))));
                 } else {                  } else {
                     $rep = &reply('courseiddump:'.&host_domain($tryserver).':'.                      $rep = &reply('courseiddump:'.&host_domain($tryserver).':'.
                              $sincefilter.':'.&escape($descfilter).':'.                               $sincefilter.':'.&escape($descfilter).':'.
Line 4286  sub courseiddump { Line 6073  sub courseiddump {
                              $showhidden.':'.$caller.':'.&escape($cloner).':'.                               $showhidden.':'.$caller.':'.&escape($cloner).':'.
                              &escape($cc_clone).':'.$cloneonly.':'.                               &escape($cc_clone).':'.$cloneonly.':'.
                              &escape($createdbefore).':'.&escape($createdafter).':'.                               &escape($createdbefore).':'.&escape($createdafter).':'.
                              &escape($creationcontext).':'.$domcloner.':'.$hasuniquecode,                               &escape($creationcontext).':'.$domcloner.':'.$hasuniquecode.
                              $tryserver);                               ':'.$reqcrsdom.':'.&escape($reqinstcode),$tryserver);
                 }                  }
                                             
                 my @pairs=split(/\&/,$rep);                  my @pairs=split(/\&/,$rep);
Line 4359  sub extract_lastaccess { Line 6146  sub extract_lastaccess {
   
 sub dcmailput {  sub dcmailput {
     my ($domain,$msgid,$message,$server)=@_;      my ($domain,$msgid,$message,$server)=@_;
     my $status = &Apache::lonnet::critical(      my $status = &critical(
        'dcmailput:'.$domain.':'.&escape($msgid).'='.         'dcmailput:'.$domain.':'.&escape($msgid).'='.
        &escape($message),$server);         &escape($message),$server);
     return $status;      return $status;
Line 4415  sub get_domain_roles { Line 6202  sub get_domain_roles {
     return %personnel;      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   # ----------------------------------------------------------- Interval timing 
   
 {  {
Line 4426  my $cachedkey=''; Line 6228  my $cachedkey='';
 # The cached times for this user  # The cached times for this user
 my %cachedtimes=();  my %cachedtimes=();
 # When this was last done  # When this was last done
 my $cachedtime=();  my $cachedtime='';
   
 sub load_all_first_access {  sub load_all_first_access {
     my ($uname,$udom)=@_;      my ($uname,$udom,$ignorecache)=@_;
     if (($cachedkey eq $uname.':'.$udom) &&      if (($cachedkey eq $uname.':'.$udom) &&
         (abs($cachedtime-time)<5) && (!$env{'form.markaccess'})) {          (abs($cachedtime-time)<5) && (!$env{'form.markaccess'}) &&
           (!$ignorecache)) {
         return;          return;
     }      }
     $cachedtime=time;      $cachedtime=time;
Line 4440  sub load_all_first_access { Line 6243  sub load_all_first_access {
 }  }
   
 sub get_first_access {  sub get_first_access {
     my ($type,$argsymb,$argmap)=@_;      my ($type,$argsymb,$argmap,$ignorecache)=@_;
     my ($symb,$courseid,$udom,$uname)=&whichuser();      my ($symb,$courseid,$udom,$uname)=&whichuser();
     if ($argsymb) { $symb=$argsymb; }      if ($argsymb) { $symb=$argsymb; }
     my ($map,$id,$res)=&decode_symb($symb);      my ($map,$id,$res)=&decode_symb($symb);
Line 4452  sub get_first_access { Line 6255  sub get_first_access {
     } else {      } else {
  $res=$symb;   $res=$symb;
     }      }
     &load_all_first_access($uname,$udom);      &load_all_first_access($uname,$udom,$ignorecache);
     return $cachedtimes{"$courseid\0$res"};      return $cachedtimes{"$courseid\0$res"};
 }  }
   
Line 4469  sub set_first_access { Line 6272  sub set_first_access {
     }      }
     $cachedkey='';      $cachedkey='';
     my $firstaccess=&get_first_access($type,$symb,$map);      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 $start = time;
  my $putres = &put('firstaccesstimes',{"$courseid\0$res"=>$start},   my $putres = &put('firstaccesstimes',{"$courseid\0$res"=>$start},
                           $udom,$uname);                            $udom,$uname);
Line 4482  sub set_first_access { Line 6290  sub set_first_access {
                         'course.'.$courseid.'.timerinterval.'.$res => $interval,                          'course.'.$courseid.'.timerinterval.'.$res => $interval,
                      }                       }
                   );                    );
               if (($cachedtime) && (abs($start-$cachedtime) < 5)) {
                   $cachedtimes{"$courseid\0$res"} = $start;
               }
           } elsif ($putres ne 'refused') {
               &logthis("Result: $putres when attempting to set first access time ".
                        "(type: $type, extent: $res) for $uname:$udom in $courseid");
         }          }
         return $putres;          return $putres;
     }      }
     return 'already_set';      return 'already_set';
 }  }
 }  }
   
 # --------------------------------------------- Set Expire Date for Spreadsheet  # --------------------------------------------- Set Expire Date for Spreadsheet
   
 sub expirespread {  sub expirespread {
Line 4742  sub tmpreset { Line 6557  sub tmpreset {
   if (!$domain) { $domain=$env{'user.domain'}; }    if (!$domain) { $domain=$env{'user.domain'}; }
   if (!$stuname) { $stuname=$env{'user.name'}; }    if (!$stuname) { $stuname=$env{'user.name'}; }
   if ($domain eq 'public' && $stuname eq 'public') {    if ($domain eq 'public' && $stuname eq 'public') {
       $stuname=$ENV{'REMOTE_ADDR'};        $stuname=&get_requestor_ip();
   }    }
   my $path=LONCAPA::tempdir();    my $path=LONCAPA::tempdir();
   my %hash;    my %hash;
Line 4779  sub tmpstore { Line 6594  sub tmpstore {
   if (!$domain) { $domain=$env{'user.domain'}; }    if (!$domain) { $domain=$env{'user.domain'}; }
   if (!$stuname) { $stuname=$env{'user.name'}; }    if (!$stuname) { $stuname=$env{'user.name'}; }
   if ($domain eq 'public' && $stuname eq 'public') {    if ($domain eq 'public' && $stuname eq 'public') {
       $stuname=$ENV{'REMOTE_ADDR'};        $stuname=&get_requestor_ip();
   }    }
   my $now=time;    my $now=time;
   my %hash;    my %hash;
Line 4823  sub tmprestore { Line 6638  sub tmprestore {
   if (!$domain) { $domain=$env{'user.domain'}; }    if (!$domain) { $domain=$env{'user.domain'}; }
   if (!$stuname) { $stuname=$env{'user.name'}; }    if (!$stuname) { $stuname=$env{'user.name'}; }
   if ($domain eq 'public' && $stuname eq 'public') {    if ($domain eq 'public' && $stuname eq 'public') {
       $stuname=$ENV{'REMOTE_ADDR'};        $stuname=&get_requestor_ip();
   }    }
   my %returnhash;    my %returnhash;
   $namespace=~s/\//\_/g;    $namespace=~s/\//\_/g;
Line 4879  sub store { Line 6694  sub store {
     }      }
     if (!$home) { $home=$env{'user.home'}; }      if (!$home) { $home=$env{'user.home'}; }
   
     $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};      $$storehash{'ip'}=&get_requestor_ip();
     $$storehash{'host'}=$perlvar{'lonHostID'};      $$storehash{'host'}=$perlvar{'lonHostID'};
   
     my $namevalue='';      my $namevalue='';
Line 4915  sub cstore { Line 6730  sub cstore {
     }      }
     if (!$home) { $home=$env{'user.home'}; }      if (!$home) { $home=$env{'user.home'}; }
   
     $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};      $$storehash{'ip'}=&get_requestor_ip();
     $$storehash{'host'}=$perlvar{'lonHostID'};      $$storehash{'host'}=$perlvar{'lonHostID'};
   
     my $namevalue='';      my $namevalue='';
Line 5179  sub rolesinit { Line 6994  sub rolesinit {
     my %firstaccess = &dump('firstaccesstimes', $domain, $username);      my %firstaccess = &dump('firstaccesstimes', $domain, $username);
     my %timerinterval = &dump('timerinterval', $domain, $username);      my %timerinterval = &dump('timerinterval', $domain, $username);
     my (%coursetimerstarts, %firstaccchk, %firstaccenv, %coursetimerintervals,      my (%coursetimerstarts, %firstaccchk, %firstaccenv, %coursetimerintervals,
         %timerintchk, %timerintenv);          %timerintchk, %timerintenv, %coauthorenv);
   
     foreach my $key (keys(%firstaccess)) {      foreach my $key (keys(%firstaccess)) {
         my ($cid, $rest) = split(/\0/, $key);          my ($cid, $rest) = split(/\0/, $key);
Line 5193  sub rolesinit { Line 7008  sub rolesinit {
   
     my %allroles=();      my %allroles=();
     my %allgroups=();      my %allgroups=();
       my %gotcoauconfig=();
       my %domdefaults=();
   
     for my $area (grep { ! /^rolesdef_/ } keys(%rolesdump)) {      for my $area (grep { ! /^rolesdef_/ } keys(%rolesdump)) {
         my $role = $rolesdump{$area};          my $role = $rolesdump{$area};
Line 5244  sub rolesinit { Line 7061  sub rolesinit {
         } else {          } else {
         # Normal role, defined in roles.tab          # Normal role, defined in roles.tab
             &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);              &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
               if (($trole eq 'ca') || ($trole eq 'aa')) {
                   (undef,my ($audom,$auname)) = split(/\//,$area);
                   unless ($gotcoauconfig{$area}) {
                       my @ca_settings = ('authoreditors','coauthorlist','coauthoroptin');
                       my %info = &userenvironment($audom,$auname,@ca_settings);
                       $gotcoauconfig{$area} = 1;
                       foreach my $item (@ca_settings) {
                           if (exists($info{$item})) {
                               my $name = $item;
                               if ($item eq 'authoreditors') {
                                   $name = 'editors';
                                   unless ($info{'authoreditors'}) {
                                       my %domdefs;
                                       if (ref($domdefaults{$audom}) eq 'HASH') {
                                           %domdefs = %{$domdefaults{$audom}};
                                       } else {
                                           %domdefs = &get_domain_defaults($audom);
                                           $domdefaults{$audom} = \%domdefs;
                                       }
                                       if ($domdefs{$name} ne '') {
                                           $info{'authoreditors'} = $domdefs{$name};
                                       } else {
                                           $info{'authoreditors'} = 'edit,xml';
                                       }
                                   }
                               }
                               $coauthorenv{"environment.internal.$name.$area"} = $info{$item};
                           }
                       }
                   }
               }
         }          }
   
         my $cid = $tdomain.'_'.$trest;          my $cid = $tdomain.'_'.$trest;
Line 5267  sub rolesinit { Line 7115  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.adv'} = $userroles{'user.adv'};
       $env{'user.rar'} = $userroles{'user.rar'};
   
     return (\%userroles,\%firstaccenv,\%timerintenv);      return (\%userroles,\%firstaccenv,\%timerintenv,\%coauthorenv);
 }  }
   
 sub set_arearole {  sub set_arearole {
Line 5305  sub custom_roleprivs { Line 7154  sub custom_roleprivs {
                     $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;                      $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
                 }                  }
                 if (($trest ne '') && (defined($coursepriv))) {                  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{'cm.'.$area}.=':'.$coursepriv;
                     $$allroles{$spec.'.'.$area}.=':'.$coursepriv;                      $$allroles{$spec.'.'.$area}.=':'.$coursepriv;
                 }                  }
Line 5313  sub custom_roleprivs { Line 7166  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 {  sub group_roleprivs {
     my ($allgroups,$area,$group_privs,$tend,$tstart) = @_;      my ($allgroups,$area,$group_privs,$tend,$tstart) = @_;
     my $access = 1;      my $access = 1;
Line 5347  sub set_userprivs { Line 7242  sub set_userprivs {
     my ($userroles,$allroles,$allgroups,$groups_roles) = @_;       my ($userroles,$allroles,$allgroups,$groups_roles) = @_; 
     my $author=0;      my $author=0;
     my $adv=0;      my $adv=0;
       my $rar=0;
     my %grouproles = ();      my %grouproles = ();
     if (keys(%{$allgroups}) > 0) {      if (keys(%{$allgroups}) > 0) {
         my @groupkeys;           my @groupkeys; 
Line 5394  sub set_userprivs { Line 7290  sub set_userprivs {
                     $thesepriv{$privilege}.=$restrictions;                      $thesepriv{$privilege}.=$restrictions;
                 }                  }
                 if ($thesepriv{'adv'} eq 'F') { $adv=1; }                  if ($thesepriv{'adv'} eq 'F') { $adv=1; }
                   if ($thesepriv{'rar'} eq 'F') { $rar=1; }
             }              }
         }          }
         my $thesestr='';          my $thesestr='';
Line 5402  sub set_userprivs { Line 7299  sub set_userprivs {
  }   }
         $userroles->{'user.priv.'.$role} = $thesestr;          $userroles->{'user.priv.'.$role} = $thesestr;
     }      }
     return ($author,$adv);      return ($author,$adv,$rar);
 }  }
   
 sub role_status {  sub role_status {
Line 5447  sub role_status { Line 7344  sub role_status {
                                 push(@rolecodes,$$role);                                  push(@rolecodes,$$role);
                                 &standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where);                                  &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);                              &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';                      $$tstatus = 'is';
Line 5525  sub delete_env_groupprivs { Line 7423  sub delete_env_groupprivs {
 }  }
   
 sub check_adhoc_privs {  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;      my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;
       if ($sec) {
           $cckey .= '/'.$sec;
       } 
     my $setprivs;      my $setprivs;
     if ($env{$cckey}) {      if ($env{$cckey}) {
         my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);          my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);
         &role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);          &role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);
         unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) {          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;              $setprivs = 1;
         }          }
     } else {      } else {
         &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);          &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller,$sec);
         $setprivs = 1;          $setprivs = 1;
     }      }
     return $setprivs;      return $setprivs;
 }  }
   
 sub set_adhoc_privileges {  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;      my $area = '/'.$dcdom.'/'.$pickedcourse;
       if ($sec ne '') {
           $area .= '/'.$sec;
       }
     my $spec = $role.'.'.$area;      my $spec = $role.'.'.$area;
     my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'},      my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'},
                                   $env{'user.name'},1);                                    $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']);      &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,          &appenv( {'request.role'        => $spec,
                   'request.role.domain' => $dcdom,                    'request.role.domain' => $dcdom,
                   'request.course.sec'  => ''                    'request.course.sec'  => $sec,
                  }                   }
                );                 );
         my $tadv=0;          my $tadv=0;
Line 5630  sub unserialize { Line 7546  sub unserialize {
 # see Lond::dump_with_regexp  # see Lond::dump_with_regexp
 # if $escapedkeys hash keys won't get unescaped.  # if $escapedkeys hash keys won't get unescaped.
 sub dump {  sub dump {
     my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys)=@_;      my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys,$encrypt)=@_;
     if (!$udomain) { $udomain=$env{'user.domain'}; }      if (!$udomain) { $udomain=$env{'user.domain'}; }
     if (!$uname) { $uname=$env{'user.name'}; }      if (!$uname) { $uname=$env{'user.name'}; }
     my $uhome=&homeserver($uname,$udomain);      my $uhome=&homeserver($uname,$udomain);
Line 5646  sub dump { Line 7562  sub dump {
                     $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});                      $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});
         return %{unserialize($reply, $escapedkeys)};          return %{unserialize($reply, $escapedkeys)};
     }      }
     my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);      my $rep;
       if ($encrypt) {
           $rep=&reply("encrypt:edump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
       } else {
           $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
       }
     my @pairs=split(/\&/,$rep);      my @pairs=split(/\&/,$rep);
     my %returnhash=();      my %returnhash=();
     if (!($rep =~ /^error/ )) {      if (!($rep =~ /^error/ )) {
Line 5707  sub currentdump { Line 7628  sub currentdump {
    #     #
    my %returnhash=();     my %returnhash=();
    #     #
    if ($rep eq "unknown_cmd") {      if ($rep eq 'unknown_cmd') {
        # an old lond will not know currentdump         # an old lond will not know currentdump
        # Do a dump and make it look like a currentdump         # Do a dump and make it look like a currentdump
        my @tmp = &dumpstore($courseid,$sdom,$sname,'.');         my @tmp = &dumpstore($courseid,$sdom,$sname,'.');
Line 5793  sub inc { Line 7714  sub inc {
 # --------------------------------------------------------------- put interface  # --------------------------------------------------------------- put interface
   
 sub put {  sub put {
    my ($namespace,$storehash,$udomain,$uname)=@_;     my ($namespace,$storehash,$udomain,$uname,$encrypt)=@_;
    if (!$udomain) { $udomain=$env{'user.domain'}; }     if (!$udomain) { $udomain=$env{'user.domain'}; }
    if (!$uname) { $uname=$env{'user.name'}; }     if (!$uname) { $uname=$env{'user.name'}; }
    my $uhome=&homeserver($uname,$udomain);     my $uhome=&homeserver($uname,$udomain);
Line 5802  sub put { Line 7723  sub put {
        $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';         $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
    }     }
    $items=~s/\&$//;     $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  # ------------------------------------------------------------ newput interface
Line 5842  sub putstore { Line 7767  sub putstore {
        foreach my $key (keys(%{$storehash})) {         foreach my $key (keys(%{$storehash})) {
            $namevalue.=&escape($key).'='.&freeze_escape($storehash->{$key}).'&';             $namevalue.=&escape($key).'='.&freeze_escape($storehash->{$key}).'&';
        }         }
        $namevalue .= 'ip='.&escape($ENV{'REMOTE_ADDR'}).         my $ip = &get_requestor_ip();
          $namevalue .= 'ip='.&escape($ip).
                      '&host='.&escape($perlvar{'lonHostID'}).                       '&host='.&escape($perlvar{'lonHostID'}).
                      '&version='.$esc_v.                       '&version='.$esc_v.
                      '&by='.&escape($env{'user.name'}.':'.$env{'user.domain'});                       '&by='.&escape($env{'user.name'}.':'.$env{'user.domain'});
        &Apache::lonnet::courselog($symb.':'.$uname.':'.$udomain.':PUTSTORE:'.$namevalue);         &courselog($symb.':'.$uname.':'.$udomain.':PUTSTORE:'.$namevalue);
    }     }
    if ($reply eq 'unknown_cmd') {     if ($reply eq 'unknown_cmd') {
        # gfall back to way things use to be done         # gfall back to way things use to be done
Line 5941  sub tmpget { Line 7867  sub tmpget {
     if (!defined($server)) { $server = $perlvar{'lonHostID'}; }      if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
     my $rep=&reply("tmpget:$token",$server);      my $rep=&reply("tmpget:$token",$server);
     my %returnhash;      my %returnhash;
       if ($rep =~ /^(con_lost|error|no_such_host)/i) {
           return %returnhash;
       }
     foreach my $item (split(/\&/,$rep)) {      foreach my $item (split(/\&/,$rep)) {
  my ($key,$value)=split(/=/,$item);   my ($key,$value)=split(/=/,$item);
         next if ($key =~ /^error: 2 /);  
  $returnhash{&unescape($key)}=&thaw_unescape($value);   $returnhash{&unescape($key)}=&thaw_unescape($value);
     }      }
     return %returnhash;      return %returnhash;
Line 5994  sub get_timebased_id { Line 7922  sub get_timebased_id {
     my $tries = 0;      my $tries = 0;
   
 # attempt to get lock on nohist_$namespace file  # 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) {      while (($gotlock ne 'ok') && $tries <$locktries) {
         $tries ++;          $tries ++;
         sleep 1;          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  # attempt to get unique identifier, based on current timestamp
     if ($gotlock eq 'ok') {      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;          my $id = time;
         $newid = $id;          $newid = $id;
         if ($idtype eq 'addcode') {          if ($idtype eq 'addcode') {
Line 6024  sub get_timebased_id { Line 7952  sub get_timebased_id {
             my %new_item =  (              my %new_item =  (
                               $prefix."\0".$newid => $who,                                $prefix."\0".$newid => $who,
                             );                              );
             my $putresult = &Apache::lonnet::put('nohist_'.$namespace,\%new_item,              my $putresult = &put('nohist_'.$namespace,\%new_item,
                                                  $cdom,$cnum);                                                   $cdom,$cnum);
             if ($putresult ne 'ok') {              if ($putresult ne 'ok') {
                 undef($newid);                  undef($newid);
Line 6064  sub portfolio_access { Line 7992  sub portfolio_access {
     if ($result) {      if ($result) {
         my %setters;          my %setters;
         if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {          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';                  return 'B';
             }              }
         } else {          } 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';                  return 'B';
             }              }
         }          }
Line 6086  sub portfolio_access { Line 8014  sub portfolio_access {
 }  }
   
 sub get_portfolio_access {  sub get_portfolio_access {
     my ($udom,$unum,$file_name,$group,$clientip,$access_hash) = @_;      my ($udom,$unum,$file_name,$group,$clientip,$access_hash,$portaccessref) = @_;
   
     if (!ref($access_hash)) {      if (!ref($access_hash)) {
  my $current_perms = &get_portfile_permissions($udom,$unum);   my $current_perms = &get_portfile_permissions($udom,$unum);
Line 6095  sub get_portfolio_access { Line 8023  sub get_portfolio_access {
  $access_hash = $access_controls{$file_name};   $access_hash = $access_controls{$file_name};
     }      }
   
     my ($public,$guest,@domains,@users,@courses,@groups,@ips);      my $portaccess;
       if (ref($portaccess) eq 'SCALAR') {
           $portaccess = $$portaccessref;
       } else {
           $portaccess = &usertools_access($unum,$udom,'portaccess',undef,'tools');
       }
   
       my ($public,$guest,@domains,@users,@courses,@groups,@ips,@userips);
     my $now = time;      my $now = time;
     if (ref($access_hash) eq 'HASH') {      if (ref($access_hash) eq 'HASH') {
         foreach my $key (keys(%{$access_hash})) {          foreach my $key (keys(%{$access_hash})) {
             my ($num,$scope,$end,$start) = ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);              my ($num,$scope,$end,$start) = ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
               next if (($scope ne 'ip') && ($portaccess == 0));
             if ($start > $now) {              if ($start > $now) {
                 next;                  next;
             }              }
Line 6121  sub get_portfolio_access { Line 8057  sub get_portfolio_access {
                 push(@groups,$key);                  push(@groups,$key);
             } elsif ($scope eq 'ip') {              } elsif ($scope eq 'ip') {
                 push(@ips,$key);                  push(@ips,$key);
               } elsif ($scope eq 'userip') {
                   push(@userips,$key);
             }              }
         }          }
         if ($public) {          if ($public) {
Line 6138  sub get_portfolio_access { Line 8076  sub get_portfolio_access {
             if ($allowed) {              if ($allowed) {
                 return 'ok';                  return 'ok';
             }              }
           } elsif (@userips > 0) {
               my $allowed;
               foreach my $useripkey (@userips) {
                   if (ref($access_hash->{$useripkey}{'ip'}) eq 'ARRAY') {
                       if (&Apache::loncommon::check_ip_acc(join(',',@{$access_hash->{$useripkey}{'ip'}}),$clientip)) {
                           $allowed = 1;
                           last;
                       }
                   }
               }
               if ($allowed) {
                   return 'ok';
               }
         }          }
         if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {          if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
             if ($guest) {              if ($guest) {
Line 6313  sub is_portfolio_file { Line 8264  sub is_portfolio_file {
     return;      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 {  sub usertools_access {
     my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref)=@_;      my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref)=@_;
     my ($access,%tools);      my ($access,%tools);
Line 6325  sub usertools_access { Line 8287  sub usertools_access {
                       unofficial => 1,                        unofficial => 1,
                       community  => 1,                        community  => 1,
                       textbook   => 1,                        textbook   => 1,
                         placement  => 1,
                         lti        => 1,
                  );                   );
     } elsif ($context eq 'requestauthor') {      } elsif ($context eq 'requestauthor') {
         %tools = (          %tools = (
                       requestauthor => 1,                        requestauthor => 1,
                  );                   );
       } elsif ($context eq 'authordefaults') {
           %tools = (
                         webdav    => 1,
                    );
     } else {      } else {
         %tools = (          %tools = (
                       aboutme   => 1,                        aboutme   => 1,
                       blog      => 1,                        blog      => 1,
                       webdav    => 1,  
                       portfolio => 1,                        portfolio => 1,
                         portaccess => 1,
                         timezone  => 1,
                  );                   );
     }      }
     return if (!defined($tools{$tool}));      return if (!defined($tools{$tool}));
Line 6351  sub usertools_access { Line 8320  sub usertools_access {
                 return $env{'environment.canrequest.'.$tool};                  return $env{'environment.canrequest.'.$tool};
             } elsif ($context eq 'requestauthor') {              } elsif ($context eq 'requestauthor') {
                 return $env{'environment.canrequest.author'};                  return $env{'environment.canrequest.author'};
               } elsif ($context eq 'authordefaults') {
                   if ($tool eq 'webdav') {
                       return $env{'environment.availabletools.'.$tool};
                   }
             } else {              } else {
                 return $env{'environment.availabletools.'.$tool};                  return $env{'environment.availabletools.'.$tool};
             }              }
Line 6359  sub usertools_access { Line 8332  sub usertools_access {
   
     my ($toolstatus,$inststatus,$envkey);      my ($toolstatus,$inststatus,$envkey);
     if ($context eq 'requestauthor') {      if ($context eq 'requestauthor') {
         $envkey = $context;           $envkey = $context;
       } elsif ($context eq 'authordefaults') {
           if ($tool eq 'webdav') {
               $envkey = 'tools.'.$tool;
           }
     } else {      } else {
         $envkey = $context.'.'.$tool;          $envkey = $context.'.'.$tool;
     }      }
Line 6460  sub is_course_owner { Line 8437  sub is_course_owner {
             if ($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'} eq $uname.':'.$udom) {              if ($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'} eq $uname.':'.$udom) {
                 return 1;                  return 1;
             } else {              } else {
                 my %courseinfo = &Apache::lonnet::coursedescription($cdom.'/'.$cnum);                  my %courseinfo = &coursedescription($cdom.'/'.$cnum);
                 if ($courseinfo{'internal.courseowner'} eq $uname.':'.$udom) {                  if ($courseinfo{'internal.courseowner'} eq $uname.':'.$udom) {
                     return 1;                      return 1;
                 }                  }
Line 6471  sub is_course_owner { Line 8448  sub is_course_owner {
 }  }
   
 sub is_advanced_user {  sub is_advanced_user {
     my ($udom,$uname) = @_;      my ($udom,$uname,$nocache) = @_;
       my ($is_adv,$is_author,$use_cache,$hashid);
     if ($udom ne '' && $uname ne '') {      if ($udom ne '' && $uname ne '') {
         if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {          if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
             if (wantarray) {              if (wantarray) {
Line 6479  sub is_advanced_user { Line 8457  sub is_advanced_user {
             } else {              } else {
                 return $env{'user.adv'};                  return $env{'user.adv'};
             }              }
           } elsif (!$nocache) {
               $use_cache = 1;
               $hashid = "$udom:$uname";  
               my ($info,$cached)=&is_cached_new('isadvau',$hashid);
               if ($cached) {
                   ($is_adv,$is_author) = split(/:/,$info);
                   if (wantarray) {
                       return ($is_adv,$is_author);
                   }
                   return $is_adv; 
               }
         }          }
     }      }
     my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1);      my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1);
     my %allroles;      my %allroles;
     my ($is_adv,$is_author);  
     foreach my $role (keys(%roleshash)) {      foreach my $role (keys(%roleshash)) {
         my ($trest,$tdomain,$trole,$sec) = split(/:/,$role);          my ($trest,$tdomain,$trole,$sec) = split(/:/,$role);
         my $area = '/'.$tdomain.'/'.$trest;          my $area = '/'.$tdomain.'/'.$trest;
Line 6514  sub is_advanced_user { Line 8502  sub is_advanced_user {
             }              }
         }          }
     }      }
       if ($use_cache) {
           my $cachetime = 600;
           &do_cache_new('isadvau',$hashid,$is_adv.':'.$is_author,$cachetime);
       }
     if (wantarray) {      if (wantarray) {
         return ($is_adv,$is_author);          return ($is_adv,$is_author);
     }      }
Line 6521  sub is_advanced_user { Line 8513  sub is_advanced_user {
 }  }
   
 sub check_can_request {  sub check_can_request {
     my ($dom,$can_request,$request_domains) = @_;      my ($dom,$can_request,$request_domains,$uname,$udom) = @_;
     my $canreq = 0;      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 ($types,$typename) = &Apache::loncommon::course_types();
     my @options = ('approval','validate','autolimit');      my @options = ('approval','validate','autolimit');
     my $optregex = join('|',@options);      my $optregex = join('|',@options);
     if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) {      if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) {
           my %willtrust;
         foreach my $type (@{$types}) {          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 ++;                  $canreq ++;
                 if (ref($request_domains) eq 'HASH') {                  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;                      $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});                  my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type});
                 if (@curr > 0) {                  if (@curr > 0) {
                     foreach my $item (@curr) {                      foreach my $item (@curr) {
                         if (ref($request_domains) eq 'HASH') {                          if (ref($request_domains) eq 'HASH') {
                             my ($otherdom) = ($item =~ /^($match_domain):($optregex)(=?\d*)$/);                              my ($otherdom) = ($item =~ /^($match_domain):($optregex)(=?\d*)$/);
                             if ($otherdom ne '') {                              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);                                          push(@{$request_domains->{$type}},$otherdom);
                                     }                                      }
                                 } else {  
                                     push(@{$request_domains->{$type}},$otherdom);  
                                 }                                  }
                             }                              }
                         }                          }
                     }                      }
                     unless($dom eq $env{'user.domain'}) {                      unless ($dom eq $env{'user.domain'}) {
                         $canreq ++;                          $canreq ++;
                         if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) {                          if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) {
                             $can_request->{$type} = 1;                              $can_request->{$type} = 1;
Line 6621  sub customaccess { Line 8623  sub customaccess {
 # ------------------------------------------------- Check for a user privilege  # ------------------------------------------------- Check for a user privilege
   
 sub allowed {  sub allowed {
     my ($priv,$uri,$symb,$role,$clientip)=@_;      my ($priv,$uri,$symb,$role,$clientip,$noblockcheck,$ignorecache,$nodeeplinkcheck,$nodeeplinkout)=@_;
     my $ver_orguri=$uri;      my $ver_orguri=$uri;
     $uri=&deversion($uri);      $uri=&deversion($uri);
     my $orguri=$uri;      my $orguri=$uri;
     $uri=&declutter($uri);      $uri=&declutter($uri);
   
     if ($priv eq 'evb') {      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\&([^\:]*)/) {          if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) {
             return $1;              return $1;
         } else {          } else {
Line 6638  sub allowed { Line 8640  sub allowed {
   
     if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }      if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
 # Free bre access to adm and meta resources  # 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/|) ))    || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) 
  && ($priv eq 'bre')) {   && ($priv eq 'bre')) {
  return 'F';   return 'F';
Line 6649  sub allowed { Line 8651  sub allowed {
     if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) &&       if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) && 
  ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {   ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {
         my %setters;          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';              return 'B';
         } else {          } else {
             return 'F';              return 'F';
Line 6686  sub allowed { Line 8688  sub allowed {
 # Free bre to public access  # Free bre to public access
   
     if ($priv eq 'bre') {      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'})) {    if (($copyright eq 'public') && (!$env{'request.course.id'})) { 
            return 'F';              return 'F'; 
         }          }
Line 6744  sub allowed { Line 8749  sub allowed {
                         my $adom = $1;                          my $adom = $1;
                         foreach my $key (keys(%env)) {                          foreach my $key (keys(%env)) {
                             if ($key =~ m{^user\.role\.(ca|aa)/\Q$adom\E}) {                              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;                                      $ownaccess = 1;
                                     last;                                      last;
                                 }                                  }
Line 6757  sub allowed { Line 8762  sub allowed {
                         foreach my $role ('ca','aa') {                           foreach my $role ('ca','aa') { 
                             if ($env{"user.role.$role./$adom/$aname"}) {                              if ($env{"user.role.$role./$adom/$aname"}) {
                                 my ($start,$end) =                                  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;                                      $ownaccess = 1;
                                     last;                                      last;
                                 }                                  }
Line 6803  sub allowed { Line 8808  sub allowed {
   
     if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri}      if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri}
        =~/\Q$priv\E\&([^\:]*)/) {         =~/\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 6816  sub allowed { Line 8847  sub allowed {
         if ($match) {          if ($match) {
             if ($env{'user.priv.'.$env{'request.role'}.'./'}              if ($env{'user.priv.'.$env{'request.role'}.'./'}
                   =~/\Q$priv\E\&([^\:]*)/) {                    =~/\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 {                  } else {
                     $thisallowed.=$1;                      my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);
                       if (@blockers > 0) {
                           $thisallowed = 'B';
                       } else {
                           $thisallowed.=$value;
                       }
                 }                  }
             }              }
         } else {          } else {
Line 6832  sub allowed { Line 8874  sub allowed {
                     $refuri=&declutter($refuri);                      $refuri=&declutter($refuri);
                     my ($match) = &is_on_map($refuri);                      my ($match) = &is_on_map($refuri);
                     if ($match) {                      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';                              $thisallowed='F';
                           } else {
                               my @blockers = &has_comm_blocking($priv,'',$refuri,'',1);
                               if (@blockers > 0) {
                                   $thisallowed = 'B';
                               } else {
                                   $thisallowed='F';
                               }
                         }                          }
                     }                      }
                 }                  }
Line 6858  sub allowed { Line 8910  sub allowed {
   
 # If this is generating or modifying users, exit with special codes  # If this is generating or modifying users, exit with special codes
   
     if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:caa:'=~/\:\Q$priv\E\:/) {      if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:caa:vca:vaa:'=~/\:\Q$priv\E\:/) {
  if (($priv eq 'cca') || ($priv eq 'caa')) {   if (($priv eq 'cca') || ($priv eq 'caa')) {
     my ($audom,$auname)=split('/',$uri);      my ($audom,$auname)=split('/',$uri);
 # no author name given, so this just checks on the general right to make a co-author in this domain  # no author name given, so this just checks on the general right to make a co-author in this domain
Line 6867  sub allowed { Line 8919  sub allowed {
     if (($auname ne $env{'user.name'} && $env{'request.role'} !~ /^dc\./) ||      if (($auname ne $env{'user.name'} && $env{'request.role'} !~ /^dc\./) ||
  (($audom ne $env{'user.domain'} && $env{'request.role'} !~ /^dc\./) &&   (($audom ne $env{'user.domain'} && $env{'request.role'} !~ /^dc\./) &&
  ($audom ne $env{'request.role.domain'}))) { return ''; }   ($audom ne $env{'request.role.domain'}))) { return ''; }
    } elsif (($priv eq 'vca') || ($priv eq 'vaa')) {
               my ($audom,$auname)=split('/',$uri);
               unless ($auname) { return $thisallowed; }
               unless (($env{'request.role'} eq "dc./$audom") ||
                       ($env{'request.role'} eq "ca./$uri")) {
                   return '';
               }
  }   }
  return $thisallowed;   return $thisallowed;
     }      }
Line 6878  sub allowed { Line 8937  sub allowed {
   
     if ($env{'request.course.id'}) {      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'};         $courseprivid=$env{'request.course.id'};
        if ($env{'request.course.sec'}) {         if ($env{'request.course.sec'}) {
           $courseprivid.='/'.$env{'request.course.sec'};            $courseprivid.='/'.$env{'request.course.sec'};
Line 6891  sub allowed { Line 8966  sub allowed {
                =~/\Q$priv\E\&([^\:]*)/) {                 =~/\Q$priv\E\&([^\:]*)/) {
                my $value = $1;                 my $value = $1;
                if ($priv eq 'bre') {                 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;                         $thisallowed.=$value;
                      } else {
                          my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);
                          if (@blockers > 0) {
                              $thisallowed = 'B';
                          } else {
                              $thisallowed.=$value;
                          }
                    }                     }
                } else {                 } else {
                    $thisallowed.=$value;                     $thisallowed.=$value;
Line 6903  sub allowed { Line 8988  sub allowed {
                $checkreferer=0;                 $checkreferer=0;
            }             }
        }         }
          
        if ($checkreferer) {         if ($checkreferer) {
   my $refuri=$env{'httpref.'.$orguri};    my $refuri=$env{'httpref.'.$orguri};
             unless ($refuri) {              unless ($refuri) {
Line 6929  sub allowed { Line 9014  sub allowed {
                   =~/\Q$priv\E\&([^\:]*)/) {                    =~/\Q$priv\E\&([^\:]*)/) {
                   my $value = $1;                    my $value = $1;
                   if ($priv eq 'bre') {                    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;                            $thisallowed.=$value;
                         } else {
                             my @blockers = &has_comm_blocking($priv,'',$refuri,'',1);
                             if (@blockers > 0) {
                                 $thisallowed = 'B';
                             } else {
                                 $thisallowed.=$value;
                             }
                       }                        }
                   } else {                    } else {
                       $thisallowed.=$value;                        $thisallowed.=$value;
Line 6970  sub allowed { Line 9065  sub allowed {
 #  #
   
 # Possibly locked functionality, check all courses  # 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  # 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/) {      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)\.([^\.]*)/) {             if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
                my $courseid=$2;                 my $courseid=$2;
                my $roleid=$1.'.'.$2;                 my $roleid=$1.'.'.$2;
                $courseid=~s/^\///;                 $courseid=~s/^\///;
                  unless ($env{'request.role'} eq $roleid) {
                      my ($start,$end) = split(/\./,$env{$envkey});
                      next unless (($now >= $start) && (!$end || $end > $now));
                  }
                my $expiretime=600;                 my $expiretime=600;
                if ($env{'request.role'} eq $roleid) {                 if ($env{'request.role'} eq $roleid) {
   $expiretime=120;    $expiretime=120;
Line 7002  sub allowed { Line 9129  sub allowed {
                }                 }
                if (($env{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/)                 if (($env{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/)
                 || ($env{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {                  || ($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'},                         &log($env{'user.domain'},$env{'user.name'},
                             $env{'user.home'},                              $env{'user.home'},
                             'Locked by priv: '.$priv.' for '.$uri.' due to '.                              'Locked by priv: '.$priv.' for '.$uri.' due to '.
Line 7014  sub allowed { Line 9141  sub allowed {
    }     }
        }         }
     }      }
      
 #  #
 # Rest of the restrictions depend on selected course  # Rest of the restrictions depend on selected course
 #  #
Line 7041  sub allowed { Line 9168  sub allowed {
        my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};         my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};
        if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}         if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}
    =~/\Q$rolecode\E/) {     =~/\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'}.':'.         &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
  'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.   'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
  $env{'request.course.id'});   $env{'request.course.id'});
Line 7051  sub allowed { Line 9178  sub allowed {
   
        if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}         if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}
    =~/\Q$unamedom\E/) {     =~/\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'}.         &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
  'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.   'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
  $env{'request.course.id'});   $env{'request.course.id'});
Line 7073  sub allowed { Line 9200  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?  # Restricted by state or randomout?
   
    if ($thisallowed=~/X/) {     if ($thisallowed=~/X/) {
Line 7093  sub allowed { Line 9231  sub allowed {
  return 'A';   return 'A';
     } elsif ($thisallowed eq 'B') {      } elsif ($thisallowed eq 'B') {
         return 'B';          return 'B';
       } elsif ($thisallowed eq 'D') {
           return 'D';
     }      }
    return 'F';     return 'F';
 }  }
Line 7109  sub constructaccess { Line 9249  sub constructaccess {
     my ($ownername,$ownerdomain,$ownerhome);      my ($ownername,$ownerdomain,$ownerhome);
   
     ($ownerdomain,$ownername) =      ($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  # The URL does not really point to any authorspace, forget it
     unless (($ownername) && ($ownerdomain)) { return ''; }      unless (($ownername) && ($ownerdomain)) { return ''; }
Line 7123  sub constructaccess { Line 9263  sub constructaccess {
        if (exists($env{'user.priv.au./'.$ownerdomain.'/./'})) {         if (exists($env{'user.priv.au./'.$ownerdomain.'/./'})) {
           return ($ownername,$ownerdomain,$ownerhome);            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'})) {
                       return if ($env{'course.'.$env{'request.course.id'}.'.internal.crsauthor'} eq '0');
                       unless ($env{'course.'.$env{'request.course.id'}.'.internal.crsauthor'}) {
                           my %domdefs = &get_domain_defaults($ownerdomain);
                           my $type = lc($env{'course.'.$env{'request.course.id'}.'.type'});
                           unless (($type eq 'community') || ($type eq 'placement')) {
                               $type = 'unofficial';
                               if ($env{'course.'.$env{'request.course.id'}.'internal.coursecode'} ne '') {
                                   $type = 'official';
                               } elsif ($env{'course.'.$env{'request.course.id'}.'internal.textbook'} ne '') {
                                   $type = 'textbook';
                               } else {
                                   $type = 'unofficial';
                               }
                           }
                           return if ($domdefs{$type.'crsauthor'} eq '0');
                       }
                       $ownerhome = $env{'course.'.$env{'request.course.id'}.'.home'};
                       return ($ownername,$ownerdomain,$ownerhome);
                   }
               }
           }
           return '';
     } else {      } else {
 # Co-author for this?  # Co-author for this?
         if (exists($env{'user.priv.ca./'.$ownerdomain.'/'.$ownername.'./'}) ||          if (exists($env{'user.priv.ca./'.$ownerdomain.'/'.$ownername.'./'}) ||
Line 7164  sub constructaccess { Line 9332  sub constructaccess {
     return '';      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 {  sub get_comm_blocks {
     my ($cdom,$cnum) = @_;      my ($cdom,$cnum) = @_;
     if ($cdom eq '' || $cnum eq '') {      if ($cdom eq '' || $cnum eq '') {
Line 7177  sub get_comm_blocks { Line 9376  sub get_comm_blocks {
     if ((defined($cached)) && (ref($blocksref) eq 'HASH')) {      if ((defined($cached)) && (ref($blocksref) eq 'HASH')) {
         %commblocks = %{$blocksref};          %commblocks = %{$blocksref};
     } else {      } else {
         %commblocks = &Apache::lonnet::dump('comm_block',$cdom,$cnum);          %commblocks = &dump('comm_block',$cdom,$cnum);
         my $cachetime = 600;          my $cachetime = 600;
         &do_cache_new('comm_block',$hashid,\%commblocks,$cachetime);          &do_cache_new('comm_block',$hashid,\%commblocks,$cachetime);
     }      }
     return %commblocks;      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;      my %commblocks;
     if (ref($blocks) eq 'HASH') {      if (ref($blocks) eq 'HASH') {
         %commblocks = %{$blocks};          %commblocks = %{$blocks};
     } else {      } else {
         %commblocks = &get_comm_blocks();          %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();      my $navmap = Apache::lonnavmaps::navmap->new();
       return %blockers unless (ref($navmap));
       my $now = time;
     foreach my $block (keys(%commblocks)) {      foreach my $block (keys(%commblocks)) {
         if ($block =~ /^(\d+)____(\d+)$/) {          if ($block =~ /^(\d+)____(\d+)$/) {
             my ($start,$end) = ($1,$2);              my ($start,$end) = ($1,$2);
Line 7212  sub has_comm_blocking { Line 9409  sub has_comm_blocking {
                 if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {                  if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
                     if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {                      if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
                         if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) 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 (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 7230  sub has_comm_blocking { Line 9423  sub has_comm_blocking {
             }              }
         } elsif ($block =~ /^firstaccess____(.+)$/) {          } elsif ($block =~ /^firstaccess____(.+)$/) {
             my $item = $1;              my $item = $1;
             my @to_test;  
             if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {              if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
                 if (ref($commblocks{$block}{'blocks'}{'docs'}) 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 {                          } 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)) {                                      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);                                          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 7296  sub has_comm_blocking { Line 9508  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.  #   splits it in to its filename and path to the filename.
 #   Seems like File::Basename could have done this more clearly.  #   Seems like File::Basename could have done this more clearly.
 #   Parameters:  #   Parameters:
Line 7390  sub get_symb_from_alias { Line 9730  sub get_symb_from_alias {
   
 sub definerole {  sub definerole {
   if (allowed('mcr','/')) {    if (allowed('mcr','/')) {
     my ($rolename,$sysrole,$domrole,$courole)=@_;      my ($rolename,$sysrole,$domrole,$courole,$uname,$udom)=@_;
     foreach my $role (split(':',$sysrole)) {      foreach my $role (split(':',$sysrole)) {
  my ($crole,$cqual)=split(/\&/,$role);   my ($crole,$cqual)=split(/\&/,$role);
         if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; }          if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; }
Line 7418  sub definerole { Line 9758  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'}:".      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);                  escape($sysrole.'_'.$domrole.'_'.$courole);
     return reply($command,$env{'user.home'});      return reply($command,$uhome);
   } else {    } else {
     return 'refused';      return 'refused';
   }    }
Line 7504  sub update_allusers_table { Line 9852  sub update_allusers_table {
   
 sub fetch_enrollment_query {  sub fetch_enrollment_query {
     my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;      my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;
     my $homeserver;      my ($homeserver,$sleep,$loopmax);
     my $maxtries = 1;      my $maxtries = 1;
     if ($context eq 'automated') {      if ($context eq 'automated') {
         $homeserver = $perlvar{'lonHostID'};          $homeserver = $perlvar{'lonHostID'};
           $sleep = 2;
           $loopmax = 100;
         $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout          $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout
     } else {      } else {
         $homeserver = &homeserver($cnum,$dom);          $homeserver = &homeserver($cnum,$dom);
Line 7525  sub fetch_enrollment_query { Line 9875  sub fetch_enrollment_query {
         &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum);           &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); 
         return 'error: '.$queryid;          return 'error: '.$queryid;
     }      }
     my $reply = &get_query_reply($queryid);      my $reply = &get_query_reply($queryid,$sleep,$loopmax);
     my $tries = 1;      my $tries = 1;
     while (($reply=~/^timeout/) && ($tries < $maxtries)) {      while (($reply=~/^timeout/) && ($tries < $maxtries)) {
         $reply = &get_query_reply($queryid);          $reply = &get_query_reply($queryid,$sleep,$loopmax);
         $tries ++;          $tries ++;
     }      }
     if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {      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);          &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
     } else {      } else {
         my @responses = split(/:/,$reply);          my @responses = split(/:/,$reply);
         if ($homeserver eq $perlvar{'lonHostID'}) {          if (grep { $_ eq $homeserver } &current_machine_ids()) {
             foreach my $line (@responses) {              foreach my $line (@responses) {
                 my ($key,$value) = split(/=/,$line,2);                  my ($key,$value) = split(/=/,$line,2);
                 $$replyref{$key} = $value;                  $$replyref{$key} = $value;
Line 7553  sub fetch_enrollment_query { Line 9903  sub fetch_enrollment_query {
                         if ($xml_classlist =~ /^error/) {                          if ($xml_classlist =~ /^error/) {
                             &logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum);                              &logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum);
                         } else {                          } else {
                             if ( open(FILE,">$destname") ) {                              if ( open(FILE,">",$destname) ) {
                                 print FILE &unescape($xml_classlist);                                  print FILE &unescape($xml_classlist);
                                 close(FILE);                                  close(FILE);
                             } else {                              } else {
Line 7570  sub fetch_enrollment_query { Line 9920  sub fetch_enrollment_query {
 }  }
   
 sub get_query_reply {  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 $replyfile=LONCAPA::tempdir().$queryid;
     my $reply='';      my $reply='';
     for (1..100) {      for (1..$loopmax) {
  sleep 2;   sleep($sleep);
         if (-e $replyfile.'.end') {          if (-e $replyfile.'.end') {
     if (open(my $fh,$replyfile)) {      if (open(my $fh,"<",$replyfile)) {
  $reply = join('',<$fh>);   $reply = join('',<$fh>);
  close($fh);   close($fh);
    } else { return 'error: reply_file_error'; }     } else { return 'error: reply_file_error'; }
Line 7697  sub auto_validate_instcode { Line 10053  sub auto_validate_instcode {
     return ($outcome,$description,$defaultcredits);      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 {  sub auto_create_password {
     my ($cnum,$cdom,$authparam,$udom) = @_;      my ($cnum,$cdom,$authparam,$udom) = @_;
     my ($homeserver,$response);      my ($homeserver,$response);
Line 7968  sub auto_validate_class_sec { Line 10343  sub auto_validate_class_sec {
     return $response;      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 {  sub auto_crsreq_update {
     my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title,      my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title,
         $code,$accessstart,$accessend,$inbound) = @_;          $code,$accessstart,$accessend,$inbound) = @_;
Line 7997  sub auto_crsreq_update { Line 10431  sub auto_crsreq_update {
     return \%crsreqresponse;      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  # ------------------------------------------------------- Course Group routines
   
 sub get_coursegroups {  sub get_coursegroups {
Line 8041  sub toggle_coursegroup_status { Line 10576  sub toggle_coursegroup_status {
 }  }
   
 sub modify_group_roles {  sub modify_group_roles {
     my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs,$selfenroll,$context) = @_;      my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs,$selfenroll,$context,
           $othdomby,$requester) = @_;
     my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;      my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
     my $role = 'gr/'.&escape($userprivs);      my $role = 'gr/'.&escape($userprivs);
     my ($uname,$udom) = split(/:/,$user);      my ($uname,$udom) = split(/:/,$user);
     my $result = &assignrole($udom,$uname,$url,$role,$end,$start,'',$selfenroll,$context);      my $result = &assignrole($udom,$uname,$url,$role,$end,$start,'',$selfenroll,$context,
                                $othdomby,$requester);
     if ($result eq 'ok') {      if ($result eq 'ok') {
         &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);          &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
     }      }
Line 8144  sub plaintext { Line 10681  sub plaintext {
     my %rolenames = (      my %rolenames = (
                       Course    => 'std',                        Course    => 'std',
                       Community => 'alt1',                        Community => 'alt1',
                         Placement => 'std',
                     );                      );
     if ($cid ne '') {      if ($cid ne '') {
         if ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '') {          if ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '') {
Line 8172  sub plaintext { Line 10710  sub plaintext {
   
 sub assignrole {  sub assignrole {
     my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,      my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,
         $context)=@_;          $context,$othdomby,$requester,$reqsec,$reqrole)=@_;
     my $mrole;      my ($mrole,$rolelogcontext);
     if ($role =~ /^cr\//) {      if ($role =~ /^cr\//) {
         my $cwosec=$url;          my $cwosec=$url;
         $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;          $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
  unless (&allowed('ccr',$cwosec)) {          if ((!&allowed('ccr',$cwosec)) && (!&allowed('ccr',$udom))) {
            my $refused = 1;              my $refused = 1;
            if ($context eq 'requestcourses') {              if ($context eq 'requestcourses') {
                if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {                  if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {
                    if ($role =~ m{^cr/($match_domain)/($match_username)/([^/]+)$}) {                      if ($role =~ m{^cr/($match_domain)/($match_username)/([^/]+)$}) {
                        if (($1 eq $env{'user.domain'}) && ($2 eq $env{'user.name'})) {                          if (($1 eq $env{'user.domain'}) && ($2 eq $env{'user.name'})) {
                            my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});                              my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
                            my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));                              my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
                            if ($crsenv{'internal.courseowner'} eq                              if ($crsenv{'internal.courseowner'} eq
                                $env{'user.name'}.':'.$env{'user.domain'}) {                                  $env{'user.name'}.':'.$env{'user.domain'}) {
                                $refused = '';                                  $refused = '';
                            }                              }
                        }                          }
                    }                      }
                }                  }
            }              } elsif (($context eq 'course') && ($othdomby eq 'othdombyuser')) {
            if ($refused) {                  my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
                &logthis('Refused custom assignrole: '.                  my ($sec) = ($url =~ m{^/\Q$cwosec\E/(.*)$});
                         $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.                  my $key = "$uname:$udom:$role:$sec";
                         ' by '.$env{'user.name'}.' at '.$env{'user.domain'});                  my %queuedrolereq = &Apache::lonnet::get('nohist_othdomqueued',[$key],$cdom,$cnum);
                return 'refused';                  if ((exists($queuedrolereq{$key})) && (ref($queuedrolereq{$key}) eq 'HASH')) {
            }                      if (($queuedrolereq{$key}{'adj'} eq 'user') && ($queuedrolereq{$key}{'requester'} eq $requester)) {
                           $refused = '';
                       }
                   }
               }
               if ($refused) {
                   &logthis('Refused custom assignrole: '.
                            $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.
                            ' by '.$env{'user.name'}.' at '.$env{'user.domain'});
                   return 'refused';
               }
         }          }
         $mrole='cr';          $mrole='cr';
     } elsif ($role =~ /^gr\//) {      } elsif ($role =~ /^gr\//) {
         my $cwogrp=$url;          my $cwogrp=$url;
         $cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2};          $cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2};
         unless (&allowed('mdg',$cwogrp)) {          if (!&allowed('mdg',$cwogrp)) {
             &logthis('Refused group assignrole: '.              my $refused = 1;
               $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.              if (($refused) && ($othdomby eq 'othdombyuser') && ($requester ne '') && ($reqrole ne '')) {
                     $env{'user.name'}.' at '.$env{'user.domain'});                  my ($cdom,$cnum) = ($cwogrp =~ m{^/?($match_domain)/($match_courseid)$});
             return 'refused';                  my $key = "$uname:$udom:$reqrole:$reqsec";
                   my %queuedrolereq = &Apache::lonnet::get('nohist_othdomqueued',[$key],$cdom,$cnum);
                   if ((exists($queuedrolereq{$key})) && (ref($queuedrolereq{$key}) eq 'HASH')) {
                       if (($queuedrolereq{$key}{'adj'} eq 'user') && ($queuedrolereq{$key}{'requester'} eq $requester)) {
                           $refused = '';
                       }
                   }
               }
               if ($refused) {
                   &logthis('Refused group assignrole: '.
                            $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
                            $env{'user.name'}.' at '.$env{'user.domain'});
                   return 'refused';
               }
         }          }
         $mrole='gr';          $mrole='gr';
     } else {      } else {
Line 8225  sub assignrole { Line 10786  sub assignrole {
             }              }
             if ($refused) {              if ($refused) {
                 my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});                  my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
                 if (!$selfenroll && $context eq 'course') {                  if (!$selfenroll && ($othdomby ne 'othdombyuser') &&
                      (($context eq 'course') || ($context eq 'ltienroll' && $env{'request.lti.login'}))) {
                     my %crsenv;                      my %crsenv;
                     if ($role eq 'cc' || $role eq 'co') {                      if ($role eq 'cc' || $role eq 'co') {
                         %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));                          %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
Line 8245  sub assignrole { Line 10807  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 ($othdomby eq 'othdombyuser') {
                       my ($key,%queuedrolereq);
                       if ($context eq 'course') {
                           my ($sec) = ($url =~ m{^/\Q$cwosec\E/(.*)$});
                           $key = "$uname:$udom:$role:$sec";
                           %queuedrolereq = &Apache::lonnet::get('nohist_othdomqueued',[$key],$cdom,$cnum);
                           if ((exists($queuedrolereq{$key})) && (ref($queuedrolereq{$key}) eq 'HASH')) {
                               if (($queuedrolereq{$key}{'adj'} eq 'user') && ($queuedrolereq{$key}{'requester'} eq $requester)) {
                                   if ((($role eq 'cc') && ($cnum !~ /^$match_community$/)) || 
                                       (($role eq 'co') && ($cnum =~ /^$match_community$/))) {
                                       my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
                                       if ($crsenv{'internal.courseowner'} eq $requester) {
                                           $refused = '';
                                       }
                                   } elsif ($role =~ /^(?:in|ta|ep|st)$/) {
                                       $refused = '';
                                   }
                               }
                           }
                       } elsif (($context eq 'author') && ($role =~ /^ca|aa$/)) {
                           my $key = "$uname:$udom:$role"; 
                           my ($audom,$auname) = ($url =~ m{^/($match_domain)/($match_username)$});
                           if (($audom ne '') && ($auname ne '')) {
                               my %queuedrolereq = &Apache::lonnet::get('nohist_othdomqueued',[$key],$audom,$auname);
                               if ((exists($queuedrolereq{$key})) && (ref($queuedrolereq{$key}) eq 'HASH')) {
                                   if (($queuedrolereq{$key}{'adj'} eq 'user') && ($queuedrolereq{$key}{'requester'} eq $requester)) {
                                       $refused = '';
                                   }
                               }
                           }
                       } elsif (($context eq 'domain') && ($role ne 'dc') && ($role ne 'su')) {
                           my $key = "$uname:$udom:$role";
                           my ($roledom) = ($url =~ m{^/($match_domain)/\Q$role\E$});
                           if ($roledom ne '') {
                               my $confname = $roledom.'-domainconfig';
                               my %queuedrolereq = &Apache::lonnet::get('nohist_othdomqueued',[$key],$roledom,$confname);
                               if ((exists($queuedrolereq{$key})) && (ref($queuedrolereq{$key}) eq 'HASH')) {
                                   if (($queuedrolereq{$key}{'adj'} eq 'user') && ($queuedrolereq{$key}{'requester'} eq $requester)) {
                                       $refused = '';
                                   }
                               }
                           }
                       }
                 } elsif ($context eq 'requestcourses') {                  } elsif ($context eq 'requestcourses') {
                     my @possroles = ('st','ta','ep','in','cc','co');                      my @possroles = ('st','ta','ep','in','cc','co');
                     if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {                      if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {
Line 8299  sub assignrole { Line 10908  sub assignrole {
                             }                              }
                         }                          }
                     }                      }
                   } elsif (($context eq 'author') && (($role eq 'ca' || $role eq 'aa'))) {
                       if ($url =~ m{^/($match_domain)/($match_username)$}) {
                           my ($audom,$auname) = ($1,$2);
                           if ((&Apache::lonnet::allowed('v'.$role,"$audom/$auname")) &&
                               ($env{"environment.internal.manager.$url"})) {
                               $refused = '';
                               $rolelogcontext = 'coauthor';
                           }
                       }
                 }                  }
                 if ($refused) {                  if ($refused) {
                     &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.                      &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
Line 8359  sub assignrole { Line 10977  sub assignrole {
                                                  $origstart,$selfenroll,$context);                                                   $origstart,$selfenroll,$context);
             }              }
             &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,              &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
                            $selfenroll,$context);                             $selfenroll,$context,$othdomby,$requester);
         } elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') ||          } 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,              &domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
                            $context);                             $context,$othdomby,$requester);
         } elsif (($role eq 'ca') || ($role eq 'aa')) {          } elsif (($role eq 'ca') || ($role eq 'aa')) {
               if ($rolelogcontext eq '') {
                   $rolelogcontext = $context;
               }
             &coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,              &coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
                              $context);                                $rolelogcontext,$othdomby,$requester); 
         }          }
         if ($role eq 'cc') {          if ($role eq 'cc') {
             &autoupdate_coowners($url,$end,$start,$uname,$udom);              &autoupdate_coowners($url,$end,$start,$uname,$udom);
Line 8384  sub autoupdate_coowners { Line 11006  sub autoupdate_coowners {
         if ($domdesign{$cdom.'.autoassign.co-owners'}) {          if ($domdesign{$cdom.'.autoassign.co-owners'}) {
             my %coursehash = &coursedescription($cdom.'_'.$cnum);              my %coursehash = &coursedescription($cdom.'_'.$cnum);
             my $instcode = $coursehash{'internal.coursecode'};              my $instcode = $coursehash{'internal.coursecode'};
               my $xlists = $coursehash{'internal.crosslistings'};
             if ($instcode ne '') {              if ($instcode ne '') {
                 if (($start && $start <= $now) && ($end == 0) || ($end > $now)) {                  if (($start && $start <= $now) && ($end == 0) || ($end > $now)) {
                     unless ($coursehash{'internal.courseowner'} eq $uname.':'.$udom) {                      unless ($coursehash{'internal.courseowner'} eq $uname.':'.$udom) {
                         my ($delcoowners,@newcoowners,$putresult,$delresult,$coowners);                          my ($delcoowners,@newcoowners,$putresult,$delresult,$coowners);
                         my ($result,$desc) = &auto_validate_instcode($cnum,$cdom,$instcode,$uname.':'.$udom);                          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 ($result eq 'valid') {
                             if ($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'})) {
Line 8401  sub autoupdate_coowners { Line 11035  sub autoupdate_coowners {
                             } else {                              } else {
                                 push(@newcoowners,$uname.':'.$udom);                                  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) {                          if (@newcoowners || $delcoowners) {
                             &store_coowners($cdom,$cnum,$coursehash{'home'},                              &store_coowners($cdom,$cnum,$coursehash{'home'},
Line 8451  sub store_coowners { Line 11083  sub store_coowners {
     }      }
     if (($putresult eq 'ok') || ($delresult eq 'ok')) {      if (($putresult eq 'ok') || ($delresult eq 'ok')) {
         my %crsinfo =          my %crsinfo =
             &Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.');              &courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.');
         if (ref($crsinfo{$cid}) eq 'HASH') {          if (ref($crsinfo{$cid}) eq 'HASH') {
             $crsinfo{$cid}{'co-owners'} = \@newcoowners;              $crsinfo{$cid}{'co-owners'} = \@newcoowners;
             my $cidput = &Apache::lonnet::courseidput($cdom,\%crsinfo,$chome,'notime');              my $cidput = &courseidput($cdom,\%crsinfo,$chome,'notime');
         }          }
     }      }
 }  }
Line 8465  sub store_coowners { Line 11097  sub store_coowners {
 sub modifyuserauth {  sub modifyuserauth {
     my ($udom,$uname,$umode,$upass)=@_;      my ($udom,$uname,$umode,$upass)=@_;
     my $uhome=&homeserver($uname,$udom);      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.', '.      &logthis('Call to modify user authentication '.$udom.', '.$uname.', '.
              $umode.' by '.$env{'user.name'}.' at '.$env{'user.domain'}.               $umode.' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
              ' in domain '.$env{'request.role.domain'});                 ' in domain '.$env{'request.role.domain'});  
     my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.      my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.
      &escape($upass),$uhome);       &escape($upass),$uhome);
       my $ip = &get_requestor_ip();
     &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},      &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},
         'Authentication changed for '.$udom.', '.$uname.', '.$umode.          'Authentication changed for '.$udom.', '.$uname.', '.$umode.
          '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);           '(Remote '.$ip.'): '.$reply);
     &log($udom,,$uname,$uhome,      &log($udom,,$uname,$uhome,
         'Authentication changed by '.$env{'user.domain'}.', '.          'Authentication changed by '.$env{'user.domain'}.', '.
                                      $env{'user.name'}.', '.$umode.                                       $env{'user.name'}.', '.$umode.
          '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);           '(Remote '.$ip.'): '.$reply);
     unless ($reply eq 'ok') {      unless ($reply eq 'ok') {
         &logthis('Authentication mode error: '.$reply);          &logthis('Authentication mode error: '.$reply);
  return 'error: '.$reply;   return 'error: '.$reply;
Line 8511  sub modifyuser { Line 11159  sub modifyuser {
     my $newuser;      my $newuser;
     if ($uhome eq 'no_host') {      if ($uhome eq 'no_host') {
         $newuser = 1;          $newuser = 1;
           unless (($umode && ($upass ne '')) || ($umode eq 'localauth') ||
                   ($umode eq 'lti')) {
               return 'error: more information needed to create new user';
           }
     }      }
 # ----------------------------------------------------------------- Create User  # ----------------------------------------------------------------- Create User
     if (($uhome eq 'no_host') &&       if (($uhome eq 'no_host') && 
  (($umode && $upass) || ($umode eq 'localauth'))) {   (($umode && $upass) || ($umode eq 'localauth') || ($umode eq 'lti'))) {
         my $unhome='';          my $unhome='';
         if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) {           if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) { 
             $unhome = $desiredhome;              $unhome = $desiredhome;
Line 8556  sub modifyuser { Line 11208  sub modifyuser {
                   'current user id "'.$uidhash{$uname}.'".';                    'current user id "'.$uidhash{$uname}.'".';
           }            }
        } else {         } else {
   &idput($udom,($uname => $uid));    &idput($udom,{$uname => $uid},$uhome,'ids');
        }         }
     }      }
 # -------------------------------------------------------------- Add names, etc  # -------------------------------------------------------------- Add names, etc
Line 8652  sub modifyuser { Line 11304  sub modifyuser {
         return 'error: '.$reply;          return 'error: '.$reply;
     }      }
     if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) {      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);      my $sqlresult = &update_allusers_table($uname,$udom,\%names);
     &devalidate_cache_new('namescache',$uname.':'.$udom);      &devalidate_cache_new('namescache',$uname.':'.$udom);
Line 8666  sub modifyuser { Line 11318  sub modifyuser {
 sub modifystudent {  sub modifystudent {
     my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,      my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
         $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid,          $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid,
         $selfenroll,$context,$inststatus,$credits)=@_;          $selfenroll,$context,$inststatus,$credits,$instsec)=@_;
     if (!$cid) {      if (!$cid) {
  unless ($cid=$env{'request.course.id'}) {   unless ($cid=$env{'request.course.id'}) {
     return 'not_in_class';      return 'not_in_class';
Line 8682  sub modifystudent { Line 11334  sub modifystudent {
     $uid = undef if (!$forceid);      $uid = undef if (!$forceid);
     $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,      $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;      return $reply;
 }  }
   
 sub modify_student_enrollment {  sub modify_student_enrollment {
     my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,      my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,
         $locktype,$cid,$selfenroll,$context,$credits) = @_;          $locktype,$cid,$selfenroll,$context,$credits,$instsec,$othdomby,$requester) = @_;
     my ($cdom,$cnum,$chome);      my ($cdom,$cnum,$chome);
     if (!$cid) {      if (!$cid) {
  unless ($cid=$env{'request.course.id'}) {   unless ($cid=$env{'request.course.id'}) {
Line 8732  sub modify_student_enrollment { Line 11384  sub modify_student_enrollment {
     }      }
     my $fullname = &format_name($first,$middle,$last,$gene,'lastname');      my $fullname = &format_name($first,$middle,$last,$gene,'lastname');
     my $user = "$uname:$udom";      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',      my $reply=cput('classlist',
    {$user =>      {$user => 
  join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits) },   join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits,$instsec) },
    $cdom,$cnum);     $cdom,$cnum);
     if (($reply eq 'ok') || ($reply eq 'delayed')) {      if (($reply eq 'ok') || ($reply eq 'delayed')) {
         &devalidate_getsection_cache($udom,$uname,$cid);          &devalidate_getsection_cache($udom,$uname,$cid);
Line 8749  sub modify_student_enrollment { Line 11401  sub modify_student_enrollment {
  $uurl.='/'.$usec;   $uurl.='/'.$usec;
     }      }
     my $result = &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,      my $result = &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,
                              $selfenroll,$context);                               $selfenroll,$context,$othdomby,$requester);
     if ($result ne 'ok') {      if ($result ne 'ok') {
         if ($old_entry{$user} ne '') {          if ($old_entry{$user} ne '') {
             $reply = &cput('classlist',\%old_entry,$cdom,$cnum);              $reply = &cput('classlist',\%old_entry,$cdom,$cnum);
Line 8802  sub writecoursepref { Line 11454  sub writecoursepref {
   
 sub createcourse {  sub createcourse {
     my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,      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);      $url=&declutter($url);
     my $cid='';      my $cid='';
     if ($context eq 'requestcourses') {      if ($context eq 'requestcourses') {
         my $can_create = 0;          my $can_create = 0;
         my ($ownername,$ownerdom) = split(':',$course_owner);          my ($ownername,$ownerdom) = split(':',$course_owner);
         if ($udom eq $ownerdom) {          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)) {                                    $context)) {
                 $can_create = 1;                  $can_create = 1;
             }              }
Line 8861  sub createcourse { Line 11518  sub createcourse {
         }          }
     }      }
     my %host_servers =      my %host_servers =
         &Apache::lonnet::get_servers($udom,'library');          &get_servers($udom,'library');
     unless ($host_servers{$course_server}) {      unless ($host_servers{$course_server}) {
         return 'error: invalid home server for course: '.$course_server;          return 'error: invalid home server for course: '.$course_server;
     }      }
Line 8959  sub is_course { Line 11616  sub is_course {
     my ($cdom, $cnum) = scalar(@_) == 1 ?       my ($cdom, $cnum) = scalar(@_) == 1 ? 
          ($_[0] =~ /^($match_domain)_($match_courseid)$/)  :  @_;           ($_[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;      return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum;
 }  }
   
Line 8981  sub store_userdata { Line 11651  sub store_userdata {
             if (($uhome eq '') || ($uhome eq 'no_host')) {              if (($uhome eq '') || ($uhome eq 'no_host')) {
                 $result = 'error: no_host';                  $result = 'error: no_host';
             } else {              } else {
                 $storehash->{'ip'} = $ENV{'REMOTE_ADDR'};                  $storehash->{'ip'} = &get_requestor_ip();
                 $storehash->{'host'} = $perlvar{'lonHostID'};                  $storehash->{'host'} = $perlvar{'lonHostID'};
   
                 my $namevalue='';                  my $namevalue='';
Line 9007  sub store_userdata { Line 11677  sub store_userdata {
 # ---------------------------------------------------------- Assign Custom Role  # ---------------------------------------------------------- Assign Custom Role
   
 sub assigncustomrole {  sub assigncustomrole {
     my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag,$selfenroll,$context)=@_;      my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag,
           $selfenroll,$context,$othdomby,$requester)=@_;
     return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,      return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
                        $end,$start,$deleteflag,$selfenroll,$context);                         $end,$start,$deleteflag,$selfenroll,$context,$othdomby,
                          $requester);
 }  }
   
 # ----------------------------------------------------------------- Revoke Role  # ----------------------------------------------------------------- Revoke Role
Line 9100  sub save_selected_files { Line 11772  sub save_selected_files {
     my ($user, $path, @files) = @_;      my ($user, $path, @files) = @_;
     my $filename = $user."savedfiles";      my $filename = $user."savedfiles";
     my @other_files = &files_not_in_path($user, $path);      my @other_files = &files_not_in_path($user, $path);
     open (OUT, '>'.$tmpdir.$filename);      open (OUT,'>',LONCAPA::tempdir().$filename);
     foreach my $file (@files) {      foreach my $file (@files) {
         print (OUT $env{'form.currentpath'}.$file."\n");          print (OUT $env{'form.currentpath'}.$file."\n");
     }      }
Line 9114  sub save_selected_files { Line 11786  sub save_selected_files {
 sub clear_selected_files {  sub clear_selected_files {
     my ($user) = @_;      my ($user) = @_;
     my $filename = $user."savedfiles";      my $filename = $user."savedfiles";
     open (OUT, '>'.LONCAPA::tempdir().$filename);      open (OUT,'>',LONCAPA::tempdir().$filename);
     print (OUT undef);      print (OUT undef);
     close (OUT);      close (OUT);
     return ("ok");          return ("ok");    
Line 9124  sub files_in_path { Line 11796  sub files_in_path {
     my ($user, $path) = @_;      my ($user, $path) = @_;
     my $filename = $user."savedfiles";      my $filename = $user."savedfiles";
     my %return_files;      my %return_files;
     open (IN, '<'.LONCAPA::tempdir().$filename);      open (IN,'<',LONCAPA::tempdir().$filename);
     while (my $line_in = <IN>) {      while (my $line_in = <IN>) {
         chomp ($line_in);          chomp ($line_in);
         my @paths_and_file = split (m!/!, $line_in);          my @paths_and_file = split (m!/!, $line_in);
Line 9146  sub files_not_in_path { Line 11818  sub files_not_in_path {
     my $filename = $user."savedfiles";      my $filename = $user."savedfiles";
     my @return_files;      my @return_files;
     my $path_part;      my $path_part;
     open(IN, '<'.LONCAPA::.$filename);      open(IN, '<',LONCAPA::tempdir().$filename);
     while (my $line = <IN>) {      while (my $line = <IN>) {
         #ok, I know it's clunky, but I want it to work          #ok, I know it's clunky, but I want it to work
         my @paths_and_file = split(m|/|, $line);          my @paths_and_file = split(m|/|, $line);
Line 9343  sub modify_access_controls { Line 12015  sub modify_access_controls {
     my $tries = 0;      my $tries = 0;
     my $gotlock = &newput('file_permissions',$lockhash,$domain,$user);      my $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
         
     while (($gotlock ne 'ok') && $tries <3) {      while (($gotlock ne 'ok') && $tries < 10) {
         $tries ++;          $tries ++;
         sleep 1;          sleep(0.1);
         $gotlock = &newput('file_permissions',$lockhash,$domain,$user);          $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
     }      }
     if ($gotlock eq 'ok') {      if ($gotlock eq 'ok') {
Line 9721  sub dirlist { Line 12393  sub dirlist {
             foreach my $user (sort(keys(%allusers))) {              foreach my $user (sort(keys(%allusers))) {
                 push(@alluserslist,$user.'&user');                  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 {          } else {
             return ([],'missing username');              return ([],'missing username');
         }          }
Line 9794  sub stat_file { Line 12483  sub stat_file {
     return ();      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  # -------------------------------------------------------- Value of a Condition
   
 # gets the value of a specific preevaluated condition  # gets the value of a specific preevaluated condition
Line 9938  sub get_userresdata { Line 12794  sub get_userresdata {
     }      }
     #error 2 occurs when the .db doesn't exist      #error 2 occurs when the .db doesn't exist
     if ($tmp!~/error: 2 /) {      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 /) {      } elsif ($tmp=~/error: 2 /) {
  #&EXT_cache_set($udom,$uname);   #&EXT_cache_set($udom,$uname);
  &do_cache_new('userres',$hashid,undef,600);   &do_cache_new('userres',$hashid,undef,600);
Line 9955  sub get_userresdata { Line 12813  sub get_userresdata {
 #  Parameters:  #  Parameters:
 #     $name      - Course/user name.  #     $name      - Course/user name.
 #     $domain    - Name of the domain the user/course is registered on.  #     $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.  #     @which     - Array of names of resources desired.
 #  Returns:  #  Returns:
 #     The value of the first reasource in @which that is found in the  #     The value of the first reasource in @which that is found in the
Line 9965  sub get_userresdata { Line 12830  sub get_userresdata {
 #     'user', an undefined  reference is returned.  #     'user', an undefined  reference is returned.
 #     If none of the resources are found, an undef is returned  #     If none of the resources are found, an undef is returned
 sub resdata {  sub resdata {
     my ($name,$domain,$type,@which)=@_;      my ($name,$domain,$type,$mapp,$recursed,$recurseup,$courseid,
           $modifier,$what,@which)=@_;
     my $result;      my $result;
     if ($type eq 'course') {      if ($type eq 'course') {
  $result=&get_courseresdata($name,$domain);   $result=&get_courseresdata($name,$domain);
Line 9974  sub resdata { Line 12840  sub resdata {
     }      }
     if (!ref($result)) { return $result; }          if (!ref($result)) { return $result; }    
     foreach my $item (@which) {      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 [$result->{$item->[0]},$item->[1]];
  }   }
     }      }
     return undef;      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 get_ltitools_id {
       my ($context,$cdom,$cnum,$title) = @_;
       my ($lockhash,$tries,$gotlock,$id,$error);
   
       # get lock on ltitools db
       $lockhash = {
                      lock => $env{'user.name'}.
                              ':'.$env{'user.domain'},
                   };
       $tries = 0;
       if ($context eq 'domain') {
           $gotlock = &newput_dom('ltitools',$lockhash,$cdom);
       } else {
           $gotlock = &newput('ltitools',$lockhash,$cdom,$cnum);
       }
       while (($gotlock ne 'ok') && ($tries<10)) {
           $tries ++;
           sleep (0.1);
           if ($context eq 'domain') {
               $gotlock = &newput_dom('ltitools',$lockhash,$cdom);
           } else {
               $gotlock = &newput('ltitools',$lockhash,$cdom,$cnum);
           }
       }
       if ($gotlock eq 'ok') {
           my %currids;
           if ($context eq 'domain') {
               %currids = &dump_dom('ltitools',$cdom);
           } else {
               %currids = &dump('ltitools',$cdom,$cnum);
           }
           if ($currids{'lock'}) {
               delete($currids{'lock'});
               if (keys(%currids)) {
                   my @curr = sort { $a <=> $b } keys(%currids);
                   if ($curr[-1] =~ /^\d+$/) {
                       $id = 1 + $curr[-1];
                   }
               } else {
                   $id = 1;
               }
               if ($id) {
                   if ($context eq 'domain') {
                       unless (&newput_dom('ltitools',{ $id => $title },$cdom) eq 'ok') {
                           $error = 'nostore';
                       }
                   } else {
                       unless (&newput('ltitools',{ $id => $title },$cdom,$cnum) eq 'ok') {
                           $error = 'nostore';
                       }
                   }
               } else {
                   $error = 'nonumber';
               }
           }
           my $dellockoutcome;
           if ($context eq 'domain') {
               $dellockoutcome = &del_dom('ltitools',['lock'],$cdom);
           } else {
               $dellockoutcome = &del('ltitools',['lock'],$cdom,$cnum);
           }
       } else {
           $error = 'nolock';
       }
       return ($id,$error);
   }
   
   sub count_supptools {
       my ($cnum,$cdom,$ignorecache,$reload)=@_;
     my $hashid=$cnum.':'.$cdom;      my $hashid=$cnum.':'.$cdom;
     my ($suppcount,$cached);      my ($numexttools,$cached);
     unless ($ignorecache) {      unless ($ignorecache) {
         ($suppcount,$cached) = &is_cached_new('suppcount',$hashid);          ($numexttools,$cached) = &is_cached_new('supptools',$hashid);
     }      }
     unless (defined($cached)) {      unless (defined($cached)) {
         my $chome=&homeserver($cnum,$cdom);          my $chome=&homeserver($cnum,$cdom);
           $numexttools = 0;
         unless ($chome eq 'no_host') {          unless ($chome eq 'no_host') {
             ($suppcount,my $errors) = (0,0);              my ($supplemental) = &Apache::loncommon::get_supplemental($cnum,$cdom,$reload);
             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'}})) {
                           if ($key =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) {
                               $numexttools ++;
                           }
                       }
                   }
               }
           }
           &do_cache_new('supptools',$hashid,$numexttools,600);
       }
       return $numexttools;
   }
   
   sub has_unhidden_suppfiles {
       my ($cnum,$cdom,$ignorecache,$possdel)=@_;
       my $hashid=$cnum.':'.$cdom;
       my ($showsupp,$cached);
       unless ($ignorecache) {
           ($showsupp,$cached) = &is_cached_new('showsupp',$hashid);
       }
       unless (defined($cached)) {
           my $chome=&homeserver($cnum,$cdom);
           unless ($chome eq 'no_host') {
               my ($supplemental) = &Apache::loncommon::get_supplemental($cnum,$cdom,$ignorecache,$possdel);
               if (ref($supplemental) eq 'HASH') {
                   if ((ref($supplemental->{'ids'}) eq 'HASH') && (ref($supplemental->{'hidden'}) eq 'HASH')) {
                       foreach my $key (keys(%{$supplemental->{'ids'}})) {
                           next if ($key =~ /\.sequence$/);
                           if (ref($supplemental->{'ids'}->{$key}) eq 'ARRAY') {
                               foreach my $id (@{$supplemental->{'ids'}->{$key}}) {
                                   unless ($supplemental->{'hidden'}->{$id}) {
                                       $showsupp = 1;
                                       last;
                                   }
                               }
                           }
                           last if ($showsupp);
                       }
                   }
               }
         }          }
         &do_cache_new('suppcount',$hashid,$suppcount,600);          &do_cache_new('showsupp',$hashid,$showsupp,600);
     }      }
     return $suppcount;      return $showsupp;
 }  }
   
 #  #
 # EXT resource caching routines  # 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 {  sub clear_EXT_cache_status {
     &delenv('cache.EXT.');      &delenv('cache.EXT.');
 }  }
Line 10029  sub EXT_cache_set { Line 13138  sub EXT_cache_set {
 # --------------------------------------------------------- Value of a Variable  # --------------------------------------------------------- Value of a Variable
 sub EXT {  sub EXT {
   
     my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid)=@_;      my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid,$recurseupref)=@_;
     unless ($varname) { return ''; }      unless ($varname) { return ''; }
     #get real user name/domain, courseid and symb      #get real user name/domain, courseid and symb
     my $courseid;      my $courseid;
Line 10061  sub EXT { Line 13170  sub EXT {
     if ( (defined($Apache::lonhomework::parsing_a_problem)      if ( (defined($Apache::lonhomework::parsing_a_problem)
   || defined($Apache::lonhomework::parsing_a_task))    || defined($Apache::lonhomework::parsing_a_task))
  &&   &&
  ($symbparm eq &symbread()) ) {   ($symbparm eq &symbread()) ) {
  # if we are in the middle of processing the resource the   # if we are in the middle of processing the resource the
  # get the value we are planning on committing   # get the value we are planning on committing
                 if (defined($Apache::lonhomework::results{$qualifierrest})) {                  if (defined($Apache::lonhomework::results{$qualifierrest})) {
Line 10182  sub EXT { Line 13291  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)) {          if (($courseid eq '') && ($cid)) {
             $courseid = $cid;              $courseid = $cid;
         }          }
Line 10194  sub EXT { Line 13307  sub EXT {
   
 # ----------------------------------------------------- Cascading lookup scheme  # ----------------------------------------------------- Cascading lookup scheme
     my $symbp=$symbparm;      my $symbp=$symbparm;
     my $mapp=&deversion((&decode_symb($symbp))[0]);      $mapp=&deversion((&decode_symb($symbp))[0]);
   
     my $symbparm=$symbp.'.'.$spacequalifierrest;      my $symbparm=$symbp.'.'.$spacequalifierrest;
               my $recurseparm=$mapp.'___(rec).'.$spacequalifierrest;
     my $mapparm=$mapp.'___(all).'.$spacequalifierrest;      my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
   
     if (($env{'user.name'} eq $uname) &&      if (($env{'user.name'} eq $uname) &&
  ($env{'user.domain'} eq $udom)) {   ($env{'user.domain'} eq $udom)) {
  $section=$env{'request.course.sec'};   $section=$env{'request.course.sec'};
Line 10215  sub EXT { Line 13327  sub EXT {
   
     my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;      my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
     my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;      my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;
               my $secleveli=$courseid.'.['.$section.'].'.$recurseparm;
     my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;      my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;
   
     $courselevel=$courseid.'.'.$spacequalifierrest;      $courselevel=$courseid.'.'.$spacequalifierrest;
     my $courselevelr=$courseid.'.'.$symbparm;      my $courselevelr=$courseid.'.'.$symbparm;
               $courseleveli=$courseid.'.'.$recurseparm;
     $courselevelm=$courseid.'.'.$mapparm;      $courselevelm=$courseid.'.'.$mapparm;
   
 # ----------------------------------------------------------- first, check user  # ----------------------------------------------------------- first, check user
   
     my $userreply=&resdata($uname,$udom,'user',      my $userreply=&resdata($uname,$udom,'user',$mapp,\$recursed,
                                      \@recurseup,$courseid,'.',$spacequalifierrest, 
        ([$courselevelr,'resource'],         ([$courselevelr,'resource'],
  [$courselevelm,'map'     ],   [$courselevelm,'map'     ],
                                           [$courseleveli,'map'     ],
  [$courselevel, 'course'  ]));   [$courselevel, 'course'  ]));
     if (defined($userreply)) { return &get_reply($userreply); }      if (defined($userreply)) { return &get_reply($userreply); }
   
Line 10233  sub EXT { Line 13349  sub EXT {
             my $coursereply;              my $coursereply;
             if (@groups > 0) {              if (@groups > 0) {
                 $coursereply = &check_group_parms($courseid,\@groups,$symbparm,                  $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'},      $coursereply=&resdata($env{'course.'.$courseid.'.num'},
   $env{'course.'.$courseid.'.domain'},    $env{'course.'.$courseid.'.domain'},
   'course',    'course',$mapp,\$recursed,\@recurseup,
                                     $courseid,'.['.$section.'].',$spacequalifierrest,
   ([$seclevelr,   'resource'],    ([$seclevelr,   'resource'],
    [$seclevelm,   'map'     ],     [$seclevelm,   'map'     ],
                                      [$secleveli,   'map'     ],
    [$seclevel,    'course'  ],     [$seclevel,    'course'  ],
    [$courselevelr,'resource']));     [$courselevelr,'resource']));
     if (defined($coursereply)) { return &get_reply($coursereply); }      if (defined($coursereply)) { return &get_reply($coursereply); }
Line 10258  sub EXT { Line 13377  sub EXT {
     if ($thisparm) { return &get_reply([$thisparm,'resource']); }      if ($thisparm) { return &get_reply([$thisparm,'resource']); }
  }   }
 # ------------------------------------------ fourth, look in resource metadata  # ------------------------------------------ fourth, look in resource metadata
    
  $spacequalifierrest=~s/\./\_/;          my $what = $spacequalifierrest;
    $what=~s/\./\_/;
  my $filename;   my $filename;
  if (!$symbparm) { $symbparm=&symbread(); }   if (!$symbparm) { $symbparm=&symbread(); }
  if ($symbparm) {   if ($symbparm) {
Line 10267  sub EXT { Line 13387  sub EXT {
  } else {   } else {
     $filename=$env{'request.filename'};      $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']); }   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']); }   if (defined($metadata)) { return &get_reply([$metadata,'resource']); }
   
 # ---------------------------------------------- fourth, look in rest of course  # ----------------------------------------------- fifth, look in rest of course
  if ($symbparm && defined($courseid) &&    if ($symbparm && defined($courseid) && 
     $courseid eq $env{'request.course.id'}) {      $courseid eq $env{'request.course.id'}) {
     my $coursereply=&resdata($env{'course.'.$courseid.'.num'},      my $coursereply=&resdata($env{'course.'.$courseid.'.num'},
      $env{'course.'.$courseid.'.domain'},       $env{'course.'.$courseid.'.domain'},
      'course',       'course',$mapp,\$recursed,\@recurseup,
                                        $courseid,'.',$spacequalifierrest,
      ([$courselevelm,'map'   ],       ([$courselevelm,'map'   ],
                                         [$courseleveli,'map'   ],
       [$courselevel, 'course']));        [$courselevel, 'course']));
     if (defined($coursereply)) { return &get_reply($coursereply); }      if (defined($coursereply)) { return &get_reply($coursereply); }
  }   }
Line 10293  sub EXT { Line 13419  sub EXT {
     if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); }      if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); }
  }   }
  if ($recurse) { return undef; }   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']); }   if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); }
 # ---------------------------------------------------- Any other user namespace  # ---------------------------------------------------- Any other user namespace
     } elsif ($realm eq 'environment') {      } elsif ($realm eq 'environment') {
Line 10318  sub EXT { Line 13444  sub EXT {
  if ($space eq 'name') {   if ($space eq 'name') {
     return $ENV{'SERVER_NAME'};      return $ENV{'SERVER_NAME'};
         }          }
       } elsif ($realm eq 'client') {
           if ($space eq 'remote_addr') {
               return &get_requestor_ip();
           }
     }      }
     return '';      return '';
 }  }
Line 10335  sub get_reply { Line 13465  sub get_reply {
 }  }
   
 sub check_group_parms {  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}) {      foreach my $group (@{$groups}) {
           my @groupitems = ();
         foreach my $level (@levels) {          foreach my $level (@levels) {
              my $item = $courseid.'.['.$group.'].'.$level->[0];               my $item = $courseid.'.['.$group.'].'.$level->[0];
              push(@groupitems,[$item,$level->[1]]);               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;      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().  sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().
     my ($courseid,@groups) = @_;      my ($courseid,@groups) = @_;
     @groups = sort(@groups);      @groups = sort(@groups);
Line 10358  sub sort_course_groups { # Sort groups b Line 13517  sub sort_course_groups { # Sort groups b
 }  }
   
 sub packages_tab_default {  sub packages_tab_default {
     my ($uri,$varname)=@_;      my ($uri,$varname,$toolsymb)=@_;
     my (undef,$part,$name)=split(/\./,$varname);      my (undef,$part,$name)=split(/\./,$varname);
   
     my (@extension,@specifics,$do_default);      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);   my ($pack_type,$pack_part)=split(/_/,$package,2);
  if ($pack_type eq 'default') {   if ($pack_type eq 'default') {
     $do_default=1;      $do_default=1;
Line 10429  sub add_prefix_and_part { Line 13588  sub add_prefix_and_part {
   
 my %metaentry;  my %metaentry;
 my %importedpartids;  my %importedpartids;
   my %importedrespids;
 sub metadata {  sub metadata {
     my ($uri,$what,$liburi,$prefix,$depthcount)=@_;      my ($uri,$what,$toolsymb,$liburi,$prefix,$depthcount)=@_;
     $uri=&declutter($uri);      $uri=&declutter($uri);
     # if it is a non metadata possible uri return quickly      # if it is a non metadata possible uri return quickly
     if (($uri eq '') ||       if (($uri eq '') || 
  (($uri =~ m|^/*adm/|) &&    (($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$})) {          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {
  return undef;   return undef;
     }      }
Line 10454  sub metadata { Line 13614  sub metadata {
  my ($result,$cached)=&is_cached_new('meta',$uri);   my ($result,$cached)=&is_cached_new('meta',$uri);
  if (defined($cached)) { return $result->{':'.$what}; }   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  # Imported parts would go here
         my %importedids=();          my @origfiletagids=();
         my @origfileimportpartids=();  
         my $importedparts=0;          my $importedparts=0;
   
   # Imported responseids would go here
           my $importedresponses=0;
 #  #
 # Is this a recursive call for a library?  # Is this a recursive call for a library?
 #  #
Line 10553  sub metadata { Line 13774  sub metadata {
                         my $dir=$filename;                          my $dir=$filename;
                         $dir=~s|[^/]*$||;                          $dir=~s|[^/]*$||;
                         $location=&filelocation($dir,$location);                          $location=&filelocation($dir,$location);
                          
                           my $importid=$token->[2]->{'id'};
                         my $importmode=$token->[2]->{'importmode'};                          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)  # Import as part(s)
                            $importedparts=1;                             $importedparts=1;
 # We need to get the original file and the imported file to get the part order correct  # 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  # 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) {                             if ($#impfilepartids>=0) {
 # This problem had parts  # This problem had parts
                                $importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids);                                 $importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids);
Line 10584  sub metadata { Line 13855  sub metadata {
                                $importedpartids{$token->[2]->{'id'}}=$token->[2]->{'id'};                                 $importedpartids{$token->[2]->{'id'}}=$token->[2]->{'id'};
                            }                             }
                         } else {                          } else {
   # Import as problem or as normal import
                               $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
                               unless ($importmode eq 'problem') {
 # Normal import  # 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) {   if ($depthcount<20) {
     my $metadata =       my $metadata = 
  &metadata($uri,'keys', $location,$unikey,   &metadata($uri,'keys',$toolsymb,$location,$unikey,
   $depthcount+1);    $depthcount+1);
     foreach my $meta (split(',',$metadata)) {      foreach my $meta (split(',',$metadata)) {
  $metaentry{':'.$meta}=$metaentry{':'.$meta};   $metaentry{':'.$meta}=$metaentry{':'.$meta};
  $metathesekeys{$meta}=1;   $metathesekeys{$meta}=1;
     }      }
   
                         }                          }
     } else {      } else {
 #  #
Line 10668  sub metadata { Line 13953  sub metadata {
  $dir=~s|[^/]*$||;   $dir=~s|[^/]*$||;
  $location=&filelocation($dir,$location);   $location=&filelocation($dir,$location);
  my $rights_metadata =   my $rights_metadata =
     &metadata($uri,'keys',$location,'_rights',      &metadata($uri,'keys',$toolsymb,$location,'_rights',
       $depthcount+1);        $depthcount+1);
  foreach my $rights (split(',',$rights_metadata)) {   foreach my $rights (split(',',$rights_metadata)) {
     #$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights};      #$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights};
Line 10682  sub metadata { Line 13967  sub metadata {
     grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));      grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));
  $metaentry{':packages'} = join(',',@uniq_packages);   $metaentry{':packages'} = join(',',@uniq_packages);
   
         if ($importedparts) {          if (($importedresponses) || ($importedparts)) {
               if ($importedparts) {
 # We had imported parts and need to rebuild partorder  # 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));   $metaentry{':keys'} = join(',',keys(%metathesekeys));
  &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);   &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  # this is the end of "was not already recently cached
     }      }
     return $metaentry{':'.$what};      return $metaentry{':'.$what};
Line 10857  sub get_reservable_slots { Line 14173  sub get_reservable_slots {
 sub get_course_slots {  sub get_course_slots {
     my ($cnum,$cdom) = @_;      my ($cnum,$cdom) = @_;
     my $hashid=$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 (defined($cached)) {
         if (ref($result) eq 'HASH') {          if (ref($result) eq 'HASH') {
             return %{$result};              return %{$result};
         }          }
     } else {      } else {
         my %slots=&Apache::lonnet::dump('slots',$cdom,$cnum);          my %slots=&dump('slots',$cdom,$cnum);
         my ($tmp) = keys(%slots);          my ($tmp) = keys(%slots);
         if ($tmp !~ /^(con_lost|error|no_such_host)/i) {          if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
             &do_cache_new('allslots',$hashid,\%slots,600);              &do_cache_new('allslots',$hashid,\%slots,600);
Line 10909  sub get_coursechange { Line 14225  sub get_coursechange {
 }  }
   
 sub devalidate_coursechange_cache {  sub devalidate_coursechange_cache {
     my ($cnum,$cdom)=@_;      my ($cdom,$cnum)=@_;
     my $hashid=$cnum.':'.$cdom;      my $hashid=$cdom.'_'.$cnum;
     &devalidate_cache_new('crschange',$hashid);      &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  # ------------------------------------------------- Update symbolic store links
   
 sub symblist {  sub symblist {
Line 10960  sub symbverify { Line 14333  sub symbverify {
   
     if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',      if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
                             &GDBM_READER(),0640)) {                              &GDBM_READER(),0640)) {
         my $noclutter;  
         if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) {          if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) {
             $thisurl =~ s/\?.+$//;              $thisurl =~ s/\?.+$//;
             if ($map =~ m{^uploaded/.+\.page$}) {              if ($map =~ m{^uploaded/.+\.page$}) {
                 $thisurl =~ s{^(/adm/wrapper|)/ext/}{http://};                  $thisurl =~ s{^(/adm/wrapper|)/ext/}{http://};
                 $thisurl =~ s{^\Qhttp://https://\E}{https://};                  $thisurl =~ s{^\Qhttp://https://\E}{https://};
                 $noclutter = 1;  
             }              }
         }          }
         my $ids;          my $ids;
         if ($noclutter) {          if ($map =~ m{^uploaded/.+\.page$}) {
             $ids=$bighash{'ids_'.$thisurl};              $ids=$bighash{'ids_'.&clutter_with_no_wrapper($thisurl)};
         } else {          } else {
             $ids=$bighash{'ids_'.&clutter($thisurl)};              $ids=$bighash{'ids_'.&clutter($thisurl)};
         }          }
Line 11071  sub deversion { Line 14442  sub deversion {
 # ------------------------------------------------------ Return symb list entry  # ------------------------------------------------------ Return symb list entry
   
 sub symbread {  sub symbread {
     my ($thisfn,$donotrecurse)=@_;      my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles,
           $ignoresymbdb,$noenccheck)=@_;
     my $cache_str='request.symbread.cached.'.$thisfn;      my $cache_str='request.symbread.cached.'.$thisfn;
     if (defined($env{$cache_str})) { return $env{$cache_str}; }      if (defined($env{$cache_str})) {
           unless (ref($possibles) eq 'HASH') {
               if ($ignorecachednull) {
                   return $env{$cache_str} unless ($env{$cache_str} eq '');
               } else {
                   return $env{$cache_str};
               }
           }
       }
 # no filename provided? try from environment  # no filename provided? try from environment
     unless ($thisfn) {      unless ($thisfn) {
         if ($env{'request.symb'}) {          if ($env{'request.symb'}) {
     return $env{$cache_str}=&symbclean($env{'request.symb'});              return $env{$cache_str}=&symbclean($env{'request.symb'});
  }   }
  $thisfn=$env{'request.filename'};   $thisfn=$env{'request.filename'};
     }      }
Line 11093  sub symbread { Line 14473  sub symbread {
     my %bighash;      my %bighash;
     my $syval='';      my $syval='';
     if (($env{'request.course.fn'}) && ($thisfn)) {      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  # ---------------------------------------------------------- There was an entry
         if ($syval) {          if ($syval) {
Line 11135  sub symbread { Line 14516  sub symbread {
      my ($mapid,$resid)=split(/\./,$ids);       my ($mapid,$resid)=split(/\./,$ids);
      $syval=&encode_symb($bighash{'map_id_'.$mapid},       $syval=&encode_symb($bighash{'map_id_'.$mapid},
     $resid,$thisfn);      $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  # ------------------------------------------ There is more than one possibility
                      my $realpossible=0;                       my $realpossible=0;
                      foreach my $id (@possibilities) {                       foreach my $id (@possibilities) {
  my $file=$bighash{'src_'.$id};   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=''; }       if ($realpossible!=1) { $syval=''; }
Line 11154  sub symbread { Line 14574  sub symbread {
                      $syval='';                       $syval='';
                  }                   }
       }        }
               untie(%bighash)                untie(%bighash);
            }             }
         }          }
         if ($syval) {          if ($syval) {
Line 11677  sub repcopy_userfile { Line 15097  sub repcopy_userfile {
     }      }
 # now the path exists for sure  # now the path exists for sure
 # get a user agent  # get a user agent
     my $ua=new LWP::UserAgent;  
     my $transferfile=$file.'.in.transfer';      my $transferfile=$file.'.in.transfer';
 # FIXME: this should flock  # FIXME: this should flock
     if (-e $transferfile) { return 'ok'; }      if (-e $transferfile) { return 'ok'; }
     my $request;      my $request;
     $uri=~s/^\///;      $uri=~s/^\///;
     my $homeserver = &homeserver($cnum,$cdom);      my $homeserver = &homeserver($cnum,$cdom);
       my $hostname = &hostname($homeserver);
     my $protocol = $protocol{$homeserver};      my $protocol = $protocol{$homeserver};
     $protocol = 'http' if ($protocol ne 'https');      $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?  # did it work?
     if ($response->is_error()) {      if ($response->is_error()) {
  unlink($transferfile);   unlink($transferfile);
Line 11710  sub tokenwrapper { Line 15130  sub tokenwrapper {
  $file=~s|(\?\.*)*$||;   $file=~s|(\?\.*)*$||;
         &appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}});          &appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}});
         my $homeserver = &homeserver($uname,$udom);          my $homeserver = &homeserver($uname,$udom);
           my $hostname = &hostname($homeserver);
         my $protocol = $protocol{$homeserver};          my $protocol = $protocol{$homeserver};
         $protocol = 'http' if ($protocol ne 'https');          $protocol = 'http' if ($protocol ne 'https');
         return $protocol.'://'.&hostname($homeserver).'/'.$uri.          return $protocol.'://'.$hostname.'/'.$uri.
                (($uri=~/\?/)?'&':'?').'token='.$token.                 (($uri=~/\?/)?'&':'?').'token='.$token.
                                '&tokenissued='.$perlvar{'lonHostID'};                                 '&tokenissued='.$perlvar{'lonHostID'};
     } else {      } else {
Line 11728  sub getuploaded { Line 15149  sub getuploaded {
     my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;      my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
     $uri=~s/^\///;      $uri=~s/^\///;
     my $homeserver = &homeserver($cnum,$cdom);      my $homeserver = &homeserver($cnum,$cdom);
       my $hostname = &hostname($homeserver);
     my $protocol = $protocol{$homeserver};      my $protocol = $protocol{$homeserver};
     $protocol = 'http' if ($protocol ne 'https');      $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 $request=new HTTP::Request($reqtype,$uri);
     my $response=$ua->request($request);      my $response=&LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,'',0,1);
     $$rtncode = $response->code;      $$rtncode = $response->code;
     if (! $response->is_success()) {      if (! $response->is_success()) {
  return 'failed';   return 'failed';
Line 11750  sub readfile { Line 15171  sub readfile {
     my $file = shift;      my $file = shift;
     if ( (! -e $file ) || ($file eq '') ) { return -1; };      if ( (! -e $file ) || ($file eq '') ) { return -1; };
     my $fh;      my $fh;
     open($fh,"<$file");      open($fh,"<",$file);
     my $a='';      my $a='';
     while (my $line = <$fh>) { $a .= $line; }      while (my $line = <$fh>) { $a .= $line; }
     return $a;      return $a;
Line 11863  sub machine_ids { Line 15284  sub machine_ids {
   
 sub additional_machine_domains {  sub additional_machine_domains {
     my @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;      return @domains;
 }  }
Line 11884  sub default_login_domain { Line 15310  sub default_login_domain {
     return $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  # ------------------------------------------------------------- Declutters URLs
   
 sub declutter {  sub declutter {
Line 11934  sub clutter { Line 15646  sub clutter {
 # &logthis("Got a blank emb style");  # &logthis("Got a blank emb style");
     }      }
  }   }
       } elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/ext\.tool$}) {
           $thisfn='/adm/wrapper'.$thisfn;
     }      }
     return $thisfn;      return $thisfn;
 }  }
Line 11999  sub get_dns { Line 15713  sub get_dns {
     my ($url,$func,$ignore_cache,$nocache,$hashref) = @_;      my ($url,$func,$ignore_cache,$nocache,$hashref) = @_;
     if (!$ignore_cache) {      if (!$ignore_cache) {
  my ($content,$cached)=   my ($content,$cached)=
     &Apache::lonnet::is_cached_new('dns',$url);      &is_cached_new('dns',$url);
  if ($cached) {   if ($cached) {
     &$func($content,$hashref);      &$func($content,$hashref);
     return;      return;
Line 12007  sub get_dns { Line 15721  sub get_dns {
     }      }
   
     my %alldns;      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) {      while (%alldns) {
  my ($dns) = sort { $b cmp $a } keys(%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);
  }              }
  &$func(\@content,$hashref);              if ($url eq '/adm/dns/loncapaCRL') {
  return;                  $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);
           }
     }      }
     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;      return;
 }  }
   
Line 12045  sub get_dns { Line 15792  sub get_dns {
 sub parse_dns_checksums_tab {  sub parse_dns_checksums_tab {
     my ($lines,$hashref) = @_;      my ($lines,$hashref) = @_;
     my $lonhost = $perlvar{'lonHostID'};      my $lonhost = $perlvar{'lonHostID'};
     my $machine_dom = &Apache::lonnet::host_domain($lonhost);      my $machine_dom = &host_domain($lonhost);
     my $loncaparev = &get_server_loncaparev($machine_dom);      my $loncaparev = &get_server_loncaparev($machine_dom);
     my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0];      my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0];
     my $webconfdir = '/etc/httpd/conf';      my $webconfdir = '/etc/httpd/conf';
Line 12089  sub parse_dns_checksums_tab { Line 15836  sub parse_dns_checksums_tab {
   
 sub fetch_dns_checksums {  sub fetch_dns_checksums {
     my %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 $loncaparev = &get_server_loncaparev($machine_dom,$perlvar{'lonHostID'});
     my ($release,$timestamp) = split(/\-/,$loncaparev);      my ($release,$timestamp) = split(/\-/,$loncaparev);
     &get_dns("/adm/dns/checksums/$release",\&parse_dns_checksums_tab,1,1,      &get_dns("/adm/dns/checksums/$release",\&parse_dns_checksums_tab,1,1,
Line 12097  sub fetch_dns_checksums { Line 15844  sub fetch_dns_checksums {
     return \%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  # ------------------------------------------------------------ Read domain file
 {  {
     my $loaded;      my $loaded;
Line 12125  sub fetch_dns_checksums { Line 15963  sub fetch_dns_checksums {
     }      }
   
     sub load_domain_tab {      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;   my $fh;
  if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) {   if (open($fh,"<",$perlvar{'lonTabDir'}.'/domain.tab')) {
     my @lines = <$fh>;      my @lines = <$fh>;
     &parse_domain_tab(\@lines);      &parse_domain_tab(\@lines);
  }   }
Line 12180  sub fetch_dns_checksums { Line 16018  sub fetch_dns_checksums {
     my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline);      my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline);
     $name=~s/\s//g;      $name=~s/\s//g;
     if ($id && $domain && $role && $name) {      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;   $hostname{$id}=$name;
  push(@{$name_to_host{$name}}, $id);  
  $hostdom{$id}=$domain;   $hostdom{$id}=$domain;
  if ($role eq 'library') { $libserv{$id}=$name; }   if ($role eq 'library') { $libserv{$id}=$name; }
                 if (defined($protocol)) {                  if (defined($protocol)) {
Line 12204  sub fetch_dns_checksums { Line 16057  sub fetch_dns_checksums {
  &purge_remembered();   &purge_remembered();
  &reset_domain_info();   &reset_domain_info();
  &reset_hosts_ip_info();   &reset_hosts_ip_info();
           undef(%internetdom);
  undef(%name_to_host);   undef(%name_to_host);
  undef(%hostname);   undef(%hostname);
  undef(%hostdom);   undef(%hostdom);
Line 12212  sub fetch_dns_checksums { Line 16066  sub fetch_dns_checksums {
     }      }
   
     sub load_hosts_tab {      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>;   my @config = <$config>;
  &parse_hosts_tab(\@config);   &parse_hosts_tab(\@config);
  close($config);   close($config);
Line 12235  sub fetch_dns_checksums { Line 16089  sub fetch_dns_checksums {
     }      }
   
     sub all_names {      sub all_names {
  &load_hosts_tab() if (!$loaded);          my ($ignore_cache,$nocache) = @_;
    &load_hosts_tab($ignore_cache,$nocache) if (!$loaded);
   
  return %name_to_host;   return %name_to_host;
     }      }
Line 12245  sub fetch_dns_checksums { Line 16100  sub fetch_dns_checksums {
         return %hostdom;          return %hostdom;
     }      }
   
       sub all_host_intdom {
           &load_hosts_tab() if (!$loaded);
           return %internetdom;
       }
   
     sub is_library {      sub is_library {
  &load_hosts_tab() if (!$loaded);   &load_hosts_tab() if (!$loaded);
   
Line 12357  sub fetch_dns_checksums { Line 16217  sub fetch_dns_checksums {
     }      }
           
     sub get_iphost {      sub get_iphost {
  my ($ignore_cache) = @_;   my ($ignore_cache,$nocache) = @_;
   
  if (!$ignore_cache) {   if (!$ignore_cache) {
     if (%iphost) {      if (%iphost) {
  return %iphost;   return %iphost;
     }      }
     my ($ip_info,$cached)=      my ($ip_info,$cached)=
  &Apache::lonnet::is_cached_new('iphost','iphost');   &is_cached_new('iphost','iphost');
     if ($cached) {      if ($cached) {
  %iphost      = %{$ip_info->[0]};   %iphost      = %{$ip_info->[0]};
  %name_to_ip  = %{$ip_info->[1]};   %name_to_ip  = %{$ip_info->[1]};
Line 12376  sub fetch_dns_checksums { Line 16236  sub fetch_dns_checksums {
  # get yesterday's info for fallback   # get yesterday's info for fallback
  my %old_name_to_ip;   my %old_name_to_ip;
  my ($ip_info,$cached)=   my ($ip_info,$cached)=
     &Apache::lonnet::is_cached_new('iphost','iphost');      &is_cached_new('iphost','iphost');
  if ($cached) {   if ($cached) {
     %old_name_to_ip = %{$ip_info->[1]};      %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)) {   foreach my $name (keys(%name_to_host)) {
     my $ip;      my $ip;
     if (!exists($name_to_ip{$name})) {      if (!exists($name_to_ip{$name})) {
Line 12406  sub fetch_dns_checksums { Line 16266  sub fetch_dns_checksums {
     }      }
     push(@{$iphost{$ip}},@{$name_to_host{$name}});      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',
       48*60*60);            [\%iphost,\%name_to_ip,\%lonid_to_ip],
             48*60*60);
           }
   
  return %iphost;   return %iphost;
     }      }
Line 12441  sub fetch_dns_checksums { Line 16303  sub fetch_dns_checksums {
         my ($lonid) = @_;          my ($lonid) = @_;
         return if ($lonid eq '');          return if ($lonid eq '');
         my ($idnref,$cached)=          my ($idnref,$cached)=
             &Apache::lonnet::is_cached_new('internetnames',$lonid);              &is_cached_new('internetnames',$lonid);
         if ($cached) {          if ($cached) {
             return $idnref;              return $idnref;
         }          }
Line 12477  sub all_loncaparevs { Line 16339  sub all_loncaparevs {
 {  {
     sub load_loncaparevs {       sub load_loncaparevs { 
         if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") {          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>) {                  while (my $configline=<$config>) {
                     chomp($configline);                      chomp($configline);
                     my ($hostid,$loncaparev)=split(/:/,$configline);                      my ($hostid,$loncaparev)=split(/:/,$configline);
Line 12493  sub all_loncaparevs { Line 16355  sub all_loncaparevs {
 {  {
     sub load_serverhomeIDs {      sub load_serverhomeIDs {
         if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") {          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>) {                  while (my $configline=<$config>) {
                     chomp($configline);                      chomp($configline);
                     my ($name,$id)=split(/:/,$configline);                      my ($name,$id)=split(/:/,$configline);
Line 12518  BEGIN { Line 16380  BEGIN {
   
 # ------------------------------------------------------ Read spare server file  # ------------------------------------------------------ Read spare server file
 {  {
     open(my $config,"<$perlvar{'lonTabDir'}/spare.tab");      open(my $config,"<","$perlvar{'lonTabDir'}/spare.tab");
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
        chomp($configline);         chomp($configline);
Line 12532  BEGIN { Line 16394  BEGIN {
 }  }
 # ------------------------------------------------------------ Read permissions  # ------------------------------------------------------------ Read permissions
 {  {
     open(my $config,"<$perlvar{'lonTabDir'}/roles.tab");      open(my $config,"<","$perlvar{'lonTabDir'}/roles.tab");
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
  chomp($configline);   chomp($configline);
Line 12546  BEGIN { Line 16408  BEGIN {
   
 # -------------------------------------------- Read plain texts for permissions  # -------------------------------------------- Read plain texts for permissions
 {  {
     open(my $config,"<$perlvar{'lonTabDir'}/rolesplain.tab");      open(my $config,"<","$perlvar{'lonTabDir'}/rolesplain.tab");
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
  chomp($configline);   chomp($configline);
Line 12566  BEGIN { Line 16428  BEGIN {
   
 # ---------------------------------------------------------- Read package table  # ---------------------------------------------------------- Read package table
 {  {
     open(my $config,"<$perlvar{'lonTabDir'}/packages.tab");      open(my $config,"<","$perlvar{'lonTabDir'}/packages.tab");
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
  if ($configline !~ /\S/ || $configline=~/^#/) { next; }   if ($configline !~ /\S/ || $configline=~/^#/) { next; }
Line 12599  BEGIN { Line 16461  BEGIN {
                 my $item = $token->[1];                  my $item = $token->[1];
                 my $name = $token->[2]{'name'};                  my $name = $token->[2]{'name'};
                 my $value = $token->[2]{'value'};                  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();                      my $release = $parser->get_text();
                     $release =~ s/(^\s*|\s*$ )//gx;                      $release =~ s/(^\s*|\s*$ )//gx;
                     $needsrelease{$item.':'.$name.':'.$value} = $release;                      $needsrelease{$item.':'.$name.':'.$value} = $release;
Line 12612  BEGIN { Line 16482  BEGIN {
 # ---------------------------------------------------------- Read managers table  # ---------------------------------------------------------- Read managers table
 {  {
     if (-e "$perlvar{'lonTabDir'}/managers.tab") {      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>) {              while (my $configline=<$config>) {
                 chomp($configline);                  chomp($configline);
                 next if ($configline =~ /^\#/);                  next if ($configline =~ /^\#/);
Line 12631  BEGIN { Line 16501  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'],  $memcache=new Cache::Memcached({'servers'           => ['127.0.0.1:11211'],
  'compress_threshold'=> 20_000,   'compress_threshold'=> 20_000,
          });           });
Line 12872  the answer, and also caches if there is Line 16752  the answer, and also caches if there is
   
 =item *  =item *
 X<idget()>  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 *  =item *
 X<idrget()>  X<idrget()>
Line 12884  usernames (returns hash: name=>id,name=> Line 16766  usernames (returns hash: name=>id,name=>
   
 =item *  =item *
 X<idput()>  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 *  =item *
 X<rolesinit()>  X<rolesinit()>
Line 12925  escaped strings of the action recorded i Line 16827  escaped strings of the action recorded i
   
 =item *  =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   F: full access
  U,I,K: authentication modes (cxx only)   U,I,K: authentication modes (cxx only)
  '': forbidden   '': forbidden
  1: user needs to choose course   1: user needs to choose course
  2: browse allowed   2: browse allowed
  A: passphrase authentication needed   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 *  =item *
   
Line 12950  in which case the null string is returne Line 16869  in which case the null string is returne
   
 =item *  =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 *  =item *
   
Line 13156  Inputs: Line 17076  Inputs:
   
 =item $credits, number of credits student will earn from this class  =item $credits, number of credits student will earn from this class
   
   =item $instsec, institutional course section code for student
   
 =back  =back
   
   
Line 13221  data base, returning a hash that is keye Line 17143  data base, returning a hash that is keye
 values that are the resource value.  I believe that the timestamps and  values that are the resource value.  I believe that the timestamps and
 versions are also returned.  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   
 10 minutes.  
   
 =back  =back
   
 =head2 Course Modification  =head2 Course Modification
Line 13259  Returns: Line 17177  Returns:
   
 =back  =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  =head2 Resource Subroutines
   
 =over 4  =over 4
Line 13310  condval($condidx) : value of condition i Line 17310  condval($condidx) : value of condition i
   
 =item *  =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  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  '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 *  =item *
   
Line 13325  will be stored for query Line 17331  will be stored for query
   
 =item *  =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  returns the data handle
   
 =item *  =item *
Line 13611  requestcourses: ability to request cours Line 17630  requestcourses: ability to request cours
 =over  =over
   
 =item  =item
 official, unofficial, community, textbook  official, unofficial, community, textbook, placement
   
 =back  =back
   
Line 13633  for course's uploaded content. Line 17652  for course's uploaded content.
   
 =item  =item
 canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota,   canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota, 
 communityquota, textbookquota  communityquota, textbookquota, placementquota
   
 =back  =back
   
Line 13937  userspace, probably shouldn't be called Line 17956  userspace, probably shouldn't be called
   formname: same as for userfileupload()    formname: same as for userfileupload()
   fname: filename (including subdirectories) for the file    fname: filename (including subdirectories) for the file
   parser: if 'parse', will parse (html) file to extract references to objects, links etc.    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    allfiles: reference to hash used to store objects found by parser
   codebase: reference to hash used for codebases of java 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    thumbwidth: width (pixels) of thumbnail to be created for uploaded image
Removed from v.1.1276  
changed lines
  Added in v.1.1524

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