[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.1172.2.31 and 1.1172.2.134

version 1.1172.2.31, 2013/08/08 02:09:10 version 1.1172.2.134, 2021/01/04 03:55:50
Line 74  use strict; Line 74  use strict;
 use LWP::UserAgent();  use LWP::UserAgent();
 use HTTP::Date;  use HTTP::Date;
 use Image::Magick;  use Image::Magick;
   use CGI::Cookie;
   
 use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $apache  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 89  use GDBM_File; Line 90  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;
Line 98  use LONCAPA qw(:DEFAULT :match); Line 99  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::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 123  our @EXPORT = qw(%env); Line 125  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 142  our @EXPORT = qw(%env); Line 145  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 154  sub logthis { Line 157  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 167  sub logperm { Line 170  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 261  sub get_server_loncaparev { Line 264  sub get_server_loncaparev {
                 if ($caller eq 'loncron') {                  if ($caller eq 'loncron') {
                     my $ua=new LWP::UserAgent;                      my $ua=new LWP::UserAgent;
                     $ua->timeout(4);                      $ua->timeout(4);
                       my $hostname = &hostname($lonhost);
                     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=$ua->request($request);
                     unless ($response->is_error()) {                      unless ($response->is_error()) {
Line 352  sub get_remote_globals { Line 356  sub get_remote_globals {
 }  }
   
 sub remote_devalidate_cache {  sub remote_devalidate_cache {
     my ($lonhost,$name,$id) = @_;      my ($lonhost,$cachekeys) = @_;
     my $response = &reply('devalidatecache:'.&escape($name).':'.&escape($id),$lonhost);      my $items;
     return $response;      return unless (ref($cachekeys) eq 'ARRAY');
       my $cachestr = join('&',@{$cachekeys});
       return &reply('devalidatecache:'.&escape($cachestr),$lonhost);
 }  }
   
 # -------------------------------------------------- Non-critical communication  # -------------------------------------------------- Non-critical communication
Line 368  sub subreply { Line 374  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 386  sub subreply { Line 392  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 405  sub reply { Line 411  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')) {
                   (undef,undef,my @rest) = split(/:/,$cmd);
                   if (($subcmd eq 'auth') || ($subcmd eq 'putdom')) {
                       splice(@rest,2,1,'Hidden');
                   } elsif ($subcmd eq 'passwd') {
                       splice(@rest,2,2,('Hidden','Hidden'));
                   } elsif (($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') ||
                            ($subcmd eq 'autoexportgrades')) {
                       splice(@rest,3,1,'Hidden');
                   }
                   $logged = join(':',('encrypt:'.$subcmd,@rest));
               }
           }
           &logthis("<font color=\"blue\">WARNING:".
                    " $logged to $server returned $answer</font>");
     }      }
     return $answer;      return $answer;
 }  }
Line 415  sub reply { Line 439  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 434  sub reconlonc { Line 458  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) {
Line 462  sub critical { Line 486  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 474  sub critical { Line 498  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 599  sub transfer_profile_to_env { Line 623  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) = @_;      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 628  sub check_for_valid_session { Line 682  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 (($r->user() eq '') && ($apache >= 2.4)) {      if (ref($userhashref) eq 'HASH') {
         if ($disk_env{'user.domain'} eq $r->dir_config('lonDefDomain')) {          $userhashref->{'name'} = $disk_env{'user.name'};
             $r->user($disk_env{'user.name'});          $userhashref->{'domain'} = $disk_env{'user.domain'};
         } else {  
             $r->user($disk_env{'user.name'}.':'.$disk_env{'user.domain'});  
         }  
     }      }
       untie(%disk_env);
   
     return $handle;      return $handle;
 }  }
Line 662  sub timed_flock { Line 715  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 672  sub appenv { Line 756  sub appenv {
     if (($key =~ /^user\.role/) || ($key =~ /^user\.priv/)) {      if (($key =~ /^user\.role/) || ($key =~ /^user\.priv/)) {
                 $refused = 1;                  $refused = 1;
                 if (ref($roles) eq 'ARRAY') {                  if (ref($roles) eq 'ARRAY') {
                     my ($type,$role) = ($key =~ /^user\.(role|priv)\.([^.]+)\./);                      my ($type,$role) = ($key =~ m{^user\.(role|priv)\.(.+?)\./});
                     if (grep(/^\Q$role\E$/,@{$roles})) {                      if (grep(/^\Q$role\E$/,@{$roles})) {
                         $refused = 0;                          $refused = 0;
                     }                      }
Line 687  sub appenv { Line 771  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 812  sub userload { Line 899  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 845  sub spareserver { Line 933  sub spareserver {
     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 859  sub spareserver { Line 945  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 871  sub spareserver { Line 955  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};
                   }
         $spare_server = $protocol.'://'.$hostname;          $spare_server = $protocol.'://'.$hostname;
             }              }
         }          }
Line 886  sub spareserver { Line 970  sub spareserver {
 }  }
   
 sub compare_server_load {  sub compare_server_load {
     my ($try_server, $spare_server, $lowest_load) = @_;      my ($try_server, $spare_server, $lowest_load, $required) = @_;
   
       if ($required) {
           my ($reqdmajor,$reqdminor) = ($required =~ /^(\d+)\.(\d+)$/);
           my $remoterev = &get_server_loncaparev(undef,$try_server);
           my ($major,$minor) = ($remoterev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
           if (($major eq '' && $minor eq '') ||
               (($reqdmajor > $major) || (($reqdmajor == $major) && ($reqdminor > $minor)))) {
               return ($spare_server,$lowest_load);
           }
       }
   
     my $loadans     = &reply('load',    $try_server);      my $loadans     = &reply('load',    $try_server);
     my $userloadans = &reply('userload',$try_server);      my $userloadans = &reply('userload',$try_server);
Line 934  sub find_existing_session { Line 1028  sub find_existing_session {
     return;      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 947  sub has_user_session { Line 1125  sub has_user_session {
 # --------- determine least loaded server in a user's domain which allows login  # --------- determine least loaded server in a user's domain which allows login
   
 sub choose_server {  sub choose_server {
     my ($udom,$checkloginvia) = @_;      my ($udom,$checkloginvia,$required,$skiploadbal) = @_;
     my %domconfhash = &Apache::loncommon::get_domainconf($udom);      my %domconfhash = &Apache::loncommon::get_domainconf($udom);
     my %servers = &get_servers($udom);      my %servers = &get_servers($udom);
     my $lowest_load = 30000;      my $lowest_load = 30000;
     my ($login_host,$hostname,$portal_path,$isredirect);      my ($login_host,$hostname,$portal_path,$isredirect,$balancers);
       if ($skiploadbal) {
           ($balancers,my $cached)=&is_cached_new('loadbalancing',$udom);
           unless (defined($cached)) {
               my $cachetime = 60*60*24;
               my %domconfig =
                   &Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom);
               if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
                   $balancers = &do_cache_new('loadbalancing',$udom,$domconfig{'loadbalancing'},
                                              $cachetime);
               }
           }
       }
     foreach my $lonhost (keys(%servers)) {      foreach my $lonhost (keys(%servers)) {
         my $loginvia;          my $loginvia;
           if ($skiploadbal) {
               if (ref($balancers) eq 'HASH') {
                   next if (exists($balancers->{$lonhost}));
               }
           }
         if ($checkloginvia) {          if ($checkloginvia) {
             $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};              $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};
             if ($loginvia) {              if ($loginvia) {
                 my ($server,$path) = split(/:/,$loginvia);                  my ($server,$path) = split(/:/,$loginvia);
                 ($login_host, $lowest_load) =                  ($login_host, $lowest_load) =
                     &compare_server_load($server, $login_host, $lowest_load);                      &compare_server_load($server, $login_host, $lowest_load, $required);
                 if ($login_host eq $server) {                  if ($login_host eq $server) {
                     $portal_path = $path;                      $portal_path = $path;
                     $isredirect = 1;                      $isredirect = 1;
                 }                  }
             } else {              } else {
                 ($login_host, $lowest_load) =                  ($login_host, $lowest_load) =
                     &compare_server_load($lonhost, $login_host, $lowest_load);                      &compare_server_load($lonhost, $login_host, $lowest_load, $required);
                 if ($login_host eq $lonhost) {                  if ($login_host eq $lonhost) {
                     $portal_path = '';                      $portal_path = '';
                     $isredirect = '';                       $isredirect = ''; 
Line 974  sub choose_server { Line 1169  sub choose_server {
             }              }
         } else {          } else {
             ($login_host, $lowest_load) =              ($login_host, $lowest_load) =
                 &compare_server_load($lonhost, $login_host, $lowest_load);                  &compare_server_load($lonhost, $login_host, $lowest_load, $required);
         }          }
     }      }
     if ($login_host ne '') {      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 1018  sub changepass { Line 1235  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 1147  sub can_host_session { Line 1367  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') {
     unless (grep(/^\Q$uint_dom\E$/,@intdoms)) {          if ($defdomdefaults{'offloadnow'}{$try_server}) {
         my $serverhomeID = &Apache::lonnet::get_server_homeID($try_server);              $canhost = 0;
         my $serverhomedom = &Apache::lonnet::host_domain($serverhomeID);          }
         my %defdomdefaults = &Apache::lonnet::get_domain_defaults($serverhomedom);      }
         my $remoterev = &Apache::lonnet::get_server_loncaparev(undef,$try_server);      if (($canhost) && ($uint_dom)) {
         $canhost = &can_host_session($udom,$try_server,$remoterev,          my @intdoms;
                                      $remotesessions,          my $internet_names = &get_internet_names($try_server);
                                      $defdomdefaults{'hostedsessions'});          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 1244  sub get_lonbalancer_config { Line 1472  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);
     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 = &Apache::lonnet::domain($udom,'primary');
     my $uintdom = &Apache::lonnet::internet_dom($uprimary_id);      my $uintdom = &Apache::lonnet::internet_dom($uprimary_id);
     my $intdom = &Apache::lonnet::internet_dom($lonhost);      my $intdom = &Apache::lonnet::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 1268  sub check_loadbalancing { Line 1496  sub check_loadbalancing {
             &Apache::lonnet::get_dom('configuration',['loadbalancing'],$dom_in_use);              &Apache::lonnet::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) =
             &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 1321  sub check_loadbalancing { Line 1551  sub check_loadbalancing {
             }              }
         }          }
     } elsif (($homeintdom) && ($udom ne $serverhomedom)) {      } elsif (($homeintdom) && ($udom ne $serverhomedom)) {
         my ($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);                  &Apache::lonnet::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) =
                 &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 1346  sub check_loadbalancing { Line 1578  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 ($domneedscache) {
           &do_cache_new('loadbalancing',$domneedscache,$is_balancer,$cachetime);
     }      }
     if ($is_balancer) {      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 1382  sub check_loadbalancing { Line 1623  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);
 }  }
   
 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);
     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 1414  sub check_balancer_result { Line 1659  sub check_balancer_result {
                     $is_balancer = 1;                      $is_balancer = 1;
                     $currrules = $result->{$key}{'rules'};                      $currrules = $result->{$key}{'rules'};
                     $currtargets = $result->{$key}{'targets'};                      $currtargets = $result->{$key}{'targets'};
                       $setcookie = $result->{$key}{'cookie'};
                     last;                      last;
                 }                  }
             }              }
         }          }
     }      }
     return ($is_balancer,$currtargets,$currrules);      return ($is_balancer,$currtargets,$currrules,$setcookie);
 }  }
   
 sub get_loadbalancer_targets {  sub get_loadbalancer_targets {
Line 1524  sub idget { Line 1770  sub idget {
           
     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/;    $idlist=~tr/A-Z/a-z/; 
  my $reply=&reply("idget:$udom:".$idlist,$tryserver);   my $reply=&reply("idget:$udom:".$idlist,$tryserver);
  my @answer=();   my @answer=();
Line 1534  sub idget { Line 1780  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]);
     }       } 
  }   }
     }       } 
Line 1621  sub dump_dom { Line 1867  sub dump_dom {
   
 sub get_dom {  sub get_dom {
     my ($namespace,$storearr,$udom,$uhome)=@_;      my ($namespace,$storearr,$udom,$uhome)=@_;
       return if ($udom eq 'public');
     my $items='';      my $items='';
     foreach my $item (@$storearr) {      foreach my $item (@$storearr) {
         $items.=&escape($item).'&';          $items.=&escape($item).'&';
Line 1628  sub get_dom { Line 1875  sub get_dom {
     $items=~s/\&$//;      $items=~s/\&$//;
     if (!$udom) {      if (!$udom) {
         $udom=$env{'user.domain'};          $udom=$env{'user.domain'};
           return if ($udom eq 'public');
         if (defined(&domain($udom,'primary'))) {          if (defined(&domain($udom,'primary'))) {
             $uhome=&domain($udom,'primary');              $uhome=&domain($udom,'primary');
         } else {          } else {
Line 1731  sub retrieve_inst_usertypes { Line 1979  sub retrieve_inst_usertypes {
     my %domdefs = &Apache::lonnet::get_domain_defaults($udom);      my %domdefs = &Apache::lonnet::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')) {
         %returnhash = %{$domdefs{'inststatustypes'}};          return ($domdefs{'inststatustypes'},$domdefs{'inststatusorder'});
         @order = @{$domdefs{'inststatusorder'}};  
     } else {      } else {
         if (defined(&domain($udom,'primary'))) {          if (defined(&domain($udom,'primary'))) {
             my $uhome=&domain($udom,'primary');              my $uhome=&domain($udom,'primary');
             my $rep=&reply("inst_usertypes:$udom",$uhome);              my $rep=&reply("inst_usertypes:$udom",$uhome);
             if ($rep =~ /^(con_lost|error|no_such_host|refused)/) {              if ($rep =~ /^(con_lost|error|no_such_host|refused)/) {
                 &logthis("get_dom failed - $rep returned from $uhome in domain: $udom");                  &logthis("retrieve_inst_usertypes failed - $rep returned from $uhome in domain: $udom");
                 return (\%returnhash,\@order);                  return (\%returnhash,\@order);
             }              }
             my ($hashitems,$orderitems) = split(/:/,$rep);               my ($hashitems,$orderitems) = split(/:/,$rep); 
Line 1754  sub retrieve_inst_usertypes { Line 2001  sub retrieve_inst_usertypes {
                 push(@order,&unescape($item));                  push(@order,&unescape($item));
             }              }
         } else {          } else {
             &logthis("get_dom failed - no primary domain server for $udom");              &logthis("retrieve_inst_usertypes failed - no primary domain server for $udom");
         }          }
           return (\%returnhash,\@order);
     }      }
     return (\%returnhash,\@order);  
 }  }
   
 sub is_domainimage {  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)/+[^/]-) {
         if (&domain($1) ne '') {          if (&domain($1) ne '') {
             return '1';              return '1';
         }          }
Line 1777  sub inst_directory_query { Line 2024  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,$subver) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.(\d+)[\w.\-]+\'?$/);
                   if (($major eq '' && $minor eq '') || ($major < 2) ||
                       (($major == 2) && ($minor < 11)) ||
                       (($major == 2) && ($minor == 11) && ($subver < 3))) {
                       return;
                   }
               }
           }
  my $queryid=&reply("querysend:instdirsearch:".   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 1818  sub usersearch { Line 2076  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,$subver) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.(\d+)[\w.\-]+\'?$/);
                       next if (($major eq '' && $minor eq '') || ($major < 2) ||
                                (($major == 2) && ($minor < 11)) ||
                                (($major == 2) && ($minor == 11) && ($subver < 3)));
                   }
               }
             my $host=&hostname($tryserver);              my $host=&hostname($tryserver);
             my $queryid=              my $queryid=
                 &reply("querysend:".&escape($query).':'.                  &reply("querysend:".&escape($query).':'.
Line 1903  sub get_instuser { Line 2170  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 1982  sub inst_userrules { Line 2306  sub inst_userrules {
 # ------------- Get Authentication, Language and User Tools Defaults for Domain  # ------------- Get Authentication, Language and User Tools Defaults for Domain
   
 sub get_domain_defaults {  sub get_domain_defaults {
     my ($domain) = @_;      my ($domain,$ignore_cache) = @_;
       return if (($domain eq '') || ($domain eq 'public'));
     my $cachetime = 60*60*24;      my $cachetime = 60*60*24;
     my ($result,$cached)=&is_cached_new('domdefaults',$domain);      unless ($ignore_cache) {
     if (defined($cached)) {          my ($result,$cached)=&is_cached_new('domdefaults',$domain);
         if (ref($result) eq 'HASH') {          if (defined($cached)) {
             return %{$result};              if (ref($result) eq 'HASH') {
                   return %{$result};
               }
         }          }
     }      }
     my %domdefaults;      my %domdefaults;
Line 1995  sub get_domain_defaults { Line 2322  sub get_domain_defaults {
          &Apache::lonnet::get_dom('configuration',['defaults','quotas',           &Apache::lonnet::get_dom('configuration',['defaults','quotas',
                                   'requestcourses','inststatus',                                    'requestcourses','inststatus',
                                   'coursedefaults','usersessions',                                    'coursedefaults','usersessions',
                                   'requestauthor'],$domain);                                    'requestauthor','selfenrollment',
                                     'coursecategories','autoenroll',
                                     'helpsettings'],$domain);
       my @coursetypes = ('official','unofficial','community','textbook');
     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 2003  sub get_domain_defaults { Line 2333  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{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'};
           $domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'};
           $domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'};
     } 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 2025  sub get_domain_defaults { Line 2358  sub get_domain_defaults {
         }          }
     }      }
     if (ref($domconfig{'requestcourses'}) eq 'HASH') {      if (ref($domconfig{'requestcourses'}) eq 'HASH') {
         foreach my $item ('official','unofficial','community') {          foreach my $item ('official','unofficial','community','textbook') {
             $domdefaults{$item} = $domconfig{'requestcourses'}{$item};              $domdefaults{$item} = $domconfig{'requestcourses'}{$item};
         }          }
     }      }
Line 2033  sub get_domain_defaults { Line 2366  sub get_domain_defaults {
         $domdefaults{'requestauthor'} = $domconfig{'requestauthor'};          $domdefaults{'requestauthor'} = $domconfig{'requestauthor'};
     }      }
     if (ref($domconfig{'inststatus'}) eq 'HASH') {      if (ref($domconfig{'inststatus'}) eq 'HASH') {
         foreach my $item ('inststatustypes','inststatusorder') {          foreach my $item ('inststatustypes','inststatusorder','inststatusguest') {
             $domdefaults{$item} = $domconfig{'inststatus'}{$item};              $domdefaults{$item} = $domconfig{'inststatus'}{$item};
         }          }
     }      }
     if (ref($domconfig{'coursedefaults'}) eq 'HASH') {      if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
         if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {          $domdefaults{'usejsme'} = $domconfig{'coursedefaults'}{'usejsme'};
             $domdefaults{'officialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'official'};          $domdefaults{'uselcmath'} = $domconfig{'coursedefaults'}{'uselcmath'};
             $domdefaults{'unofficialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'unofficial'};          if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') {
         }              $domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'};
         if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {          }
             $domdefaults{'officialquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'official'};          foreach my $type (@coursetypes) {
             $domdefaults{'unofficialquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'unofficial'};              if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {
             $domdefaults{'communityquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'community'};                  unless ($type eq 'community') {
                       $domdefaults{$type.'credits'} = $domconfig{'coursedefaults'}{'coursecredits'}{$type};
                   }
               }
               if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {
                   $domdefaults{$type.'quota'} = $domconfig{'coursedefaults'}{'uploadquota'}{$type};
               }
               if ($domdefaults{'postsubmit'} eq 'on') {
                   if (ref($domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}) eq 'HASH') {
                       $domdefaults{$type.'postsubtimeout'} =
                           $domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}{$type};
                   }
               }
           }
           if (ref($domconfig{'coursedefaults'}{'canclone'}) eq 'HASH') {
               if (ref($domconfig{'coursedefaults'}{'canclone'}{'instcode'}) eq 'ARRAY') {
                   my @clonecodes = @{$domconfig{'coursedefaults'}{'canclone'}{'instcode'}};
                   if (@clonecodes) {
                       $domdefaults{'canclone'} = join('+',@clonecodes);
                   }
               }
           } elsif ($domconfig{'coursedefaults'}{'canclone'}) {
               $domdefaults{'canclone'}=$domconfig{'coursedefaults'}{'canclone'};
           }
           if ($domconfig{'coursedefaults'}{'texengine'}) {
               $domdefaults{'texengine'} = $domconfig{'coursedefaults'}{'texengine'};
         }          }
     }      }
     if (ref($domconfig{'usersessions'}) eq 'HASH') {      if (ref($domconfig{'usersessions'}) eq 'HASH') {
Line 2055  sub get_domain_defaults { Line 2413  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{'selfenrollment'}) eq 'HASH') {
           if (ref($domconfig{'selfenrollment'}{'admin'}) eq 'HASH') {
               my @settings = ('types','registered','enroll_dates','access_dates','section',
                               'approval','limit');
               foreach my $type (@coursetypes) {
                   if (ref($domconfig{'selfenrollment'}{'admin'}{$type}) eq 'HASH') {
                       my @mgrdc = ();
                       foreach my $item (@settings) {
                           if ($domconfig{'selfenrollment'}{'admin'}{$type}{$item} eq '0') {
                               push(@mgrdc,$item);
                           }
                       }
                       if (@mgrdc) {
                           $domdefaults{$type.'selfenrolladmdc'} = join(',',@mgrdc);
                       }
                   }
               }
           }
           if (ref($domconfig{'selfenrollment'}{'default'}) eq 'HASH') {
               foreach my $type (@coursetypes) {
                   if (ref($domconfig{'selfenrollment'}{'default'}{$type}) eq 'HASH') {
                       foreach my $item (keys(%{$domconfig{'selfenrollment'}{'default'}{$type}})) {
                           $domdefaults{$type.'selfenroll'.$item} = $domconfig{'selfenrollment'}{'default'}{$type}{$item};
                       }
                   }
               }
           }
       }
       if (ref($domconfig{'coursecategories'}) eq 'HASH') {
           $domdefaults{'catauth'} = 'std';
           $domdefaults{'catunauth'} = 'std';
           if ($domconfig{'coursecategories'}{'auth'}) {
               $domdefaults{'catauth'} = $domconfig{'coursecategories'}{'auth'};
           }
           if ($domconfig{'coursecategories'}{'unauth'}) {
               $domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'};
           }
       }
       if (ref($domconfig{'autoenroll'}) eq 'HASH') {
           $domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'};
       }
       if (ref($domconfig{'helpsettings'}) eq 'HASH') {
           $domdefaults{'submitbugs'} = $domconfig{'helpsettings'}{'submitbugs'};
           if (ref($domconfig{'helpsettings'}{'adhoc'}) eq 'HASH') {
               $domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'};
           }
     }      }
     &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 = {};
           }
           &Apache::lonnet::do_cache_new('cats',$dom,$cats,3600);
       }
       return $cats;
   }
   
   sub get_dom_instcats {
       my ($dom) = @_;
       return unless (&domain($dom));
       my ($instcats,$cached)=&is_cached_new('instcats',$dom);
       unless (defined($cached)) {
           my (%coursecodes,%codes,@codetitles,%cat_titles,%cat_order);
           my $totcodes = &retrieve_instcodes(\%coursecodes,$dom);
           if ($totcodes > 0) {
               my $caller = 'global';
               if (&auto_instcode_format($caller,$dom,\%coursecodes,\%codes,
                                         \@codetitles,\%cat_titles,\%cat_order) eq 'ok') {
                   $instcats = {
                                   codes => \%codes,
                                   codetitles => \@codetitles,
                                   cat_titles => \%cat_titles,
                                   cat_order => \%cat_order,
                               };
                   &do_cache_new('instcats',$dom,$instcats,3600);
               }
           }
       }
       return $instcats;
   }
   
   sub retrieve_instcodes {
       my ($coursecodes,$dom) = @_;
       my $totcodes;
       my %courses = &courseiddump($dom,'.',1,'.','.','.',undef,undef,'Course');
       foreach my $course (keys(%courses)) {
           if (ref($courses{$course}) eq 'HASH') {
               if ($courses{$course}{'inst_code'} ne '') {
                   $$coursecodes{$course} = $courses{$course}{'inst_code'};
                   $totcodes ++;
               }
           }
       }
       return $totcodes;
   }
   
   # --------------------------------------------- Get domain config for passwords
   
   sub get_passwdconf {
       my ($dom) = @_;
       my (%passwdconf,$gotconf,$lookup);
       my ($result,$cached)=&is_cached_new('passwdconf',$dom);
       if (defined($cached)) {
           if (ref($result) eq 'HASH') {
               %passwdconf = %{$result};
               $gotconf = 1;
           }
       }
       unless ($gotconf) {
           my %domconfig = &get_dom('configuration',['passwords'],$dom);
           if (ref($domconfig{'passwords'}) eq 'HASH') {
               %passwdconf = %{$domconfig{'passwords'}};
           }
           my $cachetime = 24*60*60;
           &do_cache_new('passwdconf',$dom,\%passwdconf,$cachetime);
       }
       return %passwdconf;
   }
   
 # --------------------------------------------------- Assign a key to a student  # --------------------------------------------------- Assign a key to a student
   
 sub assign_access_key {  sub assign_access_key {
Line 2296  sub make_key { Line 2786  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) for 
     if (exists($remembered{$id})) {                                       # keys in %remembered hash, which persists for
  if ($debug) { &Apache::lonnet::logthis("Early return $id of $remembered{$id} "); }                                       # duration of request (no restriction on key length).
  $accessed{$id}=[&gettimeofday()];      if (exists($remembered{$remembered_id})) {
    if ($debug) { &Apache::lonnet::logthis("Early return $remembered_id of $remembered{$remembered_id} "); }
    $accessed{$remembered_id}=[&gettimeofday()];
  $hits++;   $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 2320  sub is_cached_new { Line 2814  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 2342  sub do_cache_new { Line 2837  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 2590  sub repcopy { Line 3085  sub repcopy {
     }      }
 }  }
   
   # ------------------------------------------------- Unsubscribe from a resource
   
   sub unsubscribe {
       my ($fname) = @_;
       my $answer;
       if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return $answer; }
       $fname=~s/[\n\r]//g;
       my $author=$fname;
       $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
       my ($udom,$uname)=split(/\//,$author);
       my $home=homeserver($uname,$udom);
       if ($home eq 'no_host') {
           $answer = 'no_host';
       } elsif (grep { $_ eq $home } &current_machine_ids()) {
           $answer = 'home';
       } else {
           $answer = reply("unsub:$fname",$home);
       }
       return $answer;
   }
   
 # ------------------------------------------------ Get server side include body  # ------------------------------------------------ Get server side include body
 sub ssi_body {  sub ssi_body {
     my ($filelink,%form)=@_;      my ($filelink,%form)=@_;
Line 2639  sub absolute_url { Line 3155  sub absolute_url {
 sub ssi {  sub ssi {
   
     my ($fn,%form)=@_;      my ($fn,%form)=@_;
     my $ua=new LWP::UserAgent;      my ($request,$response);
     my $request;  
   
     $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',&absolute_url().$fn);
       $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys(%form)));        $request->content(join('&',map {
               my $name = escape($_);
               "$name=" . ( ref($form{$_}) eq 'ARRAY'
               ? join("&$name=", map {escape($_) } @{$form{$_}})
               : &escape($form{$_}) );
           } keys(%form)));
     } else {      } else {
       $request=new HTTP::Request('GET',&absolute_url().$fn);        $request=new HTTP::Request('GET',&absolute_url().$fn);
     }      }
   
     $request->header(Cookie => $ENV{'HTTP_COOKIE'});      $request->header(Cookie => $ENV{'HTTP_COOKIE'});
     my $response= $ua->request($request);  
       if (($env{'request.course.id'}) &&
           ($form{'grade_courseid'} eq $env{'request.course.id'}) &&
           ($form{'grade_username'} ne '') && ($form{'grade_domain'} ne '') &&
           ($form{'grade_symb'} ne '') &&
           (&Apache::lonnet::allowed('mgr',$env{'request.course.id'}.
                                    ($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:'')))) {
           if (LWP::UserAgent->VERSION >= 5.834) {
               my $ua=new LWP::UserAgent;
               $ua->local_address('127.0.0.1');
               $response = $ua->request($request);
           } else {
               {
                   require LWP::Protocol::http;
                   local @LWP::Protocol::http::EXTRA_SOCK_OPTS = (LocalAddr => '127.0.0.1');
                   my $ua=new LWP::UserAgent;
                   $response = $ua->request($request);
                   @LWP::Protocol::http::EXTRA_SOCK_OPTS = ();
               }
           }
       } else {
           my $ua=new LWP::UserAgent;
           $response = $ua->request($request);
       }
     if (wantarray) {      if (wantarray) {
  return ($response->content, $response);   return ($response->content, $response);
     } else {      } else {
Line 2672  sub externalssi { Line 3215  sub externalssi {
     }      }
 }  }
   
   # If the local copy of a replicated resource is outdated, trigger a
   # connection from the homeserver to flush the delayed queue. If no update
   # happens, remove local copies of outdated resource (and corresponding
   # metadata file).
   
   sub remove_stale_resfile {
       my ($url) = @_;
       my $removed;
       if ($url=~m{^/res/($match_domain)/($match_username)/}) {
           my $audom = $1;
           my $auname = $2;
           unless (($url =~ /\.\d+\.\w+$/) || ($url =~ m{^/res/lib/templates/})) {
               my $homeserver = &homeserver($auname,$audom);
               unless (($homeserver eq 'no_host') ||
                       (grep { $_ eq $homeserver } &current_machine_ids())) {
                   my $fname = &filelocation('',$url);
                   if (-e $fname) {
                       my $hostname = &hostname($homeserver);
                       if ($hostname) {
                           my $protocol = $protocol{$homeserver};
                           $protocol = 'http' if ($protocol ne 'https');
                           my $uri = $protocol.'://'.$hostname.'/raw/'.&declutter($url);
                           my $ua=new LWP::UserAgent;
                           $ua->timeout(5);
                           my $request=new HTTP::Request('HEAD',$uri);
                           my $response=$ua->request($request);
                           if ($response->is_success()) {
                               my $remmodtime = &HTTP::Date::str2time( $response->header('Last-modified') );
                               my $locmodtime = (stat($fname))[9];
                               if ($locmodtime < $remmodtime) {
                                   my $stale;
                                   my $answer = &reply('pong',$homeserver);
                                   if ($answer eq $homeserver.':'.$perlvar{'lonHostID'}) {
                                       sleep(0.2);
                                       $locmodtime = (stat($fname))[9];
                                       if ($locmodtime < $remmodtime) {
                                           my $posstransfer = $fname.'.in.transfer';
                                           if ((-e $posstransfer) && ($remmodtime < (stat($posstransfer))[9])) {
                                               $removed = 1;
                                           } else {
                                               $stale = 1;
                                           }
                                       } else {
                                           $removed = 1;
                                       }
                                   } else {
                                       $stale = 1;
                                   }
                                   if ($stale) {
                                       if (unlink($fname)) {
                                           if ($uri!~/\.meta$/) {
                                               if (-e $fname.'.meta') {
                                                   unlink($fname.'.meta');
                                               }
                                           }
                                           my $unsubresult = &unsubscribe($fname);
                                           unless ($unsubresult eq 'ok') {
                                               &logthis("no unsub of $fname from $homeserver, reason: $unsubresult");
                                           }
                                           $removed = 1;
                                       }
                                   }
                               }
                           }
                       }
                   }
               }
           }
       }
       return $removed;
   }
   
 # -------------------------------- Allow a /uploaded/ URI to be vouched for  # -------------------------------- Allow a /uploaded/ URI to be vouched for
   
 sub allowuploaded {  sub allowuploaded {
Line 2810  sub can_edit_resource { Line 3425  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/viewclasslist$}) {                  } elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
                     $incourse = 1;                      $incourse = 1;
                     if ($env{'form.forceedit'}) {                      if ($env{'form.forceedit'}) {
Line 2827  sub can_edit_resource { Line 3454  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 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 3000  sub process_coursefile { Line 3627  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 3058  sub store_edited_file { Line 3685  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 3083  sub clean_filename { Line 3710  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
Line 3090  sub clean_filename { Line 3720  sub clean_filename {
     $fname=~s/\.(\d+)(?=\.)/_$1/g;      $fname=~s/\.(\d+)(?=\.)/_$1/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 3132  sub resizeImage { Line 3763  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 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  #        $desuname - username for permanent storage of uploaded file
Line 3161  sub userfileupload { Line 3795  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 3174  sub userfileupload { Line 3816  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 3209  sub userfileupload { Line 3851  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 3284  sub finishuserfileupload { Line 3926  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 3328  sub finishuserfileupload { Line 3970  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 3337  sub finishuserfileupload { Line 3979  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 $thumbsize = $thumbwidth.'x'.$thumbheight;          my $thumbsize = $thumbwidth.'x'.$thumbheight;
         system("convert -sample $thumbsize $input $output");          my @args = ('convert','-sample',$thumbsize,$input,$output);
           system({$args[0]} @args);
         if (-e $filepath.'/'.'tn-'.$file) {          if (-e $filepath.'/'.'tn-'.$file) {
             $fetchthumb  = 1;               $fetchthumb  = 1; 
         }          }
Line 3490  sub extract_embedded_items { Line 4136  sub extract_embedded_items {
                     }                      }
                 }                  }
     }      }
               if (lc($tagname) eq 'iframe') {
                   my $src = $attr->{'src'} ;
                   if (($src ne '') && ($src !~ m{^(/|https?://)})) {
                       &add_filetype($allfiles,$src,'src');
                   } elsif ($src =~ m{^/}) {
                       if ($env{'request.course.id'}) {
                           my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
                           my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
                           my $url = &hreflocation('',$fullpath);
                           if ($url =~ m{^/uploaded/$cdom/$cnum/docs/(\w+/\d+)/}) {
                               my $relpath = $1;
                               if ($src =~ m{^/uploaded/$cdom/$cnum/docs/\Q$relpath\E/(.+)$}) {
                                   &add_filetype($allfiles,$1,'src');
                               }
                           }
                       }
                   }
               }
             if ($t->[4] =~ m{/>$}) {              if ($t->[4] =~ m{/>$}) {
                 pop(@state);                    pop(@state);
             }              }
  } elsif ($t->[0] eq 'E') {   } elsif ($t->[0] eq 'E') {
     my ($tagname) = ($t->[1]);      my ($tagname) = ($t->[1]);
Line 3558  sub embedded_dependency { Line 4222  sub embedded_dependency {
     return;      return;
 }  }
   
   sub bubblesheet_converter {
       my ($cdom,$fullpath,$config,$format) = @_;
       if ((&domain($cdom) ne '') &&
           ($fullpath =~ m{^\Q$perlvar{'lonDocRoot'}/userfiles/$cdom/\E$match_courseid/scantron_orig}) &&
           (-e $fullpath) && (ref($config) eq 'HASH') && ($format ne '')) {
           my (%csvcols,%csvoptions);
           if (ref($config->{'fields'}) eq 'HASH') {
               %csvcols = %{$config->{'fields'}};
           }
           if (ref($config->{'options'}) eq 'HASH') {
               %csvoptions = %{$config->{'options'}};
           }
           my %csvbynum = reverse(%csvcols);
           my %scantronconf = &get_scantron_config($format,$cdom);
           if (keys(%scantronconf)) {
               my %bynum = (
                             $scantronconf{CODEstart} => 'CODEstart',
                             $scantronconf{IDstart}   => 'IDstart',
                             $scantronconf{PaperID}   => 'PaperID',
                             $scantronconf{FirstName} => 'FirstName',
                             $scantronconf{LastName}  => 'LastName',
                             $scantronconf{Qstart}    => 'Qstart',
                           );
               my @ordered;
               foreach my $item (sort { $a <=> $b } keys(%bynum)) {
                   push(@ordered,$bynum{$item});
               }
               my %mapstart = (
                                 CODEstart => 'CODE',
                                 IDstart   => 'ID',
                                 PaperID   => 'PaperID',
                                 FirstName => 'FirstName',
                                 LastName  => 'LastName',
                                 Qstart    => 'FirstQuestion',
                              );
               my %maplength = (
                                 CODEstart => 'CODElength',
                                 IDstart   => 'IDlength',
                                 PaperID   => 'PaperIDlength',
                                 FirstName => 'FirstNamelength',
                                 LastName  => 'LastNamelength',
               );
               if (open(my $fh,'<',$fullpath)) {
                   my $output;
                   my %lettdig = &letter_to_digits();
                   my %diglett = reverse(%lettdig);
                   my $numletts = scalar(keys(%lettdig));
                   my $num = 0;
                   while (my $line=<$fh>) {
                       $num ++;
                       next if (($num == 1) && ($csvoptions{'hdr'} == 1));
                       $line =~ s{[\r\n]+$}{};
                       my %found;
                       my @values = split(/,/,$line);
                       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);
               }
           }
       }
       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 3708  sub flushcourselogs { Line 4612  sub flushcourselogs {
         }          }
     }      }
 #  #
 # Reverse lookup of domain roles (dc, ad, li, sc, au)  # Reverse lookup of domain roles (dc, ad, li, sc, dh, da, au)
 #  #
     my %domrolebuffer = ();      my %domrolebuffer = ();
     foreach my $entry (keys(%domainrolehash)) {      foreach my $entry (keys(%domainrolehash)) {
Line 3723  sub flushcourselogs { Line 4627  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 3775  sub courseacclog { Line 4688  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 3846  sub userrolelog { Line 4763  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 4073  sub get_my_roles { Line 4990  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 = &Apache::lonnet::get('environment',['internal.coursecode'],
                                        $cdom,$cnum);
       }
       if (($info{'internal.coursecode'} ne '') && ($checkreg)) {
           my $user = $env{'user.name'}.':'.$env{'user.domain'};
           my %rosterhash = &get('classlist',[$user],$cdom,$cnum);
           if ($rosterhash{$user} ne '') {
               my $type = (split(/:/,$rosterhash{$user}))[5];
               return ([],{}) if ($type eq 'auto');
           }
       }
       if (($cdom ne '') && ($cnum ne ''))  {
           if (($env{"user.role.dh./$cdom/"}) || ($env{"user.role.da./$cdom/"})) {
               my $then=$env{'user.login.time'};
               my $update=$env{'user.update.time'};
               if (!$update) {
                   $update = $then;
               }
               my @liveroles;
               foreach my $role ('dh','da') {
                   if ($env{"user.role.$role./$cdom/"}) {
                       my ($tstart,$tend)=split(/\./,$env{"user.role.$role./$cdom/"});
                       my $limit = $update;
                       if ($env{'request.role'} eq "$role./$cdom/") {
                           $limit = $then;
                       }
                       my $activerole = 1;
                       if ($tstart && $tstart>$limit) { $activerole = 0; }
                       if ($tend   && $tend  <$limit) { $activerole = 0; }
                       if ($activerole) {
                           push(@liveroles,$role);
                       }
                   }
               }
               if (@liveroles) {
                   if (&homeserver($cnum,$cdom) ne 'no_host') {
                       my ($accessref,$accessinfo,%access_in_dom);
                       ($roles_by_num,$description,$accessref,$accessinfo) = &get_all_adhocroles($cdom);
                       if (ref($roles_by_num) eq 'ARRAY') {
                           if (@{$roles_by_num}) {
                               my %settings;
                               if ($env{'request.course.id'} eq $cid) {
                                   foreach my $envkey (keys(%env)) {
                                       if ($envkey =~ /^\Qcourse.$cid.\E(internal\.adhoc.+)$/) {
                                           $settings{$1} = $env{$envkey};
                                       }
                                   }
                               } else {
                                   %settings = &dump('environment',$cdom,$cnum,'internal\.adhoc');
                               }
                               my %setincrs;
                               if ($settings{'internal.adhocaccess'}) {
                                   map { $setincrs{$_} = 1; } split(/,/,$settings{'internal.adhocaccess'});
                               }
                               my @statuses;
                               if ($env{'environment.inststatus'}) {
                                   @statuses = split(/,/,$env{'environment.inststatus'});
                               }
                               my $user = $env{'user.name'}.':'.$env{'user.domain'};
                               if (ref($accessref) eq 'HASH') {
                                   %access_in_dom = %{$accessref};
                               }
                               foreach my $role (@{$roles_by_num}) {
                                   my ($curraccess,@okstatus,@personnel);
                                   if ($setincrs{$role}) {
                                       ($curraccess,my $rest) = split(/=/,$settings{'internal.adhoc.'.$role});
                                       if ($curraccess eq 'status') {
                                           @okstatus = split(/\&/,$rest);
                                       } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) {
                                           @personnel = split(/\&/,$rest);
                                       }
                                   } else {
                                       $curraccess = $access_in_dom{$role};
                                       if (ref($accessinfo) eq 'HASH') {
                                           if ($curraccess eq 'status') {
                                               if (ref($accessinfo->{$role}) eq 'ARRAY') {
                                                   @okstatus = @{$accessinfo->{$role}};
                                               }
                                           } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) {
                                               if (ref($accessinfo->{$role}) eq 'ARRAY') {
                                                   @personnel = @{$accessinfo->{$role}};
                                               }
                                           }
                                       }
                                   }
                                   if ($curraccess eq 'none') {
                                       next;
                                   } elsif ($curraccess eq 'all') {
                                       push(@possroles,$role);
                                   } elsif ($curraccess eq 'dh') {
                                       if (grep(/^dh$/,@liveroles)) {
                                           push(@possroles,$role);
                                       } else {
                                           next;
                                       }
                                   } elsif ($curraccess eq 'da') {
                                       if (grep(/^da$/,@liveroles)) {
                                           push(@possroles,$role);
                                       } else {
                                           next;
                                       }
                                   } elsif ($curraccess eq 'status') {
                                       if (@okstatus) {
                                           if (!@statuses) {
                                               if (grep(/^default$/,@okstatus)) {
                                                   push(@possroles,$role);
                                               }
                                           } else {
                                               foreach my $status (@okstatus) {
                                                   if (grep(/^\Q$status\E$/,@statuses)) {
                                                       push(@possroles,$role);
                                                       last;
                                                   }
                                               }
                                           }
                                       }
                                   } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) {
                                       if (grep(/^\Q$user\E$/,@personnel)) {
                                           if ($curraccess eq 'exc') {
                                               push(@possroles,$role);
                                           }
                                       } elsif ($curraccess eq 'inc') {
                                           push(@possroles,$role);
                                       }
                                   }
                               }
                           }
                       }
                   }
               }
           }
       }
       unless (ref($description) eq 'HASH') {
           if (ref($roles_by_num) eq 'ARRAY') {
               my %desc;
               map { $desc{$_} = $_; } (@{$roles_by_num});
               $description = \%desc;
           } else {
               $description = {};
           }
       }
       return (\@possroles,$description);
   }
   
 # ----------------------------------------------------- Frontpage Announcements  # ----------------------------------------------------- Frontpage Announcements
 #  #
 #  #
Line 4086  sub postannounce { Line 5192  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 4148  sub courseiddump { Line 5254  sub courseiddump {
     my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,      my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
         $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,          $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
         $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,          $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,
         $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner)=@_;          $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner,
           $hasuniquecode,$reqcrsdom,$reqinstcode)=@_;
     my $as_hash = 1;      my $as_hash = 1;
     my %returnhash;      my %returnhash;
     if (!$domfilter) { $domfilter=''; }      if (!$domfilter) { $domfilter=''; }
Line 4171  sub courseiddump { Line 5278  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)));                                  &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 4182  sub courseiddump { Line 5290  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,                               &escape($creationcontext).':'.$domcloner.':'.$hasuniquecode.
                              $tryserver);                               ':'.$reqcrsdom.':'.&escape($reqinstcode),$tryserver);
                 }                  }
   
                 my @pairs=split(/\&/,$rep);                  my @pairs=split(/\&/,$rep);
Line 4311  sub get_domain_roles { Line 5419  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 4322  my $cachedkey=''; Line 5445  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)=@_;
Line 4365  sub set_first_access { Line 5488  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 4378  sub set_first_access { Line 5506  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';
 }  }
 }  }
   
   sub checkout {
       my ($symb,$tuname,$tudom,$tcrsid)=@_;
       my $now=time;
       my $lonhost=$perlvar{'lonHostID'};
       my $ip = &get_requestor_ip();
       my $infostr=&escape(
                    'CHECKOUTTOKEN&'.
                    $tuname.'&'.
                    $tudom.'&'.
                    $tcrsid.'&'.
                    $symb.'&'.
                    $now.'&'.$ip);
       my $token=&reply('tmpput:'.$infostr,$lonhost);
       if ($token=~/^error\:/) {
           &logthis("<font color=\"blue\">WARNING: ".
                   "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
                    "</font>");
           return '';
       }
   
       $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;
       $token=~tr/a-z/A-Z/;
   
       my %infohash=('resource.0.outtoken' => $token,
                     'resource.0.checkouttime' => $now,
                     'resource.0.outremote' => $ip);
   
       unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
          return '';
       } else {
           &logthis("<font color=\"blue\">WARNING: ".
                   "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
                    "</font>");
       }
   
       if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
                            &escape('Checkout '.$infostr.' - '.
                                                    $token)) ne 'ok') {
           return '';
       } else {
           &logthis("<font color=\"blue\">WARNING: ".
                   "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
                    "</font>");
       }
       return $token;
   }
   
   # ------------------------------------------------------------ Check in an item
   
   sub checkin {
       my $token=shift;
       my $now=time;
       my ($ta,$tb,$lonhost)=split(/\*/,$token);
       $lonhost=~tr/A-Z/a-z/;
       my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb;
       $dtoken=~s/\W/\_/g;
       my $ip = &get_requestor_ip();
       my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
                    split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
   
       unless (($tuname) && ($tudom)) {
           &logthis('Check in '.$token.' ('.$dtoken.') failed');
           return '';
       }
   
       unless (&allowed('mgr',$tcrsid)) {
           &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.
                    $env{'user.name'}.' - '.$env{'user.domain'});
           return '';
       }
   
       my %infohash=('resource.0.intoken' => $token,
                     'resource.0.checkintime' => $now,
                     'resource.0.inremote' => $ip);
   
       unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
          return '';
       }
   
       if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
                            &escape('Checkin - '.$token)) ne 'ok') {
           return '';
       }
   
       return ($symb,$tuname,$tudom,$tcrsid);
   }
   
 # --------------------------------------------- Set Expire Date for Spreadsheet  # --------------------------------------------- Set Expire Date for Spreadsheet
   
 sub expirespread {  sub expirespread {
Line 4754  sub tmprestore { Line 5976  sub tmprestore {
 # ----------------------------------------------------------------------- Store  # ----------------------------------------------------------------------- Store
   
 sub store {  sub store {
     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;      my ($storehash,$symb,$namespace,$domain,$stuname,$laststore) = @_;
     my $home='';      my $home='';
   
     if ($stuname) { $home=&homeserver($stuname,$domain); }      if ($stuname) { $home=&homeserver($stuname,$domain); }
Line 4784  sub store { Line 6006  sub store {
     }      }
     $namevalue=~s/\&$//;      $namevalue=~s/\&$//;
     &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);      &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);
     return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");      return reply("store:$domain:$stuname:$namespace:$symb:$namevalue:$laststore","$home");
 }  }
   
 # -------------------------------------------------------------- Critical Store  # -------------------------------------------------------------- Critical Store
   
 sub cstore {  sub cstore {
     my ($storehash,$symb,$namespace,$domain,$stuname) = @_;      my ($storehash,$symb,$namespace,$domain,$stuname,$laststore) = @_;
     my $home='';      my $home='';
   
     if ($stuname) { $home=&homeserver($stuname,$domain); }      if ($stuname) { $home=&homeserver($stuname,$domain); }
Line 4821  sub cstore { Line 6043  sub cstore {
     $namevalue=~s/\&$//;      $namevalue=~s/\&$//;
     &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);      &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);
     return critical      return critical
                 ("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");                  ("store:$domain:$stuname:$namespace:$symb:$namevalue:$laststore","$home");
 }  }
   
 # --------------------------------------------------------------------- Restore  # --------------------------------------------------------------------- Restore
Line 5001  sub privileged { Line 6223  sub privileged {
         my %rolesdump = &dump("roles", $domain, $username) or return 0;          my %rolesdump = &dump("roles", $domain, $username) or return 0;
         my $now = time;          my $now = time;
   
         for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys %rolesdump}) {          for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys(%rolesdump)}) {
             my ($trole, $tend, $tstart) = split(/_/, $role);              my ($trole, $tend, $tstart) = split(/_/, $role);
             if (grep(/^\Q$trole\E$/,@{$roles})) {              if (grep(/^\Q$trole\E$/,@{$roles})) {
                 return 1 unless ($tend && $tend < $now)                  return 1 unless ($tend && $tend < $now)
Line 5090  sub rolesinit { Line 6312  sub rolesinit {
     my %allroles=();      my %allroles=();
     my %allgroups=();      my %allgroups=();
   
     for my $area (grep { ! /^rolesdef_/ } keys %rolesdump) {      for my $area (grep { ! /^rolesdef_/ } keys(%rolesdump)) {
         my $role = $rolesdump{$area};          my $role = $rolesdump{$area};
         $area =~ s/\_\w\w$//;          $area =~ s/\_\w\w$//;
   
Line 5163  sub rolesinit { Line 6385  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);
 }  }
Line 5182  sub set_arearole { Line 6405  sub set_arearole {
 sub custom_roleprivs {  sub custom_roleprivs {
     my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;      my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;
     my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);      my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
     my $homsvr=homeserver($rauthor,$rdomain);      my $homsvr = &homeserver($rauthor,$rdomain);
     if (&hostname($homsvr) ne '') {      if (&hostname($homsvr) ne '') {
         my ($rdummy,$roledef)=          my ($rdummy,$roledef)=
             &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);              &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);
Line 5201  sub custom_roleprivs { Line 6424  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 5209  sub custom_roleprivs { Line 6436  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 5243  sub set_userprivs { Line 6512  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 5290  sub set_userprivs { Line 6560  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 5298  sub set_userprivs { Line 6569  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 {
     my ($rolekey,$update,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;      my ($rolekey,$update,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;
     my @pwhere = ();  
     if (exists($env{$rolekey}) && $env{$rolekey} ne '') {      if (exists($env{$rolekey}) && $env{$rolekey} ne '') {
         (undef,undef,$$role,@pwhere)=split(/\./,$rolekey);          my ($one,$two) = split(m{\./},$rolekey,2);
           (undef,undef,$$role) = split(/\./,$one,3);
         unless (!defined($$role) || $$role eq '') {          unless (!defined($$role) || $$role eq '') {
             $$where=join('.',@pwhere);              $$where = '/'.$two;
             $$trolecode=$$role.'.'.$$where;              $$trolecode=$$role.'.'.$$where;
             ($$tstart,$$tend)=split(/\./,$env{$rolekey});              ($$tstart,$$tend)=split(/\./,$env{$rolekey});
             $$tstatus='is';              $$tstatus='is';
Line 5343  sub role_status { Line 6614  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 5421  sub delete_env_groupprivs { Line 6693  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'}) {
         &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 5530  sub dump { Line 6819  sub dump {
     if (!$uname) { $uname=$env{'user.name'}; }      if (!$uname) { $uname=$env{'user.name'}; }
     my $uhome=&homeserver($uname,$udomain);      my $uhome=&homeserver($uname,$udomain);
   
     my $reply;      if ($regexp) {
           $regexp=&escape($regexp);
       } else {
           $regexp='.';
       }
     if (grep { $_ eq $uhome } &current_machine_ids()) {      if (grep { $_ eq $uhome } &current_machine_ids()) {
         # user is hosted on this machine          # user is hosted on this machine
         $reply = LONCAPA::Lond::dump_with_regexp(join(':', ($udomain,          my $reply = LONCAPA::Lond::dump_with_regexp(join(':', ($udomain,
                     $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});                      $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});
         return %{&unserialize($reply, $escapedkeys)};          return %{&unserialize($reply, $escapedkeys)};
     }      }
     if ($regexp) {  
  $regexp=&escape($regexp);  
     } else {  
  $regexp='.';  
     }  
     my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);      my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
     my @pairs=split(/\&/,$rep);      my @pairs=split(/\&/,$rep);
     my %returnhash=();      my %returnhash=();
Line 5589  sub currentdump { Line 6877  sub currentdump {
    $sdom     = $env{'user.domain'}       if (! defined($sdom));     $sdom     = $env{'user.domain'}       if (! defined($sdom));
    $sname    = $env{'user.name'}         if (! defined($sname));     $sname    = $env{'user.name'}         if (! defined($sname));
    my $uhome = &homeserver($sname,$sdom);     my $uhome = &homeserver($sname,$sdom);
    my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);     my $rep;
   
      if (grep { $_ eq $uhome } current_machine_ids()) {
          $rep = LONCAPA::Lond::dump_profile_database(join(":", ($sdom, $sname,
                      $courseid)));
      } else {
          $rep = reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);
      }
   
    return if ($rep =~ /^(error:|no_such_host)/);     return if ($rep =~ /^(error:|no_such_host)/);
    #     #
    my %returnhash=();     my %returnhash=();
Line 5710  sub newput { Line 7006  sub newput {
 # ---------------------------------------------------------  putstore interface  # ---------------------------------------------------------  putstore interface
   
 sub putstore {  sub putstore {
    my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;     my ($namespace,$symb,$version,$storehash,$udomain,$uname,$tolog)=@_;
    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 5724  sub putstore { Line 7020  sub putstore {
    my $reply =     my $reply =
        &reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items",         &reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items",
       $uhome);        $uhome);
      if (($tolog) && ($reply eq 'ok')) {
          my $namevalue='';
          foreach my $key (keys(%{$storehash})) {
              $namevalue.=&escape($key).'='.&freeze_escape($storehash->{$key}).'&';
          }
          my $ip = &get_requestor_ip();
          $namevalue .= 'ip='.$ip.
                        '&host='.&escape($perlvar{'lonHostID'}).
                        '&version='.$esc_v.
                        '&by='.&escape($env{'user.name'}.':'.$env{'user.domain'});
          &Apache::lonnet::courselog($symb.':'.$uname.':'.$udomain.':PUTSTORE:'.$namevalue);
      }
    if ($reply eq 'unknown_cmd') {     if ($reply eq 'unknown_cmd') {
        # gfall back to way things use to be done         # gfall back to way things use to be done
        return &old_putstore($namespace,$symb,$version,$storehash,$udomain,         return &old_putstore($namespace,$symb,$version,$storehash,$udomain,
Line 5817  sub tmpget { Line 7125  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 5882  sub get_timebased_id { Line 7192  sub get_timebased_id {
         my %inuse = &Apache::lonnet::dump('nohist_'.$namespace,$cdom,$cnum,$prefix);          my %inuse = &Apache::lonnet::dump('nohist_'.$namespace,$cdom,$cnum,$prefix);
         my $id = time;          my $id = time;
         $newid = $id;          $newid = $id;
           if ($idtype eq 'addcode') {
               $newid .= &sixnum_code();
           }
         my $idtries = 0;          my $idtries = 0;
         while (exists($inuse{$prefix."\0".$newid}) && $idtries < $maxtries) {          while (exists($inuse{$prefix."\0".$newid}) && $idtries < $maxtries) {
             if ($idtype eq 'concat') {              if ($idtype eq 'concat') {
                 $newid = $id.$idtries;                  $newid = $id.$idtries;
               } elsif ($idtype eq 'addcode') {
                   $newid = $newid.&sixnum_code();
             } else {              } else {
                 $newid ++;                  $newid ++;
             }              }
Line 5902  sub get_timebased_id { Line 7217  sub get_timebased_id {
                 $error = 'error saving new item: '.$putresult;                  $error = 'error saving new item: '.$putresult;
             }              }
         } else {          } else {
                undef($newid);
              $error = ('error: no unique suffix available for the new item ');               $error = ('error: no unique suffix available for the new item ');
         }          }
 #  remove lock  #  remove lock
Line 5910  sub get_timebased_id { Line 7226  sub get_timebased_id {
     } else {      } else {
         $error = "error: could not obtain lockfile\n";          $error = "error: could not obtain lockfile\n";
         $dellock = 'ok';          $dellock = 'ok';
           if (($prefix eq 'paste') && ($namespace eq 'courseeditor') && ($keyid eq 'num')) {
               $dellock = 'nolock';
           }
     }      }
     return ($newid,$dellock,$error);      return ($newid,$dellock,$error);
 }  }
   
   sub sixnum_code {
       my $code;
       for (0..6) {
           $code .= int( rand(9) );
       }
       return $code;
   }
   
 # -------------------------------------------------- portfolio access checking  # -------------------------------------------------- portfolio access checking
   
 sub portfolio_access {  sub portfolio_access {
     my ($requrl) = @_;      my ($requrl,$clientip) = @_;
     my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);      my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);
     my $result = &get_portfolio_access($udom,$unum,$file_name,$group);      my $result = &get_portfolio_access($udom,$unum,$file_name,$group,$clientip);
     if ($result) {      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') {
Line 5945  sub portfolio_access { Line 7272  sub portfolio_access {
 }  }
   
 sub get_portfolio_access {  sub get_portfolio_access {
     my ($udom,$unum,$file_name,$group,$access_hash) = @_;      my ($udom,$unum,$file_name,$group,$clientip,$access_hash) = @_;
   
     if (!ref($access_hash)) {      if (!ref($access_hash)) {
  my $current_perms = &get_portfile_permissions($udom,$unum);   my $current_perms = &get_portfile_permissions($udom,$unum);
Line 5954  sub get_portfolio_access { Line 7281  sub get_portfolio_access {
  $access_hash = $access_controls{$file_name};   $access_hash = $access_controls{$file_name};
     }      }
   
     my ($public,$guest,@domains,@users,@courses,@groups);      my ($public,$guest,@domains,@users,@courses,@groups,@ips);
     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})) {
Line 5978  sub get_portfolio_access { Line 7305  sub get_portfolio_access {
                 push(@courses,$key);                  push(@courses,$key);
             } elsif ($scope eq 'group') {              } elsif ($scope eq 'group') {
                 push(@groups,$key);                  push(@groups,$key);
               } elsif ($scope eq 'ip') {
                   push(@ips,$key);
             }              }
         }          }
         if ($public) {          if ($public) {
             return 'ok';              return 'ok';
           } elsif (@ips > 0) {
               my $allowed;
               foreach my $ipkey (@ips) {
                   if (ref($access_hash->{$ipkey}{'ip'}) eq 'ARRAY') {
                       if (&Apache::loncommon::check_ip_acc(join(',',@{$access_hash->{$ipkey}{'ip'}}),$clientip)) {
                           $allowed = 1;
                           last;
                       }
                   }
               }
               if ($allowed) {
                   return 'ok';
               }
         }          }
         if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {          if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
             if ($guest) {              if ($guest) {
Line 6168  sub usertools_access { Line 7510  sub usertools_access {
                       official   => 1,                        official   => 1,
                       unofficial => 1,                        unofficial => 1,
                       community  => 1,                        community  => 1,
                         textbook   => 1,
                  );                   );
     } elsif ($context eq 'requestauthor') {      } elsif ($context eq 'requestauthor') {
         %tools = (          %tools = (
Line 6183  sub usertools_access { Line 7526  sub usertools_access {
     }      }
     return if (!defined($tools{$tool}));      return if (!defined($tools{$tool}));
   
     if ((!defined($udom)) || (!defined($uname))) {      if (($udom eq '') || ($uname eq '')) {
         $udom = $env{'user.domain'};          $udom = $env{'user.domain'};
         $uname = $env{'user.name'};          $uname = $env{'user.name'};
     }      }
Line 6464  sub customaccess { Line 7807  sub customaccess {
 # ------------------------------------------------- Check for a user privilege  # ------------------------------------------------- Check for a user privilege
   
 sub allowed {  sub allowed {
     my ($priv,$uri,$symb,$role)=@_;      my ($priv,$uri,$symb,$role,$clientip,$noblockcheck,$ignorecache)=@_;
     my $ver_orguri=$uri;      my $ver_orguri=$uri;
     $uri=&deversion($uri);      $uri=&deversion($uri);
     my $orguri=$uri;      my $orguri=$uri;
Line 6481  sub allowed { Line 7824  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)$})) 
  || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) ))    || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) 
  && ($priv eq 'bre')) {   && ($priv eq 'bre')) {
  return 'F';   return 'F';
Line 6646  sub allowed { Line 7989  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 6659  sub allowed { Line 8028  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) {                  if ($noblockcheck) {
                     $thisallowed = 'B';                      $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 6675  sub allowed { Line 8049  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);                          if ($noblockcheck) {
                         if (@blockers > 0) {  
                             $thisallowed = 'B';  
                         } else {  
                             $thisallowed='F';                              $thisallowed='F';
                           } else {
                               my @blockers = &has_comm_blocking($priv,'',$refuri,'',1);
                               if (@blockers > 0) {
                                   $thisallowed = 'B';
                               } else {
                                   $thisallowed='F';
                               }
                         }                          }
                     }                      }
                 }                  }
Line 6691  sub allowed { Line 8069  sub allowed {
  && $thisallowed ne 'F'    && $thisallowed ne 'F' 
  && $thisallowed ne '2'   && $thisallowed ne '2'
  && &is_portfolio_url($uri)) {   && &is_portfolio_url($uri)) {
  $thisallowed = &portfolio_access($uri);   $thisallowed = &portfolio_access($uri,$clientip);
     }      }
           
 # Full access at system, domain or course-wide level? Exit.  # Full access at system, domain or course-wide level? Exit.
Line 6721  sub allowed { Line 8099  sub allowed {
   
     if ($env{'request.course.id'}) {      if ($env{'request.course.id'}) {
   
   # If this is modifying password (internal auth) domains must match for user and user's role.
   
           if ($priv eq 'mip') {
               if ($env{'user.domain'} eq $env{'request.role.domain'}) {
                   return $thisallowed;
               } else {
                   return '';
               }
           }
   
        $courseprivid=$env{'request.course.id'};         $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 6734  sub allowed { Line 8122  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);                     if ($noblockcheck) {
                    if (@blockers > 0) {  
                        $thisallowed = 'B';  
                    } else {  
                        $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 6746  sub allowed { Line 8138  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 6772  sub allowed { Line 8164  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);                        if ($noblockcheck) {
                       if (@blockers > 0) {  
                           $thisallowed = 'B';  
                       } else {  
                           $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 6857  sub allowed { Line 8253  sub allowed {
    }     }
        }         }
     }      }
      
 #  #
 # Rest of the restrictions depend on selected course  # Rest of the restrictions depend on selected course
 #  #
Line 6952  sub constructaccess { Line 8348  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|)/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 7007  sub constructaccess { Line 8403  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 7027  sub get_comm_blocks { Line 8454  sub get_comm_blocks {
     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\&([^\:]*)/);      return %blockers if ($env{'user.priv.'.$env{'request.role'}} =~/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 7055  sub has_comm_blocking { Line 8476  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 7076  sub has_comm_blocking { Line 8493  sub has_comm_blocking {
             my @to_test;              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;
                     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);
                               if (ref($navmap)) {
                                   my $res = $navmap->getBySymb($item);
                                   push(@to_test,$res);
                               }
                         } else {                          } else {
                             if ($item =~ /___\d+___/) {                              my $mapsymb = &symbread($item,1);
                                 $type = 'resource';                              if ($mapsymb) {
                                 @interval=&EXT("resource.0.interval",$item);                                  if (ref($navmap)) {
                                 if (ref($navmap)) {                                                              my $mapres = $navmap->getBySymb($mapsymb);
                                     my $res = $navmap->getBySymb($item);                                       if (ref($mapres)) {
                                     push(@to_test,$res);                                          my $first = $mapres->map_start();
                                 }                                          my $finish = $mapres->map_finish();
                             } else {                                          my $it = $navmap->getIterator($first,$finish,undef,0,0);
                                 my $mapsymb = &symbread($item,1);                                          if (ref($it)) {
                                 if ($mapsymb) {                                              my $res;
                                     if (ref($navmap)) {                                              while ($res = $it->next(undef,1)) {
                                         my $mapres = $navmap->getBySymb($mapsymb);                                                  next unless (ref($res));
                                         @to_test = $mapres->retrieveResources($mapres,undef,0,1);                                                  my $symb = $res->symb();
                                         foreach my $res (@to_test) {                                                  next if (($symb eq $mapsymb) || ($symb eq ''));
                                             my $symb = $res->symb();  
                                             next if ($symb eq $mapsymb);  
                                             if ($symb ne '') {  
                                                 @interval=&EXT("resource.0.interval",$symb);                                                  @interval=&EXT("resource.0.interval",$symb);
                                                 last;                                                  if ($interval[1] eq 'map') {
                                                       if ($res->answerable()) {
                                                           push(@to_test,$res);
                                                           last;
                                                       }
                                                   }
                                             }                                              }
                                         }                                          }
                                     }                                      }
                                 }                                  }
                             }                              }
                         }                          }
                         if ($interval[0] =~ /\d+/) {                      }
                             my $first_access;                      if ($interval[0] =~ /^\d+$/) {
                             if ($type eq 'resource') {                          my $first_access;
                                 $first_access=&get_first_access($interval[1],$item);                          if ($type eq 'resource') {
                             } elsif ($type eq 'map') {                              $first_access=&get_first_access($interval[1],$item);
                                 $first_access=&get_first_access($interval[1],undef,$item);                          } elsif ($type eq 'map') {
                             } else {                              $first_access=&get_first_access($interval[1],undef,$item);
                                 $first_access=&get_first_access($interval[1]);                          } else {
                             }                              $first_access=&get_first_access($interval[1]);
                             if ($first_access) {                          }
                                 my $timesup = $first_access+$interval[0];                          if ($first_access) {
                                 if ($timesup > $now) {                              my $timesup = $first_access+$interval[0];
                                     foreach my $res (@to_test) {                              if ($timesup > $now) {
                                         if ($res->is_problem()) {                                  my $activeblock;
                                             if ($res->completable()) {                                  foreach my $res (@to_test) {
                                                 unless (grep(/^\Q$block\E$/,@blockers)) {                                      if ($res->answerable()) {
                                                     push(@blockers,$block);                                          $activeblock = 1;
                                                 }                                          last;
                                                 last;                                      }
                                             }                                  }
                                   if ($activeblock) {
                                       if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') {
                                            if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'maps'}})) {
                                                $blockers{$block}{'maps'} = $commblocks{$block}{'blocks'}{'docs'}{'maps'};
                                            }
                                       }
                                       if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') {
                                           if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'resources'}})) {
                                               $blockers{$block}{'resources'} = $commblocks{$block}{'blocks'}{'docs'}{'resources'};
                                         }                                          }
                                     }                                      }
                                 }                                  }
Line 7139  sub has_comm_blocking { Line 8573  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{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);
       return if ($env{'request.state'} eq 'construct');
       my %blockinfo;
       if (ref($blocks) eq 'HASH') {
           %blockinfo = &get_commblock_resources($blocks);
       } else {
           &load_all_blockers($env{'user.name'},$env{'user.domain'});
           %blockinfo = %cachedblockers;
     }      }
     if (ref($docsblock->{'maps'}) eq 'HASH') {      return unless (keys(%blockinfo) > 0);
         if ($tocheck->{'maps'}) {      my (%possibles,@symbs);
             if ($docsblock->{'maps'}{$tocheck->{'maps'}}) {      if (!$symb) {
                 return 1;          $symb = &symbread($uri,1,1,1,\%possibles,$ignoresymbdb,$noenccheck);
             }  
         }  
     }      }
     if (ref($docsblock->{'resources'}) eq 'HASH') {      if ($symb) {
         if ($tocheck->{'resources'}) {          @symbs = ($symb);
             if ($docsblock->{'resources'}{$tocheck->{'resources'}}) {      } elsif (keys(%possibles)) {
                 return 1;          @symbs = keys(%possibles);
       }
       my $noblock;
       foreach my $symb (@symbs) {
           last if ($noblock);
           my ($map,$resid,$resurl)=&decode_symb($symb);
           foreach my $block (keys(%blockinfo)) {
               if ($block =~ /^firstaccess____(.+)$/) {
                   my $item = $1;
                   unless ($blocked) {
                       if (($item eq $map) || ($item eq $symb)) {
                           $noblock = 1;
                           last;
                       }
                   }
               }
               if (ref($blockinfo{$block}) eq 'HASH') {
                   if (ref($blockinfo{$block}{'resources'}) eq 'HASH') {
                       if ($blockinfo{$block}{'resources'}{$symb}) {
                           unless (grep(/^\Q$block\E$/,@blockers)) {
                               push(@blockers,$block);
                           }
                       }
                   }
                   if (ref($blockinfo{$block}{'maps'}) eq 'HASH') {
                       if ($blockinfo{$block}{'maps'}{$map}) {
                           unless (grep(/^\Q$block\E$/,@blockers)) {
                               push(@blockers,$block);
                           }
                       }
                   }
             }              }
         }          }
     }      }
       unless ($noblock) {
           return @blockers;
       }
     return;      return;
 }  }
   }
   
   # -------------------------------- 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 7233  sub get_symb_from_alias { Line 8710  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 7261  sub definerole { Line 8738  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 7274  sub definerole { Line 8759  sub definerole {
 # ---------------- Make a metadata query against the network of library servers  # ---------------- Make a metadata query against the network of library servers
   
 sub metadata_query {  sub metadata_query {
     my ($query,$custom,$customshow,$server_array)=@_;      my ($query,$custom,$customshow,$server_array,$domains_hash)=@_;
     my %rhash;      my %rhash;
     my %libserv = &all_library();      my %libserv = &all_library();
     my @server_list = (defined($server_array) ? @$server_array      my @server_list = (defined($server_array) ? @$server_array
                                               : keys(%libserv) );                                                : keys(%libserv) );
     for my $server (@server_list) {      for my $server (@server_list) {
           my $domains = '';
           if (ref($domains_hash) eq 'HASH') {
               $domains = $domains_hash->{$server};    
           }
  unless ($custom or $customshow) {   unless ($custom or $customshow) {
     my $reply=&reply("querysend:".&escape($query),$server);      my $reply=&reply("querysend:".&escape($query).':::'.&escape($domains),$server);
     $rhash{$server}=$reply;      $rhash{$server}=$reply;
  }   }
  else {   else {
     my $reply=&reply("querysend:".&escape($query).':'.      my $reply=&reply("querysend:".&escape($query).':'.
      &escape($custom).':'.&escape($customshow),       &escape($custom).':'.&escape($customshow).':'.&escape($domains),
      $server);       $server);
     $rhash{$server}=$reply;      $rhash{$server}=$reply;
  }   }
Line 7343  sub update_allusers_table { Line 8832  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 7364  sub fetch_enrollment_query { Line 8855  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 7392  sub fetch_enrollment_query { Line 8883  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 7409  sub fetch_enrollment_query { Line 8900  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 7775  sub auto_courserequest_checks { Line 9272  sub auto_courserequest_checks {
 }  }
   
 sub auto_courserequest_validation {  sub auto_courserequest_validation {
     my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist) = @_;      my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist,$custominfo) = @_;
     my ($homeserver,$response);      my ($homeserver,$response);
     if ($dom =~ /^$match_domain$/) {      if ($dom =~ /^$match_domain$/) {
         $homeserver = &domain($dom,'primary');          $homeserver = &domain($dom,'primary');
     }      }
     unless ($homeserver eq 'no_host') {        unless ($homeserver eq 'no_host') {
                     my $customdata;
           if (ref($custominfo) eq 'HASH') {
               $customdata = &freeze_escape($custominfo);
           }
         $response=&unescape(&reply('autocrsreqvalidation:'.$dom.':'.&escape($owner).          $response=&unescape(&reply('autocrsreqvalidation:'.$dom.':'.&escape($owner).
                                     ':'.&escape($crstype).':'.&escape($inststatuslist).                                      ':'.&escape($crstype).':'.&escape($inststatuslist).
                                     ':'.&escape($instcode).':'.&escape($instseclist),                                      ':'.&escape($instcode).':'.&escape($instseclist).':'.
                                     $homeserver));                                      $customdata,$homeserver));
     }      }
     return $response;      return $response;
 }  }
Line 7804  sub auto_validate_class_sec { Line 9304  sub auto_validate_class_sec {
     return $response;      return $response;
 }  }
   
   sub auto_validate_instclasses {
       my ($cdom,$cnum,$owners,$classesref) = @_;
       my ($homeserver,%validations);
       $homeserver = &homeserver($cnum,$cdom);
       unless ($homeserver eq 'no_host') {
           my $ownerlist;
           if (ref($owners) eq 'ARRAY') {
               $ownerlist = join(',',@{$owners});
           } else {
               $ownerlist = $owners;
           }
           if (ref($classesref) eq 'HASH') {
               my $classes = &freeze_escape($classesref);
               my $response=&reply('autovalidateinstclasses:'.&escape($ownerlist).
                                   ':'.$cdom.':'.$classes,$homeserver);
               unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
                   my @items = split(/&/,$response);
                   foreach my $item (@items) {
                       my ($key,$value) = split('=',$item);
                       $validations{&unescape($key)} = &thaw_unescape($value);
                   }
               }
           }
       }
       return %validations;
   }
   
   sub auto_crsreq_update {
       my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title,
           $code,$accessstart,$accessend,$inbound) = @_;
       my ($homeserver,%crsreqresponse);
       if ($cdom =~ /^$match_domain$/) {
           $homeserver = &domain($cdom,'primary');
       }
       unless (($homeserver eq 'no_host') || ($homeserver eq '')) {
           my $info;
           if (ref($inbound) eq 'HASH') {
               $info = &freeze_escape($inbound);
           }
           my $response=&reply('autocrsrequpdate:'.$cdom.':'.$cnum.':'.&escape($crstype).
                               ':'.&escape($action).':'.&escape($ownername).':'.
                               &escape($ownerdomain).':'.&escape($fullname).':'.
                               &escape($title).':'.&escape($code).':'.
                               &escape($accessstart).':'.&escape($accessend).':'.$info,$homeserver);
           unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
               my @items = split(/&/,$response);
               foreach my $item (@items) {
                   my ($key,$value) = split('=',$item);
                   $crsreqresponse{&unescape($key)} = &thaw_unescape($value);
               }
           }
       }
       return \%crsreqresponse;
   }
   
   sub auto_export_grades {
       my ($cdom,$cnum,$inforef,$gradesref) = @_;
       my ($homeserver,%exportresponse);
       if ($cdom =~ /^$match_domain$/) {
           $homeserver = &domain($cdom,'primary');
       }
       unless (($homeserver eq 'no_host') || ($homeserver eq '')) {
           my $info;
           if (ref($inforef) eq 'HASH') {
               $info = &freeze_escape($inforef);
           }
           if (ref($gradesref) eq 'HASH') {
               my $grades = &freeze_escape($gradesref);
               my $response=&reply('encrypt:autoexportgrades:'.$cdom.':'.$cnum.':'.
                                   $info.':'.$grades,$homeserver);
               unless ($response =~ /(con_lost|error|no_such_host|refused|unknown_command)/) {
                   my @items = split(/&/,$response);
                   foreach my $item (@items) {
                       my ($key,$value) = split('=',$item);
                       $exportresponse{&unescape($key)} = &thaw_unescape($value);
                   }
               }
           }
       }
       return \%exportresponse;
   }
   
   sub check_instcode_cloning {
       my ($codedefaults,$code_order,$cloner,$clonefromcode,$clonetocode) = @_;
       unless ((ref($codedefaults) eq 'HASH') && (ref($code_order) eq 'ARRAY')) {
           return;
       }
       my $canclone;
       if (@{$code_order} > 0) {
           my $instcoderegexp ='^';
           my @clonecodes = split(/\&/,$cloner);
           foreach my $item (@{$code_order}) {
               if (grep(/^\Q$item\E=/,@clonecodes)) {
                   foreach my $pair (@clonecodes) {
                       my ($key,$val) = split(/\=/,$pair,2);
                       $val = &unescape($val);
                       if ($key eq $item) {
                           $instcoderegexp .= '('.$val.')';
                           last;
                       }
                   }
               } else {
                   $instcoderegexp .= $codedefaults->{$item};
               }
           }
           $instcoderegexp .= '$';
           my (@from,@to);
           eval {
                  (@from) = ($clonefromcode =~ /$instcoderegexp/);
                  (@to) = ($clonetocode =~ /$instcoderegexp/);
           };
           if ((@from > 0) && (@to > 0)) {
               my @diffs = &Apache::loncommon::compare_arrays(\@from,\@to);
               if (!@diffs) {
                   $canclone = 1;
               }
           }
       }
       return $canclone;
   }
   
   sub default_instcode_cloning {
       my ($clonedom,$domdefclone,$clonefromcode,$clonetocode,$codedefaultsref,$codeorderref) = @_;
       my (%codedefaults,@code_order,$canclone);
       if ((ref($codedefaultsref) eq 'HASH') && (ref($codeorderref) eq 'ARRAY')) {
           %codedefaults = %{$codedefaultsref};
           @code_order = @{$codeorderref};
       } elsif ($clonedom) {
           &auto_instcode_defaults($clonedom,\%codedefaults,\@code_order);
       }
       if (($domdefclone) && (@code_order)) {
           my @clonecodes = split(/\+/,$domdefclone);
           my $instcoderegexp ='^';
           foreach my $item (@code_order) {
               if (grep(/^\Q$item\E$/,@clonecodes)) {
                   $instcoderegexp .= '('.$codedefaults{$item}.')';
               } else {
                   $instcoderegexp .= $codedefaults{$item};
               }
           }
           $instcoderegexp .= '$';
           my (@from,@to);
           eval {
               (@from) = ($clonefromcode =~ /$instcoderegexp/);
               (@to) = ($clonetocode =~ /$instcoderegexp/);
           };
           if ((@from > 0) && (@to > 0)) {
               my @diffs = &Apache::loncommon::compare_arrays(\@from,\@to);
               if (!@diffs) {
                   $canclone = 1;
               }
           }
       }
       return $canclone;
   }
   
 # ------------------------------------------------------- Course Group routines  # ------------------------------------------------------- Course Group routines
   
 sub get_coursegroups {  sub get_coursegroups {
Line 8168  sub assignrole { Line 9824  sub assignrole {
             &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,              &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
                            $selfenroll,$context);                             $selfenroll,$context);
         } 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);
         } elsif (($role eq 'ca') || ($role eq 'aa')) {          } elsif (($role eq 'ca') || ($role eq 'aa')) {
Line 8272  sub store_coowners { Line 9929  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 8473  sub modifyuser { Line 10146  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 8489  sub modifystudent { Line 10162  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) = @_;
     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 8542  sub modify_student_enrollment { Line 10215  sub modify_student_enrollment {
     my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum);      my %old_entry = &Apache::lonnet::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 8765  sub generate_coursenum { Line 10438  sub generate_coursenum {
 sub is_course {  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 =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/));
     return unless $cdom and $cnum;      my $uhome=&homeserver($cnum,$cdom);
       my $iscourse;
     my %courses = &courseiddump($cdom, '.', 1, '.', '.', $cnum, undef, undef,      if (grep { $_ eq $uhome } current_machine_ids()) {
         '.');          $iscourse = &LONCAPA::Lond::is_course($cdom,$cnum);
       } else {
     return unless(exists($courses{$cdom.'_'.$cnum}));          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 8907  sub save_selected_files { Line 10592  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 8921  sub save_selected_files { Line 10606  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 8931  sub files_in_path { Line 10616  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 8953  sub files_not_in_path { Line 10638  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 9066  sub modify_access_controls { Line 10751  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 9361  sub dirlist { Line 11046  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 9578  sub get_userresdata { Line 11279  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 10069  sub add_prefix_and_part { Line 11772  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,$liburi,$prefix,$depthcount)=@_;
     $uri=&declutter($uri);      $uri=&declutter($uri);
Line 10079  sub metadata { Line 11783  sub metadata {
         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {
  return undef;   return undef;
     }      }
     if (($uri =~ /^priv/ || $uri=~/home\/httpd\/html\/priv/)       if (($uri =~ /^priv/ || $uri=~m{^home/httpd/html/priv}) 
  && &Apache::lonxml::get_state('target') =~ /^(|meta)$/) {   && &Apache::lonxml::get_state('target') =~ /^(|meta)$/) {
  return undef;   return undef;
     }      }
Line 10096  sub metadata { Line 11800  sub metadata {
     }      }
     {      {
 # 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 10193  sub metadata { Line 11899  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'};
   #
   # Check metadata for imported file to
   # see if it contained response items
   #
                           my %currmetaentry = %metaentry;
                           my $libresponseorder = &metadata($location,'responseorder');
                           my $origfile;
                           if ($libresponseorder ne '') {
                               if ($#origfiletagids<0) {
                                   undef(%importedrespids);
                                   undef(%importedpartids);
                               }
                               @{$importedrespids{$importid}} = split(/\s*,\s*/,$libresponseorder);
                               if (@{$importedrespids{$importid}} > 0) {
                                   $importedresponses = 1;
   # We need to get the original file and the imported file to get the response order correct
   # Load and inspect original file
                                   if ($#origfiletagids<0) {
                                       my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
                                       $origfile=&getfile($origfilelocation);
                                       @origfiletagids=($origfile=~/<((?:\w+)response|import|part)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
                                   }
                               }
                           }
   # Do not overwrite contents of %metaentry hash for resource itself with 
   # hash populated for imported library file
                           %metaentry = %currmetaentry;
                           undef(%currmetaentry);
                         if ($importmode eq 'problem') {                          if ($importmode eq 'problem') {
 # Import as problem/response  # Import as problem/response
                            $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});                             $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
Line 10203  sub metadata { Line 11938  sub metadata {
                            $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);
                                  }
                            }                             }
   
 # Load and inspect imported file  # Load and inspect imported file
Line 10322  sub metadata { Line 12060  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 rebuild responseorder
                   $metaentry{':partorder'}.=','.$origfileimportpartids[$index+1];                  $metaentry{':responseorder'}='';
                } else {                  $metathesekeys{'responseorder'}=1;
 # we have imported parts at this position              }
                   $metaentry{':partorder'}.=','.$importedpartids{$origfileimportpartids[$index+1]};              for (my $index=0;$index<$#origfiletagids;$index+=2) {
                }                  my $origid = $origfiletagids[$index+1];
            }                  if ($origfiletagids[$index] eq 'part') {
            $metaentry{':partorder'}=~s/^\,//;  # Original part, part of the problem
                       if ($importedparts) {
                           $metaentry{':partorder'}.=','.$origid;
                       }
                   } elsif ($origfiletagids[$index] eq 'import') {
                       if ($importedparts) {
   # We have imported parts at this position
                           $metaentry{':partorder'}.=','.$importedpartids{$origid};
                       }
                       if ($importedresponses) {
   # We have imported responses at this position
                           if (ref($importedrespids{$origid}) eq 'ARRAY') {
                               $metaentry{':responseorder'}.=','.join(',',map { $origid.'_'.$_ } @{$importedrespids{$origid}});
                           }
                       }
                   } else {
   # Original response item, part of the problem
                       if ($importedresponses) {
                           $metaentry{':responseorder'}.=','.$origid;
                       }
                   }
               }
               if ($importedparts) {
                   $metaentry{':partorder'}=~s/^\,//;
               }
               if ($importedresponses) {
                   $metaentry{':responseorder'}=~s/^\,//;
               }
         }          }
   
  $metaentry{':keys'} = join(',',keys(%metathesekeys));   $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);   &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
     }      }
Line 10600  sub symbverify { Line 12366  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 10711  sub deversion { Line 12475  sub deversion {
 # ------------------------------------------------------ Return symb list entry  # ------------------------------------------------------ Return symb list entry
   
 sub symbread {  sub symbread {
     my ($thisfn,$donotrecurse)=@_;      my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles,
     my $cache_str;          $ignoresymbdb,$noenccheck)=@_;
     if ($thisfn ne '') {      my $cache_str='request.symbread.cached.'.$thisfn;
         $cache_str='request.symbread.cached.'.$thisfn;      if (defined($env{$cache_str})) {
         if ($env{$cache_str} ne '') {          unless (ref($possibles) eq 'HASH') {
             return $env{$cache_str};              if ($ignorecachednull) {
                   return $env{$cache_str} unless ($env{$cache_str} eq '');
               } else {
                   return $env{$cache_str};
               }
         }          }
    } else {      }
 # no filename provided? try from environment  # no filename provided? try from environment
       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'});
         }          }
Line 10744  sub symbread { Line 12513  sub symbread {
  if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) {   if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) {
     $targetfn=$1;      $targetfn=$1;
  }   }
         if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',          unless ($ignoresymbdb) {
                       &GDBM_READER(),0640)) {              if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
     $syval=$hash{$targetfn};                            &GDBM_READER(),0640)) {
             untie(%hash);          $syval=$hash{$targetfn};
                   untie(%hash);
               }
               if ($syval && $checkforblock) {
                   my @blockers = &has_comm_blocking('bre',$syval,$thisfn,$ignoresymbdb,$noenccheck);
                   if (@blockers) {
                       $syval='';
                   }
               }
         }          }
 # ---------------------------------------------------------- There was an entry  # ---------------------------------------------------------- There was an entry
         if ($syval) {          if ($syval) {
Line 10779  sub symbread { Line 12556  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 10798  sub symbread { Line 12614  sub symbread {
                      $syval='';                       $syval='';
                  }                   }
       }        }
               untie(%bighash)                untie(%bighash);
            }             }
         }          }
         if ($syval) {          if ($syval) {
Line 11136  sub rndseed_CODE_64bit5 { Line 12952  sub rndseed_CODE_64bit5 {
 sub setup_random_from_rndseed {  sub setup_random_from_rndseed {
     my ($rndseed)=@_;      my ($rndseed)=@_;
     if ($rndseed =~/([,:])/) {      if ($rndseed =~/([,:])/) {
  my ($num1,$num2)=split(/[,:]/,$rndseed);   my ($num1,$num2) = map { abs($_); } (split(/[,:]/,$rndseed));
  &Math::Random::random_set_seed(abs($num1),abs($num2));          if ((!$num1) || (!$num2) || ($num1 > 2147483562) || ($num2 > 2147483398)) {
               &Math::Random::random_set_seed_from_phrase($rndseed);
           } else {
               &Math::Random::random_set_seed($num1,$num2);
           }
     } else {      } else {
  &Math::Random::random_set_seed_from_phrase($rndseed);   &Math::Random::random_set_seed_from_phrase($rndseed);
     }      }
Line 11323  sub repcopy_userfile { Line 13143  sub repcopy_userfile {
     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=$ua->request($request,$transferfile);
 # did it work?  # did it work?
     if ($response->is_error()) {      if ($response->is_error()) {
Line 11349  sub tokenwrapper { Line 13170  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 11367  sub getuploaded { Line 13189  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 $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=$ua->request($request);
Line 11389  sub readfile { Line 13212  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 11502  sub machine_ids { Line 13325  sub machine_ids {
   
 sub additional_machine_domains {  sub additional_machine_domains {
     my @domains;      my @domains;
     open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab");      open(my $fh,"<","$perlvar{'lonTabDir'}/expected_domains.tab");
     while( my $line = <$fh>) {      while( my $line = <$fh>) {
         $line =~ s/\s//g;          $line =~ s/\s//g;
         push(@domains,$line);          push(@domains,$line);
Line 11523  sub default_login_domain { Line 13346  sub default_login_domain {
     return $domain;      return $domain;
 }  }
   
   sub shared_institution {
       my ($dom) = @_;
       my $same_intdom;
       my $hostintdom = &internet_dom($perlvar{'lonHostID'});
       if ($hostintdom ne '') {
           my %iphost = &get_iphost();
           my $primary_id = &domain($dom,'primary');
           my $primary_ip = &get_host_ip($primary_id);
           if (ref($iphost{$primary_ip}) eq 'ARRAY') {
               foreach my $id (@{$iphost{$primary_ip}}) {
                   my $intdom = &internet_dom($id);
                   if ($intdom eq $hostintdom) {
                       $same_intdom = 1;
                       last;
                   }
               }
           }
       }
       return $same_intdom;
   }
   
   sub uses_sts {
       my ($ignore_cache) = @_;
       my $lonhost = $perlvar{'lonHostID'};
       my $hostname = &hostname($lonhost);
       my $sts_on;
       if ($protocol{$lonhost} eq 'https') {
           my $cachetime = 12*3600;
           if (!$ignore_cache) {
               ($sts_on,my $cached)=&is_cached_new('stspolicy',$lonhost);
               if (defined($cached)) {
                   return $sts_on;
               }
           }
           my $ua=new LWP::UserAgent;
           my $url = $protocol{$lonhost}.'://'.$hostname.'/index.html';
           my $request=new HTTP::Request('HEAD',$url);
           my $response=$ua->request($request);
           if ($response->is_success) {
               my $has_sts = $response->header('Strict-Transport-Security');
               if ($has_sts eq '') {
                   $sts_on = 0;
               } else {
                   if ($has_sts =~ /\Qmax-age=\E(\d+)/) {
                       my $maxage = $1;
                       if ($maxage) {
                           $sts_on = 1;
                       } else {
                           $sts_on = 0;
                       }
                   } else {
                       $sts_on = 0;
                   }
               }
               return &do_cache_new('stspolicy',$lonhost,$sts_on,$cachetime);
           }
       }
       return;
   }
   
   sub get_requestor_ip {
       my ($r,$nolookup,$noproxy) = @_;
       my $from_ip;
       if (ref($r)) {
           $from_ip = $r->get_remote_host($nolookup);
       } else {
           $from_ip = $ENV{'REMOTE_ADDR'};
       }
       return $from_ip;
   }
   
 # ------------------------------------------------------------- Declutters URLs  # ------------------------------------------------------------- Declutters URLs
   
 sub declutter {  sub declutter {
     my $thisfn=shift;      my $thisfn=shift;
     if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }      if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
     $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;      unless ($thisfn=~m{^/home/httpd/html/priv/}) {
           $thisfn=~s{^/home/httpd/html}{};
       }
     $thisfn=~s/^\///;      $thisfn=~s/^\///;
     $thisfn=~s|^adm/wrapper/||;      $thisfn=~s|^adm/wrapper/||;
     $thisfn=~s|^adm/coursedocs/showdoc/||;      $thisfn=~s|^adm/coursedocs/showdoc/||;
Line 11644  sub get_dns { Line 13540  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) = keys(%alldns);   my ($dns) = sort { $b cmp $a } keys(%alldns);
  my $ua=new LWP::UserAgent;   my $ua=new LWP::UserAgent;
         $ua->timeout(30);          $ua->timeout(30);
  my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");   my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
Line 11669  sub get_dns { Line 13567  sub get_dns {
  &$func(\@content,$hashref);   &$func(\@content,$hashref);
  return;   return;
     }      }
     close($config);  
     my $which = (split('/',$url))[3];      my $which = (split('/',$url))[3];
     &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");      &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");
     open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab");      if (open(my $config,"<","$perlvar{'lonTabDir'}/dns_$which.tab")) {
     my @content = <$config>;          my @content = <$config>;
     &$func(\@content,$hashref);          &$func(\@content,$hashref);
       }
     return;      return;
 }  }
   
 # ------------------------------------------------------Get DNS checksums file  # ------------------------------------------------------Get DNS checksums file
 sub parse_dns_checksums_tab {  sub parse_dns_checksums_tab {
     my ($lines,$hashref) = @_;      my ($lines,$hashref) = @_;
     my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});      my $lonhost = $perlvar{'lonHostID'};
       my $machine_dom = &Apache::lonnet::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 $webconfdir = '/etc/httpd/conf';
       if ($distro =~ /^(ubuntu|debian)(\d+)$/) {
           $webconfdir = '/etc/apache2';
       } elsif ($distro =~ /^sles(\d+)$/) {
           if ($1 >= 10) {
               $webconfdir = '/etc/apache2';
           }
       } elsif ($distro =~ /^suse(\d+\.\d+)$/) {
           if ($1 >= 10.0) {
               $webconfdir = '/etc/apache2';
           }
       }
     my ($release,$timestamp) = split(/\-/,$loncaparev);      my ($release,$timestamp) = split(/\-/,$loncaparev);
     my (%chksum,%revnum);      my (%chksum,%revnum);
     if (ref($lines) eq 'ARRAY') {      if (ref($lines) eq 'ARRAY') {
         chomp(@{$lines});          chomp(@{$lines});
         my $versions = shift(@{$lines});          my $version = shift(@{$lines});
         my %supported;          if ($version eq $release) {
         if ($versions =~ /^VERSIONS\:([\w\.\,]+)$/) {  
             my $releaseslist = $1;  
             if ($releaseslist =~ /,/) {  
                 map { $supported{$_} = 1; } split(/,/,$releaseslist);  
             } elsif ($releaseslist) {  
                 $supported{$releaseslist} = 1;  
             }  
         }  
         if ($supported{$release}) {  
             my $matchthis = 0;  
             foreach my $line (@{$lines}) {              foreach my $line (@{$lines}) {
                 if ($line =~ /^(\d[\w\.]+)$/) {                  my ($file,$version,$shasum) = split(/,/,$line);
                     if ($matchthis) {                  if ($file =~ m{^/etc/httpd/conf}) {
                         last;                      if ($webconfdir eq '/etc/apache2') {
                     } elsif ($1 eq $release) {                          $file =~ s{^\Q/etc/httpd/conf/\E}{$webconfdir/};
                         $matchthis = 1;  
                     }                      }
                 } elsif ($matchthis) {  
                     my ($file,$version,$shasum) = split(/,/,$line);  
                     $chksum{$file} = $shasum;  
                     $revnum{$file} = $version;  
                 }                  }
                   $chksum{$file} = $shasum;
                   $revnum{$file} = $version;
             }              }
             if (ref($hashref) eq 'HASH') {              if (ref($hashref) eq 'HASH') {
                 %{$hashref} = (                  %{$hashref} = (
Line 11725  sub parse_dns_checksums_tab { Line 13624  sub parse_dns_checksums_tab {
   
 sub fetch_dns_checksums {  sub fetch_dns_checksums {
     my %checksums;      my %checksums;
     &get_dns('/adm/dns/checksums',\&parse_dns_checksums_tab,1,1,      my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});
       my $loncaparev = &get_server_loncaparev($machine_dom,$perlvar{'lonHostID'});
       my ($release,$timestamp) = split(/\-/,$loncaparev);
       &get_dns("/adm/dns/checksums/$release",\&parse_dns_checksums_tab,1,1,
              \%checksums);               \%checksums);
     return \%checksums;      return \%checksums;
 }  }
Line 11758  sub fetch_dns_checksums { Line 13660  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 11813  sub fetch_dns_checksums { Line 13715  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 11845  sub fetch_dns_checksums { Line 13762  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 11868  sub fetch_dns_checksums { Line 13785  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 11990  sub fetch_dns_checksums { Line 13908  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) {
Line 12014  sub fetch_dns_checksums { Line 13932  sub fetch_dns_checksums {
     %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 12039  sub fetch_dns_checksums { Line 13957  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 12103  sub fetch_dns_checksums { Line 14023  sub fetch_dns_checksums {
 }  }
   
 sub all_loncaparevs {  sub all_loncaparevs {
     return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10);      return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10 2.11);
 }  }
   
 # ------------------------------------------------------- Read loncaparev table  # ------------------------------------------------------- Read loncaparev table
 {  {
     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 12126  sub all_loncaparevs { Line 14046  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 12151  BEGIN { Line 14071  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 12165  BEGIN { Line 14085  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 12179  BEGIN { Line 14099  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 12199  BEGIN { Line 14119  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 12245  BEGIN { Line 14165  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 12264  BEGIN { Line 14184  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 12281  $readit=1; Line 14211  $readit=1;
  if ($test != 0) { $_64bit=1; } else { $_64bit=0; }   if ($test != 0) { $_64bit=1; } else { $_64bit=0; }
  &logthis(" Detected 64bit platform ($_64bit)");   &logthis(" Detected 64bit platform ($_64bit)");
     }      }
   
     {  
         eval {  
             ($apache) =  
                 (Apache2::ServerUtil::get_server_version() =~ m{Apache/(\d+\.\d+)});  
         };  
         if ($@) {  
            $apache = 1.3;  
         }  
     }  
   
 }  }
 }  }
   
Line 12433  were new keys. I.E. 1:foo will become 1: Line 14352  were new keys. I.E. 1:foo will become 1:
 Calling convention:  Calling convention:
   
  my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname);   my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname);
  &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname);   &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$laststore);
   
 For more detailed information, see lonnet specific documentation.  For more detailed information, see lonnet specific documentation.
   
Line 12569  escaped strings of the action recorded i Line 14488  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.
   
 =item *  =item *
   
Line 12594  in which case the null string is returne Line 14529  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 12800  Inputs: Line 14736  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 12903  Returns: Line 14841  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 12969  will be stored for query Line 14989  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 13070  homeserver. Line 15103  homeserver.
   
 =item *  =item *
   
 store($storehash,$symb,$namespace,$udom,$uname) : stores hash permanently  store($storehash,$symb,$namespace,$udom,$uname,$laststore) : stores hash 
 for this url; hashref needs to be given and should be a \%hashname; the  permanently for this url; hashref needs to be given and should be a \%hashname;
 remaining args aren't required and if they aren't passed or are '' they will  the remaining args aren't required and if they aren't passed or are '' they will
 be derived from the env  be derived from the env (with the exception of $laststore, which is an
   optional arg used when a user's submission is stored in grading).
   $laststore is $version=$timestamp, where $version is the most recent version
   number retrieved for the corresponding $symb in the $namespace db file, and
   $timestamp is the timestamp for that transaction (UNIX time).
   $laststore is currently only passed when cstore() is called by
   structuretags::finalize_storage().
   
 =item *  =item *
   
 cstore($storehash,$symb,$namespace,$udom,$uname) : same as store but  cstore($storehash,$symb,$namespace,$udom,$uname,$laststore) : same as store 
 uses critical subroutine  but uses critical subroutine
   
 =item *  =item *
   
Line 13101  $range should be either an integer '100' Line 15140  $range should be either an integer '100'
   
 =item *  =item *
   
 putstore($namespace,$symb,$version,$storehash,$udomain,$uname) :  putstore($namespace,$symb,$version,$storehash,$udomain,$uname,$tolog) :
 replaces a &store() version of data with a replacement set of data  replaces a &store() version of data with a replacement set of data
 for a particular resource in a namespace passed in the $storehash hash   for a particular resource in a namespace passed in the $storehash hash 
 reference  reference. If $tolog is true, the transaction is logged in the courselog
   with an action=PUTSTORE.
   
 =item *  =item *
   
Line 13214  server ($udom and $uhome are optional) Line 15254  server ($udom and $uhome are optional)
   
 =item *   =item * 
   
 get_domain_defaults($target_domain) : returns hash with defaults for  get_domain_defaults($target_domain,$ignore_cache) : returns hash with defaults
 authentication and language in the domain. Keys are: auth_def, auth_arg_def,  for: authentication, language, quotas, timezone, date locale, and portal URL in
 lang_def; corresponsing values are authentication type (internal, krb4, krb5,  the target domain.
 or localauth), initial password or a kerberos realm, language (e.g., en-us).  
 Values are retrieved from cache (if current), or from domain's configuration.db  May also include additional key => value pairs for the following groups:
 (if available), or lastly from values in lonTabs/dns_domain,tab,   
 or lonTabs/domain.tab.   =over
   
   =item
   disk quotas (MB allocated by default to portfolios and authoring spaces).
   
   =over
   
   =item defaultquota, authorquota
   
   =back
   
   =item
   tools (availability of aboutme page, blog, webDAV access for authoring spaces,
   portfolio for users).
   
   =over
   
   =item
   aboutme, blog, webdav, portfolio
   
   =back
   
   =item
   requestcourses: ability to request courses, and how requests are processed.
   
   =over
   
   =item
   official, unofficial, community, textbook
   
   =back
   
   =item
   inststatus: types of institutional affiliation, and order in which they are displayed.
   
   =over
   
   =item
   inststatustypes, inststatusorder, inststatusguest
   
   =back
   
   =item
   coursedefaults: can PDF forms can be created, default credits for courses, default quotas (MB)
   for course's uploaded content.
   
   =over
   
   =item
   canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota,
   communityquota, textbookquota
   
   =back
   
   =item
   usersessions: set options for hosting of your users in other domains, and hosting of users from other domains
   on your servers.
   
   =over
   
   =item
   remotesessions, hostedsessions
   
   =back
   
   =back
   
   In cases where a domain coordinator has never used the "Set Domain Configuration"
   utility to create a configuration.db file on a domain's primary library server
   only the following domain defaults: auth_def, auth_arg_def, lang_def
   -- corresponding values are authentication type (internal, krb4, krb5,
   or localauth), initial password or a kerberos realm, language (e.g., en-us) --
   will be available. Values are retrieved from cache (if current), unless the
   optional $ignore_cache arg is true, or from domain's configuration.db (if available),
   or lastly from values in lonTabs/dns_domain,tab, or lonTabs/domain.tab.
   
   Typical usage:
   
 %domdefaults = &get_auth_defaults($target_domain);  %domdefaults = &get_domain_defaults($target_domain);
   
 =back  =back
   
Line 13447  filelocation except for hrefs Line 15563  filelocation except for hrefs
   
 =item *  =item *
   
 declutter() : declutters URLs (remove docroot, beginning slashes, 'res' etc)  declutter() : declutters URLs -- remove beginning slashes, 'res' etc.
   also removes beginning /home/httpd/html unless /priv/ follows it.
   
 =back  =back
   
Line 13497  userspace, probably shouldn't be called Line 15614  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.1172.2.31  
changed lines
  Added in v.1.1172.2.134

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