[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.1311 and 1.1442

version 1.1311, 2016/06/19 00:19:24 version 1.1442, 2021/02/08 14:50:53
Line 71  delayed. Line 71  delayed.
 package Apache::lonnet;  package Apache::lonnet;
   
 use strict;  use strict;
 use LWP::UserAgent();  
 use HTTP::Date;  use HTTP::Date;
 use Image::Magick;  use Image::Magick;
   use CGI::Cookie;
   
 use Encode;  use Encode;
   
 use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir  use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $deftex
             $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease              $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease
             %managerstab);              %managerstab $passwdmin);
   
 my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,  my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
     %userrolehash, $processmarker, $dumpcount, %coursedombuf,      %userrolehash, $processmarker, $dumpcount, %coursedombuf,
Line 97  use Cache::Memcached; Line 96  use Cache::Memcached;
 use Digest::MD5;  use Digest::MD5;
 use Math::Random;  use Math::Random;
 use File::MMagic;  use File::MMagic;
   use Net::CIDR;
 use LONCAPA qw(:DEFAULT :match);  use LONCAPA qw(:DEFAULT :match);
 use LONCAPA::Configuration;  use LONCAPA::Configuration;
 use LONCAPA::lonmetadata;  use LONCAPA::lonmetadata;
 use LONCAPA::Lond;  use LONCAPA::Lond;
   use LONCAPA::LWPReq;
   use LONCAPA::transliterate;
   
 use File::Copy;  use File::Copy;
   
Line 127  our @EXPORT = qw(%env); Line 129  our @EXPORT = qw(%env);
  $logid ++;   $logid ++;
         my $now = time();          my $now = time();
  my $id=$now.'00000'.$$.'00000'.$logid;   my $id=$now.'00000'.$$.'00000'.$logid;
           my $ip = &get_requestor_ip();
         my $logentry = {           my $logentry = { 
                           $id => {                            $id => {
                                    'exe_uname' => $env{'user.name'},                                     'exe_uname' => $env{'user.name'},
                                    'exe_udom'  => $env{'user.domain'},                                     'exe_udom'  => $env{'user.domain'},
                                    'exe_time'  => $now,                                     'exe_time'  => $now,
                                    'exe_ip'    => $ENV{'REMOTE_ADDR'},                                     'exe_ip'    => $ip,
                                    'delflag'   => $delflag,                                     'delflag'   => $delflag,
                                    'logentry'  => $storehash,                                     'logentry'  => $storehash,
                                    'uname'     => $uname,                                     'uname'     => $uname,
Line 146  our @EXPORT = qw(%env); Line 149  our @EXPORT = qw(%env);
 sub logtouch {  sub logtouch {
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     unless (-e "$execdir/logs/lonnet.log") {      unless (-e "$execdir/logs/lonnet.log") {
  open(my $fh,">>$execdir/logs/lonnet.log");   open(my $fh,">>","$execdir/logs/lonnet.log");
  close $fh;   close $fh;
     }      }
     my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];      my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];
Line 158  sub logthis { Line 161  sub logthis {
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     my $now=time;      my $now=time;
     my $local=localtime($now);      my $local=localtime($now);
     if (open(my $fh,">>$execdir/logs/lonnet.log")) {      if (open(my $fh,">>","$execdir/logs/lonnet.log")) {
  my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string.   my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string.
  print $fh $logstring;   print $fh $logstring;
  close($fh);   close($fh);
Line 171  sub logperm { Line 174  sub logperm {
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     my $now=time;      my $now=time;
     my $local=localtime($now);      my $local=localtime($now);
     if (open(my $fh,">>$execdir/logs/lonnet.perm.log")) {      if (open(my $fh,">>","$execdir/logs/lonnet.perm.log")) {
  print $fh "$now:$message:$local\n";   print $fh "$now:$message:$local\n";
  close($fh);   close($fh);
     }      }
Line 184  sub create_connection { Line 187  sub create_connection {
      Type    => SOCK_STREAM,       Type    => SOCK_STREAM,
      Timeout => 10);       Timeout => 10);
     return 0 if (!$client);      return 0 if (!$client);
     print $client (join(':',$hostname,$lonid,&machine_ids($hostname))."\n");      print $client (join(':',$hostname,$lonid,&machine_ids($hostname),$loncaparevs{$lonid})."\n");
     my $result = <$client>;      my $result = <$client>;
     chomp($result);      chomp($result);
     return 1 if ($result eq 'done');      return 1 if ($result eq 'done');
Line 229  sub get_server_distarch { Line 232  sub get_server_distarch {
     return;      return;
 }  }
   
   sub get_servercerts_info {
       my ($lonhost,$hostname,$context) = @_;
       return if ($lonhost eq '');
       if ($hostname eq '') {
           $hostname = &hostname($lonhost);
       }
       return if ($hostname eq '');
       my ($rep,$uselocal);
       if ($context eq 'install') {
           $uselocal = 1;
       } elsif (grep { $_ eq $lonhost } &current_machine_ids()) {
           $uselocal = 1;
       }
       if (($context ne 'cgi') && ($context ne 'install') && ($uselocal)) {
           my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0];
           if ($distro eq '') {
               $uselocal = 0;
           } elsif ($distro =~ /^(?:centos|redhat|scientific)(\d+)$/) {
               if ($1 < 6) {
                   $uselocal = 0;
               }
           }  elsif ($distro =~ /^(?:sles)(\d+)$/) {
               if ($1 < 12) {
                   $uselocal = 0;
               }
           }
       }
       if ($uselocal) {
           $rep = LONCAPA::Lond::server_certs(\%perlvar,$lonhost,$hostname);
       } else {
           $rep=&reply('servercerts',$lonhost);
       }
       my ($result,%returnhash);
       if (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') ||
           ($rep eq 'unknown_cmd')) {
           $result = $rep;
       } else {
           $result = 'ok';
           my @pairs=split(/\&/,$rep);
           foreach my $item (@pairs) {
               my ($key,$value)=split(/=/,$item,2);
               my $what = &unescape($key);
               $returnhash{$what}=&thaw_unescape($value);
           }
       }
       return ($result,\%returnhash);
   }
   
 sub get_server_loncaparev {  sub get_server_loncaparev {
     my ($dom,$lonhost,$ignore_cache,$caller) = @_;      my ($dom,$lonhost,$ignore_cache,$caller) = @_;
     if (defined($lonhost)) {      if (defined($lonhost)) {
Line 263  sub get_server_loncaparev { Line 314  sub get_server_loncaparev {
             $answer = &reply('serverloncaparev',$lonhost);              $answer = &reply('serverloncaparev',$lonhost);
             if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) {              if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) {
                 if ($caller eq 'loncron') {                  if ($caller eq 'loncron') {
                     my $ua=new LWP::UserAgent;                      my $hostname = &hostname($lonhost);
                     $ua->timeout(4);  
                     my $protocol = $protocol{$lonhost};                      my $protocol = $protocol{$lonhost};
                     $protocol = 'http' if ($protocol ne 'https');                      $protocol = 'http' if ($protocol ne 'https');
                     my $url = $protocol.'://'.&hostname($lonhost).'/adm/about.html';                      my $url = $protocol.'://'.$hostname.'/adm/about.html';
                     my $request=new HTTP::Request('GET',$url);                      my $request=new HTTP::Request('GET',$url);
                     my $response=$ua->request($request);                      my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,4,1);
                     unless ($response->is_error()) {                      unless ($response->is_error()) {
                         my $content = $response->content;                          my $content = $response->content;
                         if ($content =~ /<p>VERSION\:\s*([\w.\-]+)<\/p>/) {                          if ($content =~ /<p>VERSION\:\s*([\w.\-]+)<\/p>/) {
Line 412  sub reply { Line 462  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 441  sub reconlonc { Line 509  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 481  sub critical { Line 549  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);
  }   }
Line 490  sub critical { Line 558  sub critical {
             my $wcmd='';              my $wcmd='';
             {              {
  my $dfh;   my $dfh;
  if (open($dfh,"<$dfilename")) {   if (open($dfh,"<",$dfilename)) {
     $wcmd=<$dfh>;       $wcmd=<$dfh>; 
     close($dfh);      close($dfh);
  }   }
Line 606  sub transfer_profile_to_env { Line 674  sub transfer_profile_to_env {
   
 # ---------------------------------------------------- Check for valid session   # ---------------------------------------------------- Check for valid session 
 sub check_for_valid_session {  sub check_for_valid_session {
     my ($r,$name,$userhashref) = @_;      my ($r,$name,$userhashref,$domref) = @_;
     my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));      my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
     if ($name eq '') {      my ($lonidsdir,$linkname,$pubname,$secure,$lonid);
         $name = 'lonID';  
     }  
     my $lonid=$cookies{$name};  
     return undef if (!$lonid);  
   
     my $handle=&LONCAPA::clean_handle($lonid->value);  
     my $lonidsdir;  
     if ($name eq 'lonDAV') {      if ($name eq 'lonDAV') {
         $lonidsdir=$r->dir_config('lonDAVsessDir');          $lonidsdir=$r->dir_config('lonDAVsessDir');
     } else {      } else {
         $lonidsdir=$r->dir_config('lonIDsDir');          $lonidsdir=$r->dir_config('lonIDsDir');
           if ($name eq '') {
               $name = 'lonID';
           }
       }
       if ($name eq 'lonID') {
           $secure = 'lonSID';
           $linkname = 'lonLinkID';
           $pubname = 'lonPubID';
           if (exists($cookies{$secure})) {
               $lonid=$cookies{$secure};
           } elsif (exists($cookies{$name})) {
               $lonid=$cookies{$name};
           } elsif ((exists($cookies{$linkname})) && ($ENV{'SERVER_PORT'} != 443)) {
               $lonid=$cookies{$linkname};
           } elsif (exists($cookies{$pubname})) {
               $lonid=$cookies{$pubname};
           }
       } else {
           $lonid=$cookies{$name};
       }
       return undef if (!$lonid);
   
       my $handle=&LONCAPA::clean_handle($lonid->value);
       if (-l "$lonidsdir/$handle.id") {
           my $link = readlink("$lonidsdir/$handle.id");
           if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) {
               $handle = $1;
           }
       }
       if (!-e "$lonidsdir/$handle.id") {
           if ((ref($domref)) && ($name eq 'lonID') && 
               ($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) {
               my ($possuname,$possudom,$possuhome) = ($1,$2,$3);
               if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) {
                   $$domref = $possudom;
               }
           }
           return undef;
     }      }
     return undef if (!-e "$lonidsdir/$handle.id");  
   
     my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");      my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
     return undef if (!$opened);      return undef if (!$opened);
Line 635  sub check_for_valid_session { Line 733  sub check_for_valid_session {
   
     if (!defined($disk_env{'user.name'})      if (!defined($disk_env{'user.name'})
  || !defined($disk_env{'user.domain'})) {   || !defined($disk_env{'user.domain'})) {
           untie(%disk_env);
  return undef;   return undef;
     }      }
   
     if (ref($userhashref) eq 'HASH') {      if (ref($userhashref) eq 'HASH') {
         $userhashref->{'name'} = $disk_env{'user.name'};          $userhashref->{'name'} = $disk_env{'user.name'};
         $userhashref->{'domain'} = $disk_env{'user.domain'};          $userhashref->{'domain'} = $disk_env{'user.domain'};
           $userhashref->{'lti'} = $disk_env{'request.lti.login'};
           if ($userhashref->{'lti'}) {
               $userhashref->{'ltitarget'} = $disk_env{'request.lti.target'};
               $userhashref->{'ltiuri'} = $disk_env{'request.lti.uri'};
           }
     }      }
       untie(%disk_env);
   
     return $handle;      return $handle;
 }  }
Line 666  sub timed_flock { Line 771  sub timed_flock {
     }      }
 }  }
   
   sub get_sessionfile_vars {
       my ($handle,$lonidsdir,$storearr) = @_;
       my %returnhash;
       unless (ref($storearr) eq 'ARRAY') {
           return %returnhash;
       }
       if (-l "$lonidsdir/$handle.id") {
           my $link = readlink("$lonidsdir/$handle.id");
           if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) {
               $handle = $1;
           }
       }
       if ((-e "$lonidsdir/$handle.id") &&
           ($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) {
           my ($possuname,$possudom,$possuhome) = ($1,$2,$3);
           if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) {
               if (open(my $idf,'+<',"$lonidsdir/$handle.id")) {
                   flock($idf,LOCK_SH);
                   if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",
                           &GDBM_READER(),0640)) {
                       foreach my $item (@{$storearr}) {
                           $returnhash{$item} = $disk_env{$item};
                       }
                       untie(%disk_env);
                   }
               }
           }
       }
       return %returnhash;
   }
   
 # ---------------------------------------------------------- Append Environment  # ---------------------------------------------------------- Append Environment
   
 sub appenv {  sub appenv {
Line 691  sub appenv { Line 827  sub appenv {
                 $env{$key}=$newenv->{$key};                  $env{$key}=$newenv->{$key};
             }              }
         }          }
         my $opened = open(my $env_file,'+<',$env{'user.environment'});          my $lonids = $perlvar{'lonIDsDir'};
         if ($opened          if ($env{'user.environment'} =~ m{^\Q$lonids/\E$match_username\_\d+\_$match_domain\_[\w\-.]+\.id$}) {
     && &timed_flock($env_file,LOCK_EX)              my $opened = open(my $env_file,'+<',$env{'user.environment'});
     &&              if ($opened
     tie(my %disk_env,'GDBM_File',$env{'user.environment'},          && &timed_flock($env_file,LOCK_EX)
         (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {          &&
     while (my ($key,$value) = each(%{$newenv})) {          tie(my %disk_env,'GDBM_File',$env{'user.environment'},
         $disk_env{$key} = $value;              (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
     }          while (my ($key,$value) = each(%{$newenv})) {
     untie(%disk_env);              $disk_env{$key} = $value;
           }
           untie(%disk_env);
               }
         }          }
     }      }
     return 'ok';      return 'ok';
Line 816  sub userload { Line 955  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 871  sub spareserver { Line 1011  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 944  sub find_existing_session { Line 1084  sub find_existing_session {
     return;      return;
 }  }
   
   sub delusersession {
       my ($lonid,$udom,$uname) = @_;
       my $uprimary_id = &domain($udom,'primary');
       my $uintdom = &internet_dom($uprimary_id);
       my $intdom = &internet_dom($lonid);
       my $serverhomedom = &host_domain($lonid);
       if (($uintdom ne '') && ($uintdom eq $intdom)) {
           return &reply(join(':','delusersession',
                               map {&escape($_)} ($udom,$uname)),$lonid);
       }
       return;
   }
   
   # check if user's browser sent load balancer cookie and server still has session
   # and is not overloaded.
   sub check_for_balancer_cookie {
       my ($r,$update_mtime) = @_;
       my ($otherserver,$cookie);
       my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
       if (exists($cookies{'balanceID'})) {
           my $balid = $cookies{'balanceID'};
           $cookie=&LONCAPA::clean_handle($balid->value);
           my $balancedir=$r->dir_config('lonBalanceDir');
           if ((-d $balancedir) && (-e "$balancedir/$cookie.id")) {
               if ($cookie =~ /^($match_domain)_($match_username)_[a-f0-9]+$/) {
                   my ($possudom,$possuname) = ($1,$2);
                   my $has_session = 0;
                   if ((&domain($possudom) ne '') &&
                       (&homeserver($possuname,$possudom) ne 'no_host')) {
                       my $try_server;
                       my $opened = open(my $idf,'+<',"$balancedir/$cookie.id");
                       if ($opened) {
                           flock($idf,LOCK_SH);
                           while (my $line = <$idf>) {
                               chomp($line);
                               if (&hostname($line) ne '') {
                                   $try_server = $line;
                                   last;
                               }
                           }
                           close($idf);
                           if (($try_server) &&
                               (&has_user_session($try_server,$possudom,$possuname))) {
                               my $lowest_load = 30000;
                               ($otherserver,$lowest_load) =
                                   &compare_server_load($try_server,undef,$lowest_load);
                               if ($otherserver ne '' && $lowest_load < 100) {
                                   $has_session = 1;
                               } else {
                                   undef($otherserver);
                               }
                           }
                       }
                   }
                   if ($has_session) {
                       if ($update_mtime) {
                           my $atime = my $mtime = time;
                           utime($atime,$mtime,"$balancedir/$cookie.id");
                       }
                   } else {
                       unlink("$balancedir/$cookie.id");
                   }
               }
           }
       }
       return ($otherserver,$cookie);
   }
   
   sub updatebalcookie {
       my ($cookie,$balancer,$lastentry)=@_;
       if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) {
           my ($udom,$uname) = ($1,$2);
           my $uprimary_id = &domain($udom,'primary');
           my $uintdom = &internet_dom($uprimary_id);
           my $intdom = &internet_dom($balancer);
           my $serverhomedom = &host_domain($balancer);
           if (($uintdom ne '') && ($uintdom eq $intdom)) {
               return &reply('updatebalcookie:'.&escape($cookie).':'.&escape($lastentry),$balancer);
           }
       }
       return;
   }
   
   sub delbalcookie {
       my ($cookie,$balancer) =@_;
       if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) {
           my ($udom,$uname) = ($1,$2);
           my $uprimary_id = &domain($udom,'primary');
           my $uintdom = &internet_dom($uprimary_id);
           my $intdom = &internet_dom($balancer);
           my $serverhomedom = &host_domain($balancer);
           if (($uintdom ne '') && ($uintdom eq $intdom)) {
               return &reply('delbalcookie:'.&escape($cookie),$balancer);
           }
       }
   }
   
 # -------------------------------- ask if server already has a session for user  # -------------------------------- ask if server already has a session for user
 sub has_user_session {  sub has_user_session {
     my ($lonid,$udom,$uname) = @_;      my ($lonid,$udom,$uname) = @_;
Line 979  sub choose_server { Line 1216  sub choose_server {
             if (ref($balancers) eq 'HASH') {              if (ref($balancers) eq 'HASH') {
                 next if (exists($balancers->{$lonhost}));                  next if (exists($balancers->{$lonhost}));
             }              }
         }             }
         my $loginvia;          my $loginvia;
         if ($checkloginvia) {          if ($checkloginvia) {
             $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};              $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};
Line 1007  sub choose_server { Line 1244  sub choose_server {
     if ($login_host ne '') {      if ($login_host ne '') {
         $hostname = &hostname($login_host);          $hostname = &hostname($login_host);
     }      }
     return ($login_host,$hostname,$portal_path,$isredirect);      return ($login_host,$hostname,$portal_path,$isredirect,$lowest_load);
   }
   
   sub get_course_sessions {
       my ($cnum,$cdom,$lastactivity) = @_;
       my %servers = &internet_dom_servers($cdom);
       my %returnhash;
       foreach my $server (sort(keys(%servers))) {
           my $rep = &reply("coursesessions:$cdom:$cnum:$lastactivity",$server);
           my @pairs=split(/\&/,$rep);
           unless (($rep eq 'unknown_cmd') || ($rep =~ /^error/)) {
               foreach my $item (@pairs) {
                   my ($key,$value)=split(/=/,$item,2);
                   $key = &unescape($key);
                   next if ($key =~ /^error: 2 /);
                   if (exists($returnhash{$key})) {
                       next if ($value < $returnhash{$key});
                   }
                   $returnhash{$key}=$value;
               }
           }
       }
       return %returnhash;
 }  }
   
 # --------------------------------------------- Try to change a user's password  # --------------------------------------------- Try to change a user's password
Line 1045  sub changepass { Line 1304  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 1183  sub spare_can_host { Line 1445  sub spare_can_host {
             $canhost = 0;              $canhost = 0;
         }          }
     }      }
       if ($canhost) {
           if (ref($defdomdefaults{'offloadoth'}) eq 'HASH') {
               if ($defdomdefaults{'offloadoth'}{$try_server}) {
                   unless (&shared_institution($udom,$try_server)) {
                       $canhost = 0;
                   }
               }
           }
       }
     if (($canhost) && ($uint_dom)) {      if (($canhost) && ($uint_dom)) {
         my @intdoms;          my @intdoms;
         my $internet_names = &get_internet_names($try_server);          my $internet_names = &get_internet_names($try_server);
Line 1279  sub get_lonbalancer_config { Line 1550  sub get_lonbalancer_config {
 }  }
   
 sub check_loadbalancing {  sub check_loadbalancing {
     my ($uname,$udom) = @_;      my ($uname,$udom,$caller) = @_;
     my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom,      my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom,
         $rule_in_effect,$offloadto,$otherserver);          $rule_in_effect,$offloadto,$otherserver,$setcookie,$dom_balancers);
     my $lonhost = $perlvar{'lonHostID'};      my $lonhost = $perlvar{'lonHostID'};
     my @hosts = &current_machine_ids();      my @hosts = &current_machine_ids();
     my $uprimary_id = &Apache::lonnet::domain($udom,'primary');      my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
Line 1308  sub check_loadbalancing { Line 1579  sub check_loadbalancing {
         }          }
     }      }
     if (ref($result) eq 'HASH') {      if (ref($result) eq 'HASH') {
         ($is_balancer,$currtargets,$currrules) =           ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers) =
             &check_balancer_result($result,@hosts);              &check_balancer_result($result,@hosts);
         if ($is_balancer) {          if ($is_balancer) {
             if (ref($currrules) eq 'HASH') {              if (ref($currrules) eq 'HASH') {
Line 1369  sub check_loadbalancing { Line 1640  sub check_loadbalancing {
             }              }
         }          }
         if (ref($result) eq 'HASH') {          if (ref($result) eq 'HASH') {
             ($is_balancer,$currtargets,$currrules) =               ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers) =
                 &check_balancer_result($result,@hosts);                  &check_balancer_result($result,@hosts);
             if ($is_balancer) {              if ($is_balancer) {
                 if (ref($currrules) eq 'HASH') {                  if (ref($currrules) eq 'HASH') {
Line 1401  sub check_loadbalancing { Line 1672  sub check_loadbalancing {
     if ($domneedscache) {      if ($domneedscache) {
         &do_cache_new('loadbalancing',$domneedscache,$is_balancer,$cachetime);          &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 1430  sub check_loadbalancing { Line 1701  sub check_loadbalancing {
                 }                  }
             }              }
         }          }
         if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) {          unless ($caller eq 'login') {
             $is_balancer = 0;              if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) {
             if ($uname ne '' && $udom ne '') {                  $is_balancer = 0;
                 if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {                  if ($uname ne '' && $udom ne '') {
                                           if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {
                     &appenv({'user.loadbalexempt'     => $lonhost,                            &appenv({'user.loadbalexempt'     => $lonhost,
                              'user.loadbalcheck.time' => time});                                   'user.loadbalcheck.time' => time});
                       }
                 }                  }
             }              }
         }          }
     }      }
     return ($is_balancer,$otherserver);      if (($is_balancer) && (!$homeintdom)) {
           undef($setcookie);
       }
       return ($is_balancer,$otherserver,$setcookie,$offloadto,$dom_balancers);
 }  }
   
 sub check_balancer_result {  sub check_balancer_result {
     my ($result,@hosts) = @_;      my ($result,@hosts) = @_;
     my ($is_balancer,$currtargets,$currrules);      my ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers);
     if (ref($result) eq 'HASH') {      if (ref($result) eq 'HASH') {
         if ($result->{'lonhost'} ne '') {          if ($result->{'lonhost'} ne '') {
             my $currbalancer = $result->{'lonhost'};              my $currbalancer = $result->{'lonhost'};
Line 1455  sub check_balancer_result { Line 1730  sub check_balancer_result {
                 $currtargets = $result->{'targets'};                  $currtargets = $result->{'targets'};
                 $currrules = $result->{'rules'};                  $currrules = $result->{'rules'};
             }              }
               $dom_balancers = $currbalancer;
         } else {          } else {
             foreach my $key (keys(%{$result})) {              if (keys(%{$result})) {
                 if (($key ne '') && (grep(/^\Q$key\E$/,@hosts)) &&                  foreach my $key (keys(%{$result})) {
                     (ref($result->{$key}) eq 'HASH')) {                      if (($key ne '') && (grep(/^\Q$key\E$/,@hosts)) &&
                     $is_balancer = 1;                          (ref($result->{$key}) eq 'HASH')) {
                     $currrules = $result->{$key}{'rules'};                          $is_balancer = 1;
                     $currtargets = $result->{$key}{'targets'};                          $currrules = $result->{$key}{'rules'};
                     last;                          $currtargets = $result->{$key}{'targets'};
                           $setcookie = $result->{$key}{'cookie'};
                           last;
                       }
                 }                  }
                   $dom_balancers = join(',',sort(keys(%{$result})));
             }              }
         }          }
     }      }
     return ($is_balancer,$currtargets,$currrules);      return ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers);
 }  }
   
 sub get_loadbalancer_targets {  sub get_loadbalancer_targets {
Line 1539  sub internet_dom_servers { Line 1819  sub internet_dom_servers {
     return %uniqservers;      return %uniqservers;
 }  }
   
   sub trusted_domains {
       my ($cmdtype,$calldom) = @_;
       my ($trusted,$untrusted);
       if (&domain($calldom) eq '') {
           return ($trusted,$untrusted);
       }
       unless ($cmdtype =~ /^(content|shared|enroll|coaurem|othcoau|domroles|catalog|reqcrs|msg)$/) {
           return ($trusted,$untrusted);
       }
       my $callprimary = &domain($calldom,'primary');
       my $intcalldom = &Apache::lonnet::internet_dom($callprimary);
       if ($intcalldom eq '') {
           return ($trusted,$untrusted);
       }
   
       my ($trustconfig,$cached)=&Apache::lonnet::is_cached_new('trust',$calldom);
       unless (defined($cached)) {
           my %domconfig = &Apache::lonnet::get_dom('configuration',['trust'],$calldom);
           &Apache::lonnet::do_cache_new('trust',$calldom,$domconfig{'trust'},3600);
           $trustconfig = $domconfig{'trust'};
       }
       if (ref($trustconfig)) {
           my (%possexc,%possinc,@allexc,@allinc); 
           if (ref($trustconfig->{$cmdtype}) eq 'HASH') {
               if (ref($trustconfig->{$cmdtype}->{'exc'}) eq 'ARRAY') {
                   map { $possexc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'exc'}}; 
               }
               if (ref($trustconfig->{$cmdtype}->{'inc'}) eq 'ARRAY') {
                   $possinc{$intcalldom} = 1;
                   map { $possinc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'inc'}};
               }
           }
           if (keys(%possexc)) {
               if (keys(%possinc)) {
                   foreach my $key (sort(keys(%possexc))) {
                       next if ($key eq $intcalldom);
                       unless ($possinc{$key}) {
                           push(@allexc,$key);
                       }
                   }
               } else {
                   @allexc = sort(keys(%possexc));
               }
           }
           if (keys(%possinc)) {
               $possinc{$intcalldom} = 1;
               @allinc = sort(keys(%possinc));
           }
           if ((@allexc > 0) || (@allinc > 0)) {
               my %doms_by_intdom;
               my %allintdoms = &all_host_intdom();
               my %alldoms = &all_host_domain();
               foreach my $key (%allintdoms) {
                   if (ref($doms_by_intdom{$allintdoms{$key}}) eq 'ARRAY') {
                       unless (grep(/^\Q$alldoms{$key}\E$/,@{$doms_by_intdom{$allintdoms{$key}}})) {
                           push(@{$doms_by_intdom{$allintdoms{$key}}},$alldoms{$key});
                       }
                   } else {
                       $doms_by_intdom{$allintdoms{$key}} = [$alldoms{$key}]; 
                   }
               }
               foreach my $exc (@allexc) {
                   if (ref($doms_by_intdom{$exc}) eq 'ARRAY') {
                       push(@{$untrusted},@{$doms_by_intdom{$exc}});
                   }
               }
               foreach my $inc (@allinc) {
                   if (ref($doms_by_intdom{$inc}) eq 'ARRAY') {
                       push(@{$trusted},@{$doms_by_intdom{$inc}});
                   }
               }
           }
       }
       return ($trusted,$untrusted);
   }
   
   sub will_trust {
       my ($cmdtype,$domain,$possdom) = @_;
       return 1 if ($domain eq $possdom);
       my ($trustedref,$untrustedref) = &trusted_domains($cmdtype,$possdom);
       my $willtrust; 
       if ((ref($trustedref) eq 'ARRAY') && (@{$trustedref} > 0)) {
           if (grep(/^\Q$domain\E$/,@{$trustedref})) {
               $willtrust = 1;
           }
       } elsif ((ref($untrustedref) eq 'ARRAY') && (@{$untrustedref} > 0)) {
           unless (grep(/^\Q$domain\E$/,@{$untrustedref})) {
               $willtrust = 1;
           }
       } else {
           $willtrust = 1;
       }
       return $willtrust;
   }
   
 # ---------------------- Find the homebase for a user from domain's lib servers  # ---------------------- Find the homebase for a user from domain's lib servers
   
 my %homecache;  my %homecache;
Line 1788  sub get_dom { Line 2163  sub get_dom {
         }          }
     }      }
     if ($udom && $uhome && ($uhome ne 'no_host')) {      if ($udom && $uhome && ($uhome ne 'no_host')) {
         my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);          my $rep;
           if (grep { $_ eq $uhome } &current_machine_ids()) {
               # domain information is hosted on this machine
               my $cmd = 'getdom';
               if ($namespace =~ /^enc/) {
                   $cmd = 'egetdom';
               }
               $rep = &LONCAPA::Lond::get_dom("$cmd:$udom:$namespace:$items");
           } else {
               if ($namespace =~ /^enc/) {
                   $rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome);
               } else {
                   $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
               }
           }
         my %returnhash;          my %returnhash;
         if ($rep eq '' || $rep =~ /^error: 2 /) {          if ($rep eq '' || $rep =~ /^error: 2 /) {
             return %returnhash;              return %returnhash;
Line 1832  sub put_dom { Line 2221  sub put_dom {
             $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';              $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
         }          }
         $items=~s/\&$//;          $items=~s/\&$//;
         return &reply("putdom:$udom:$namespace:$items",$uhome);          if ($namespace =~ /^enc/) {
               return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome);
           } else {
               return &reply("putdom:$udom:$namespace:$items",$uhome);
           }
     } else {      } else {
         &logthis("put_dom failed - no homeserver and/or domain");          &logthis("put_dom failed - no homeserver and/or domain");
     }      }
Line 1923  sub inst_directory_query { Line 2316  sub inst_directory_query {
     my $homeserver = &domain($udom,'primary');      my $homeserver = &domain($udom,'primary');
     my $outcome;      my $outcome;
     if ($homeserver ne '') {      if ($homeserver ne '') {
           unless ($homeserver eq $perlvar{'lonHostID'}) {
               if ($srch->{'srchby'} eq 'email') {
                   my $lcrev = &get_server_loncaparev($udom,$homeserver);
                   my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
                   if (($major eq '' && $minor eq '') || ($major < 2) ||
                       (($major == 2) && ($minor < 12))) {
                       return;
                   }
               }
           }
  my $queryid=&reply("querysend:instdirsearch:".   my $queryid=&reply("querysend:instdirsearch:".
    &escape($srch->{'srchby'}).':'.     &escape($srch->{'srchby'}).':'.
    &escape($srch->{'srchterm'}).':'.     &escape($srch->{'srchterm'}).':'.
    &escape($srch->{'srchtype'}),$homeserver);     &escape($srch->{'srchtype'}),$homeserver);
  my $host=&hostname($homeserver);   my $host=&hostname($homeserver);
  if ($queryid !~/^\Q$host\E\_/) {   if ($queryid !~/^\Q$host\E\_/) {
     &logthis('instituional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom);      &logthis('institutional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.' in domain '.$udom);
     return;      return;
  }   }
  my $response = &get_query_reply($queryid);   my $response = &get_query_reply($queryid);
Line 1964  sub usersearch { Line 2367  sub usersearch {
     my $query = 'usersearch';      my $query = 'usersearch';
     foreach my $tryserver (keys(%libserv)) {      foreach my $tryserver (keys(%libserv)) {
         if (&host_domain($tryserver) eq $dom) {          if (&host_domain($tryserver) eq $dom) {
               unless ($tryserver eq $perlvar{'lonHostID'}) {
                   if ($srch->{'srchby'} eq 'email') {
                       my $lcrev = &get_server_loncaparev($dom,$tryserver);
                       my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
                       next if (($major eq '' && $minor eq '') || ($major < 2) ||
                                (($major == 2) && ($minor < 12)));
                   }
               }
             my $host=&hostname($tryserver);              my $host=&hostname($tryserver);
             my $queryid=              my $queryid=
                 &reply("querysend:".&escape($query).':'.                  &reply("querysend:".&escape($query).':'.
Line 2202  sub get_domain_defaults { Line 2613  sub get_domain_defaults {
                                   'requestcourses','inststatus',                                    'requestcourses','inststatus',
                                   'coursedefaults','usersessions',                                    'coursedefaults','usersessions',
                                   'requestauthor','selfenrollment',                                    'requestauthor','selfenrollment',
                                   'coursecategories'],$domain);                                    'coursecategories','ssl','autoenroll',
                                     'trust','helpsettings','wafproxy'],$domain);
     my @coursetypes = ('official','unofficial','community','textbook','placement');      my @coursetypes = ('official','unofficial','community','textbook','placement');
     if (ref($domconfig{'defaults'}) eq 'HASH') {      if (ref($domconfig{'defaults'}) eq 'HASH') {
         $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};           $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; 
Line 2211  sub get_domain_defaults { Line 2623  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 2278  sub get_domain_defaults { Line 2693  sub get_domain_defaults {
         } elsif ($domconfig{'coursedefaults'}{'canclone'}) {          } elsif ($domconfig{'coursedefaults'}{'canclone'}) {
             $domdefaults{'canclone'}=$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') {
         if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') {          if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') {
Line 2289  sub get_domain_defaults { Line 2707  sub get_domain_defaults {
         if (ref($domconfig{'usersessions'}{'offloadnow'}) eq 'HASH') {          if (ref($domconfig{'usersessions'}{'offloadnow'}) eq 'HASH') {
             $domdefaults{'offloadnow'} = $domconfig{'usersessions'}{'offloadnow'};              $domdefaults{'offloadnow'} = $domconfig{'usersessions'}{'offloadnow'};
         }          }
           if (ref($domconfig{'usersessions'}{'offloadoth'}) eq 'HASH') {
               $domdefaults{'offloadoth'} = $domconfig{'usersessions'}{'offloadoth'};
           }
     }      }
     if (ref($domconfig{'selfenrollment'}) eq 'HASH') {      if (ref($domconfig{'selfenrollment'}) eq 'HASH') {
         if (ref($domconfig{'selfenrollment'}{'admin'}) eq 'HASH') {          if (ref($domconfig{'selfenrollment'}{'admin'}) eq 'HASH') {
Line 2321  sub get_domain_defaults { Line 2742  sub get_domain_defaults {
     if (ref($domconfig{'coursecategories'}) eq 'HASH') {      if (ref($domconfig{'coursecategories'}) eq 'HASH') {
         $domdefaults{'catauth'} = 'std';          $domdefaults{'catauth'} = 'std';
         $domdefaults{'catunauth'} = 'std';          $domdefaults{'catunauth'} = 'std';
         if ($domconfig{'coursecategories'}{'auth'}) {           if ($domconfig{'coursecategories'}{'auth'}) {
             $domdefaults{'catauth'} = $domconfig{'coursecategories'}{'auth'};              $domdefaults{'catauth'} = $domconfig{'coursecategories'}{'auth'};
         }          }
         if ($domconfig{'coursecategories'}{'unauth'}) {          if ($domconfig{'coursecategories'}{'unauth'}) {
             $domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'};              $domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'};
         }          }
     }      }
       if (ref($domconfig{'ssl'}) eq 'HASH') {
           if (ref($domconfig{'ssl'}{'replication'}) eq 'HASH') {
               $domdefaults{'replication'} = $domconfig{'ssl'}{'replication'};
           }
           if (ref($domconfig{'ssl'}{'connto'}) eq 'HASH') {
               $domdefaults{'connect'} = $domconfig{'ssl'}{'connto'};
           }
           if (ref($domconfig{'ssl'}{'connfrom'}) eq 'HASH') {
               $domdefaults{'connect'} = $domconfig{'ssl'}{'connfrom'};
           }
       }
       if (ref($domconfig{'trust'}) eq 'HASH') {
           my @prefixes = qw(content shared enroll othcoau coaurem domroles catalog reqcrs msg);
           foreach my $prefix (@prefixes) {
               if (ref($domconfig{'trust'}{$prefix}) eq 'HASH') {
                   $domdefaults{'trust'.$prefix} = $domconfig{'trust'}{$prefix};
               }
           }
       }
       if (ref($domconfig{'autoenroll'}) eq 'HASH') {
           $domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'};
       }
       if (ref($domconfig{'helpsettings'}) eq 'HASH') {
           $domdefaults{'submitbugs'} = $domconfig{'helpsettings'}{'submitbugs'};
           if (ref($domconfig{'helpsettings'}{'adhoc'}) eq 'HASH') {
               $domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'};
           }
       }
       if (ref($domconfig{'wafproxy'}) eq 'HASH') {
           foreach my $item ('ipheader','trusted','vpnint','vpnext') {
               if ($domconfig{'wafproxy'}{$item}) {
                   $domdefaults{'waf_'.$item} = $domconfig{'wafproxy'}{$item};
               }
           }
       } 
     &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;
   }
   
 sub course_portal_url {  sub course_portal_url {
     my ($cnum,$cdom) = @_;      my ($cnum,$cdom) = @_;
     my $chome = &homeserver($cnum,$cdom);      my $chome = &homeserver($cnum,$cdom);
Line 2348  sub course_portal_url { Line 2863  sub course_portal_url {
     return $firsturl;      return $firsturl;
 }  }
   
   # --------------------------------------------- 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 2584  sub make_key { Line 3122  sub make_key {
 sub devalidate_cache_new {  sub devalidate_cache_new {
     my ($name,$id,$debug) = @_;      my ($name,$id,$debug) = @_;
     if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }      if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }
       my $remembered_id=$name.':'.$id;
     $id=&make_key($name,$id);      $id=&make_key($name,$id);
     $memcache->delete($id);      $memcache->delete($id);
     delete($remembered{$id});      delete($remembered{$remembered_id});
     delete($accessed{$id});      delete($accessed{$remembered_id});
 }  }
   
 sub is_cached_new {  sub is_cached_new {
     my ($name,$id,$debug) = @_;      my ($name,$id,$debug) = @_;
     $id=&make_key($name,$id);      my $remembered_id=$name.':'.$id; # this is to avoid make_key (which is slow) whenever possible
     if (exists($remembered{$id})) {      if (exists($remembered{$remembered_id})) {
  if ($debug) { &Apache::lonnet::logthis("Early return $id of $remembered{$id} "); }   if ($debug) { &Apache::lonnet::logthis("Early return $remembered_id of $remembered{$remembered_id} "); }
  $accessed{$id}=[&gettimeofday()];   $accessed{$remembered_id}=[&gettimeofday()];
  $hits++;   $hits++;
  return ($remembered{$id},1);   return ($remembered{$remembered_id},1);
     }      }
       $id=&make_key($name,$id);
     my $value = $memcache->get($id);      my $value = $memcache->get($id);
     if (!(defined($value))) {      if (!(defined($value))) {
  if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }   if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }
Line 2608  sub is_cached_new { Line 3148  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 2630  sub do_cache_new { Line 3171  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 2852  sub repcopy { Line 3393  sub repcopy {
    mkdir($path,0777);     mkdir($path,0777);
                }                 }
            }             }
            my $ua=new LWP::UserAgent;  
            my $request=new HTTP::Request('GET',"$remoteurl");             my $request=new HTTP::Request('GET',"$remoteurl");
            my $response=$ua->request($request,$transname);             my $response;
              if ($remoteurl =~ m{/raw/}) {
                  $response=&LONCAPA::LWPReq::makerequest($home,$request,$transname,\%perlvar,'',0,1);
              } else {
                  $response=&LONCAPA::LWPReq::makerequest($home,$request,$transname,\%perlvar,'',1);
              }
            if ($response->is_error()) {             if ($response->is_error()) {
        unlink($transname);         unlink($transname);
                my $message=$response->status_line;                 my $message=$response->status_line;
Line 2864  sub repcopy { Line 3409  sub repcopy {
            } else {             } else {
        if ($remoteurl!~/\.meta$/) {         if ($remoteurl!~/\.meta$/) {
                   my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');                    my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
                   my $mresponse=$ua->request($mrequest,$filename.'.meta');                    my $mresponse;
                     if ($remoteurl =~ m{/raw/}) {
                         $mresponse = &LONCAPA::LWPReq::makerequest($home,$mrequest,$filename.'.meta',\%perlvar,'',0,1);
                     } else {
                         $mresponse = &LONCAPA::LWPReq::makerequest($home,$mrequest,$filename.'.meta',\%perlvar,'',1);
                     }
                   if ($mresponse->is_error()) {                    if ($mresponse->is_error()) {
       unlink($filename.'.meta');        unlink($filename.'.meta');
                       &logthis(                        &logthis(
Line 2878  sub repcopy { Line 3428  sub repcopy {
     }      }
 }  }
   
   # ------------------------------------------------- Unsubscribe from a resource
   
   sub unsubscribe {
       my ($fname) = @_;
       my $answer;
       if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return $answer; }
       $fname=~s/[\n\r]//g;
       my $author=$fname;
       $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
       my ($udom,$uname)=split(/\//,$author);
       my $home=homeserver($uname,$udom);
       if ($home eq 'no_host') {
           $answer = 'no_host';
       } elsif (grep { $_ eq $home } &current_machine_ids()) {
           $answer = 'home';
       } else {
           my $defdom = $perlvar{'lonDefDomain'};
           if (&will_trust('content',$defdom,$udom)) {
               $answer = reply("unsub:$fname",$home);
           } else {
               $answer = 'untrusted';
           }
       }
       return $answer;
   }
   
 # ------------------------------------------------ Get server side include body  # ------------------------------------------------ Get server side include body
 sub ssi_body {  sub ssi_body {
     my ($filelink,%form)=@_;      my ($filelink,%form)=@_;
Line 2927  sub absolute_url { Line 3503  sub absolute_url {
 sub ssi {  sub ssi {
   
     my ($fn,%form)=@_;      my ($fn,%form)=@_;
     my $ua=new LWP::UserAgent;  
     my $request;      my $request;
   
     $form{'no_update_last_known'}=1;      $form{'no_update_last_known'}=1;
Line 2945  sub ssi { Line 3520  sub ssi {
     }      }
   
     $request->header(Cookie => $ENV{'HTTP_COOKIE'});      $request->header(Cookie => $ENV{'HTTP_COOKIE'});
     my $response= $ua->request($request);      my $lonhost = $perlvar{'lonHostID'};
     my $content = $response->content;      my $islocal;
       if (($env{'request.course.id'}) &&
           ($form{'grade_courseid'} eq $env{'request.course.id'}) &&
           ($form{'grade_username'} ne '') && ($form{'grade_domain'} ne '') &&
           ($form{'grade_symb'} ne '') &&
           (&Apache::lonnet::allowed('mgr',$env{'request.course.id'}.
                                    ($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:'')))) {
           $islocal = 1;
       }
       my $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,
                                                   '','','',$islocal);
   
     if (wantarray) {      if (wantarray) {
  return ($content, $response);   return ($response->content, $response);
     } else {      } else {
  return $content;   return $response->content;
     }      }
 }  }
   
 sub externalssi {  sub externalssi {
     my ($url)=@_;      my ($url)=@_;
     my $ua=new LWP::UserAgent;  
     my $request=new HTTP::Request('GET',$url);      my $request=new HTTP::Request('GET',$url);
     my $response=$ua->request($request);      my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar);
     if (wantarray) {      if (wantarray) {
         return ($response->content, $response);          return ($response->content, $response);
     } else {      } else {
Line 2968  sub externalssi { Line 3551  sub externalssi {
     }      }
 }  }
   
   
   # If the local copy of a replicated resource is outdated, trigger a  
   # connection from the homeserver to flush the delayed queue. If no update 
   # happens, remove local copies of outdated resource (and corresponding
   # metadata file).
   
   sub remove_stale_resfile {
       my ($url) = @_;
       my $removed;
       if ($url=~m{^/res/($match_domain)/($match_username)/}) {
           my $audom = $1;
           my $auname = $2;
           unless (($url =~ /\.\d+\.\w+$/) || ($url =~ m{^/res/lib/templates/})) {
               my $homeserver = &homeserver($auname,$audom);
               unless (($homeserver eq 'no_host') ||
                       (grep { $_ eq $homeserver } &current_machine_ids())) {
                   my $fname = &filelocation('',$url);
                   if (-e $fname) {
                       my $hostname = &hostname($homeserver);
                       if ($hostname) {
                           my $protocol = $protocol{$homeserver};
                           $protocol = 'http' if ($protocol ne 'https');
                           my $uri = &declutter($url);
                           my $request=new HTTP::Request('HEAD',$protocol.'://'.$hostname.'/raw/'.$uri);
                           my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,5,0,1);
                           if ($response->is_success()) {
                               my $remmodtime = &HTTP::Date::str2time( $response->header('Last-modified') );
                               my $locmodtime = (stat($fname))[9];
                               if ($locmodtime < $remmodtime) {
                                   my $stale;
                                   my $answer = &reply('pong',$homeserver);
                                   if ($answer eq $homeserver.':'.$perlvar{'lonHostID'}) {
                                       sleep(0.2);
                                       $locmodtime = (stat($fname))[9];
                                       if ($locmodtime < $remmodtime) {
                                           my $posstransfer = $fname.'.in.transfer';
                                           if ((-e $posstransfer) && ($remmodtime < (stat($posstransfer))[9])) {
                                               $removed = 1;
                                           } else {
                                               $stale = 1;
                                           }
                                       } else {
                                           $removed = 1;
                                       }
                                   } else {
                                       $stale = 1;
                                   }
                                   if ($stale) {
                                       if (unlink($fname)) {
                                           if ($uri!~/\.meta$/) {
                                               if (-e $fname.'.meta') {
                                                   unlink($fname.'.meta');
                                               }
                                           }
                                           my $unsubresult = &unsubscribe($fname);
                                           unless ($unsubresult eq 'ok') {
                                               &logthis("no unsub of $fname from $homeserver, reason: $unsubresult");
                                           }
                                           $removed = 1;
                                       }
                                   }
                               }
                           }
                       }
                   }
               }
           }
       }
       return $removed;
   }
   
 # -------------------------------- Allow a /uploaded/ URI to be vouched for  # -------------------------------- Allow a /uploaded/ URI to be vouched for
   
 sub allowuploaded {  sub allowuploaded {
Line 3106  sub can_edit_resource { Line 3760  sub can_edit_resource {
                         $forceedit = 1;                          $forceedit = 1;
                     }                      }
                     $cfile = $resurl;                      $cfile = $resurl;
                 } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/exttools?$}) {                  } elsif (($resurl =~ m{^/ext/}) && ($symb ne '')) {
                       my ($map,$id,$res) = &decode_symb($symb);
                       if ($map =~ /\.page$/) {
                           $incourse = 1;
                           if ($env{'form.forceedit'}) {
                               $forceview = 1;
                               $cfile = $map;
                           } else {
                               $forceedit = 1;
                               $cfile =  '/adm/wrapper'.$resurl;
                           }
                       }
                   } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) {
                     $incourse = 1;                      $incourse = 1;
                     if ($env{'form.forceedit'}) {                      if ($env{'form.forceedit'}) {
                         $forceview = 1;                          $forceview = 1;
Line 3131  sub can_edit_resource { Line 3797  sub can_edit_resource {
                     $cfile = $template;                      $cfile = $template;
                 }                  }
             } elsif (($resurl =~ m{^/adm/wrapper/ext/}) && ($env{'form.folderpath'} =~ /^supplemental/)) {              } elsif (($resurl =~ m{^/adm/wrapper/ext/}) && ($env{'form.folderpath'} =~ /^supplemental/)) {
                     $incourse = 1;                  $incourse = 1;
                     if ($env{'form.forceedit'}) {                  if ($env{'form.forceedit'}) {
                         $forceview = 1;                      $forceview = 1;
                     } else {                  } else {
                         $forceedit = 1;                      $forceedit = 1;
                     }                  }
                     $cfile = $resurl;                  $cfile = $resurl;
             } elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/exttools?$}) && ($env{'form.folderpath'} =~ /^supplemental/)) {              } elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($env{'form.folderpath'} =~ /^supplemental/)) {
                 $incourse = 1;                  $incourse = 1;
                 if ($env{'form.forceedit'}) {                  if ($env{'form.forceedit'}) {
                     $forceview = 1;                      $forceview = 1;
Line 3156  sub can_edit_resource { Line 3822  sub can_edit_resource {
                 } else {                  } else {
                     $cfile = $env{'form.suppurl'};                      $cfile = $env{'form.suppurl'};
                     my $escfile = &unescape($cfile);                      my $escfile = &unescape($cfile);
                     if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/exttools?$}) {                      if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) {
                         $cfile = '/adm/wrapper'.$escfile;                          $cfile = '/adm/wrapper'.$escfile;
                     } else {                      } else {
                         $escfile =~ s{^http://}{};                          $escfile =~ s{^http://}{};
Line 3317  sub process_coursefile { Line 3983  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 3375  sub store_edited_file { Line 4041  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 3400  sub clean_filename { Line 4066  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 3407  sub clean_filename { Line 4076  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 3449  sub resizeImage { Line 4119  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 3478  sub userfileupload { Line 4151  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 3491  sub userfileupload { Line 4172  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 3526  sub userfileupload { Line 4207  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 3601  sub finishuserfileupload { Line 4282  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 3645  sub finishuserfileupload { Line 4326  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 3654  sub finishuserfileupload { Line 4335  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 3893  sub embedded_dependency { Line 4578  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 4043  sub flushcourselogs { Line 4968  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 4058  sub flushcourselogs { Line 4983  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 4110  sub courseacclog { Line 5044  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 4181  sub userrolelog { Line 5119  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 4408  sub get_my_roles { Line 5346  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 4421  sub postannounce { Line 5548  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 4648  sub get_domain_roles { Line 5775  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 4703  sub set_first_access { Line 5845  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 4716  sub set_first_access { Line 5863  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;
     }      }
Line 4977  sub tmpreset { Line 6130  sub tmpreset {
   if (!$domain) { $domain=$env{'user.domain'}; }    if (!$domain) { $domain=$env{'user.domain'}; }
   if (!$stuname) { $stuname=$env{'user.name'}; }    if (!$stuname) { $stuname=$env{'user.name'}; }
   if ($domain eq 'public' && $stuname eq 'public') {    if ($domain eq 'public' && $stuname eq 'public') {
       $stuname=$ENV{'REMOTE_ADDR'};        $stuname=&get_requestor_ip();
   }    }
   my $path=LONCAPA::tempdir();    my $path=LONCAPA::tempdir();
   my %hash;    my %hash;
Line 5014  sub tmpstore { Line 6167  sub tmpstore {
   if (!$domain) { $domain=$env{'user.domain'}; }    if (!$domain) { $domain=$env{'user.domain'}; }
   if (!$stuname) { $stuname=$env{'user.name'}; }    if (!$stuname) { $stuname=$env{'user.name'}; }
   if ($domain eq 'public' && $stuname eq 'public') {    if ($domain eq 'public' && $stuname eq 'public') {
       $stuname=$ENV{'REMOTE_ADDR'};        $stuname=&get_requestor_ip();
   }    }
   my $now=time;    my $now=time;
   my %hash;    my %hash;
Line 5058  sub tmprestore { Line 6211  sub tmprestore {
   if (!$domain) { $domain=$env{'user.domain'}; }    if (!$domain) { $domain=$env{'user.domain'}; }
   if (!$stuname) { $stuname=$env{'user.name'}; }    if (!$stuname) { $stuname=$env{'user.name'}; }
   if ($domain eq 'public' && $stuname eq 'public') {    if ($domain eq 'public' && $stuname eq 'public') {
       $stuname=$ENV{'REMOTE_ADDR'};        $stuname=&get_requestor_ip();
   }    }
   my %returnhash;    my %returnhash;
   $namespace=~s/\//\_/g;    $namespace=~s/\//\_/g;
Line 5114  sub store { Line 6267  sub store {
     }      }
     if (!$home) { $home=$env{'user.home'}; }      if (!$home) { $home=$env{'user.home'}; }
   
     $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};      $$storehash{'ip'}=&get_requestor_ip();
     $$storehash{'host'}=$perlvar{'lonHostID'};      $$storehash{'host'}=$perlvar{'lonHostID'};
   
     my $namevalue='';      my $namevalue='';
Line 5150  sub cstore { Line 6303  sub cstore {
     }      }
     if (!$home) { $home=$env{'user.home'}; }      if (!$home) { $home=$env{'user.home'}; }
   
     $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};      $$storehash{'ip'}=&get_requestor_ip();
     $$storehash{'host'}=$perlvar{'lonHostID'};      $$storehash{'host'}=$perlvar{'lonHostID'};
   
     my $namevalue='';      my $namevalue='';
Line 5502  sub rolesinit { Line 6655  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 5540  sub custom_roleprivs { Line 6694  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 5548  sub custom_roleprivs { Line 6706  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 5582  sub set_userprivs { Line 6782  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 5629  sub set_userprivs { Line 6830  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 5637  sub set_userprivs { Line 6839  sub set_userprivs {
  }   }
         $userroles->{'user.priv.'.$role} = $thesestr;          $userroles->{'user.priv.'.$role} = $thesestr;
     }      }
     return ($author,$adv);      return ($author,$adv,$rar);
 }  }
   
 sub role_status {  sub role_status {
Line 5682  sub role_status { Line 6884  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 5760  sub delete_env_groupprivs { Line 6963  sub delete_env_groupprivs {
 }  }
   
 sub check_adhoc_privs {  sub check_adhoc_privs {
     my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller) = @_;      my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller,$sec) = @_;
     my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;      my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;
       if ($sec) {
           $cckey .= '/'.$sec;
       } 
     my $setprivs;      my $setprivs;
     if ($env{$cckey}) {      if ($env{$cckey}) {
         my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);          my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);
         &role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);          &role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);
         unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) {          unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) {
             &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);              &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller,$sec);
             $setprivs = 1;              $setprivs = 1;
         }          }
     } else {      } else {
         &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);          &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller,$sec);
         $setprivs = 1;          $setprivs = 1;
     }      }
     return $setprivs;      return $setprivs;
 }  }
   
 sub set_adhoc_privileges {  sub set_adhoc_privileges {
 # role can be cc or ca  # role can be cc, ca, or cr/<dom>/<dom>-domainconfig/role
     my ($dcdom,$pickedcourse,$role,$caller) = @_;      my ($dcdom,$pickedcourse,$role,$caller,$sec) = @_;
     my $area = '/'.$dcdom.'/'.$pickedcourse;      my $area = '/'.$dcdom.'/'.$pickedcourse;
       if ($sec ne '') {
           $area .= '/'.$sec;
       }
     my $spec = $role.'.'.$area;      my $spec = $role.'.'.$area;
     my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'},      my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'},
                                   $env{'user.name'},1);                                    $env{'user.name'},1);
     my %ccrole = ();      my %rolehash = ();
     &standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area);      if ($role =~ m{^\Qcr/$dcdom/$dcdom\E\-domainconfig/(\w+)$}) {
     my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole);          my $rolename = $1;
           &custom_roleprivs(\%rolehash,$role,$dcdom,$pickedcourse,$spec,$area);
           my %domdef = &get_domain_defaults($dcdom);
           if (ref($domdef{'adhocroles'}) eq 'HASH') {
               if (ref($domdef{'adhocroles'}{$rolename}) eq 'HASH') {
                   &appenv({'request.role.desc' => $domdef{'adhocroles'}{$rolename}{'desc'},});
               }
           }
       } else {
           &standard_roleprivs(\%rolehash,$role,$dcdom,$spec,$pickedcourse,$area);
       }
       my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%rolehash);
     &appenv(\%userroles,[$role,'cm']);      &appenv(\%userroles,[$role,'cm']);
     &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);      &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec);
     unless ($caller eq 'constructaccess' && $env{'request.course.id'}) {      unless (($caller eq 'constructaccess' && $env{'request.course.id'}) ||
               ($caller eq 'tiny')) {
         &appenv( {'request.role'        => $spec,          &appenv( {'request.role'        => $spec,
                   'request.role.domain' => $dcdom,                    'request.role.domain' => $dcdom,
                   'request.course.sec'  => ''                    'request.course.sec'  => $sec,
                  }                   }
                );                 );
         my $tadv=0;          my $tadv=0;
Line 5942  sub currentdump { Line 7163  sub currentdump {
    #     #
    my %returnhash=();     my %returnhash=();
    #     #
    if ($rep eq "unknown_cmd") {      if ($rep eq 'unknown_cmd') {
        # an old lond will not know currentdump         # an old lond will not know currentdump
        # Do a dump and make it look like a currentdump         # Do a dump and make it look like a currentdump
        my @tmp = &dumpstore($courseid,$sdom,$sname,'.');         my @tmp = &dumpstore($courseid,$sdom,$sname,'.');
Line 6077  sub putstore { Line 7298  sub putstore {
        foreach my $key (keys(%{$storehash})) {         foreach my $key (keys(%{$storehash})) {
            $namevalue.=&escape($key).'='.&freeze_escape($storehash->{$key}).'&';             $namevalue.=&escape($key).'='.&freeze_escape($storehash->{$key}).'&';
        }         }
        $namevalue .= 'ip='.&escape($ENV{'REMOTE_ADDR'}).         my $ip = &get_requestor_ip();
          $namevalue .= 'ip='.&escape($ip).
                      '&host='.&escape($perlvar{'lonHostID'}).                       '&host='.&escape($perlvar{'lonHostID'}).
                      '&version='.$esc_v.                       '&version='.$esc_v.
                      '&by='.&escape($env{'user.name'}.':'.$env{'user.domain'});                       '&by='.&escape($env{'user.name'}.':'.$env{'user.domain'});
Line 6176  sub tmpget { Line 7398  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 6561  sub usertools_access { Line 7785  sub usertools_access {
                       community  => 1,                        community  => 1,
                       textbook   => 1,                        textbook   => 1,
                       placement  => 1,                        placement  => 1,
                         lti        => 1,
                  );                   );
     } elsif ($context eq 'requestauthor') {      } elsif ($context eq 'requestauthor') {
         %tools = (          %tools = (
Line 6757  sub is_advanced_user { Line 7982  sub is_advanced_user {
 }  }
   
 sub check_can_request {  sub check_can_request {
     my ($dom,$can_request,$request_domains) = @_;      my ($dom,$can_request,$request_domains,$uname,$udom) = @_;
     my $canreq = 0;      my $canreq = 0;
       if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {
           $uname = $env{'user.name'};
           $udom = $env{'user.domain'};
       }
     my ($types,$typename) = &Apache::loncommon::course_types();      my ($types,$typename) = &Apache::loncommon::course_types();
     my @options = ('approval','validate','autolimit');      my @options = ('approval','validate','autolimit');
     my $optregex = join('|',@options);      my $optregex = join('|',@options);
     if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) {      if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) {
         foreach my $type (@{$types}) {          foreach my $type (@{$types}) {
             if (&usertools_access($env{'user.name'},              if (&usertools_access($uname,$udom,$type,undef,
                                   $env{'user.domain'},                                    'requestcourses')) {
                                   $type,undef,'requestcourses')) {  
                 $canreq ++;                  $canreq ++;
                 if (ref($request_domains) eq 'HASH') {                  if (ref($request_domains) eq 'HASH') {
                     push(@{$request_domains->{$type}},$env{'user.domain'});                      push(@{$request_domains->{$type}},$udom);
                 }                  }
                 if ($dom eq $env{'user.domain'}) {                  if ($dom eq $udom) {
                     $can_request->{$type} = 1;                      $can_request->{$type} = 1;
                 }                  }
             }              }
             if ($env{'environment.reqcrsotherdom.'.$type} ne '') {              if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '') &&
                   ($env{'environment.reqcrsotherdom.'.$type} ne '')) {
                 my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type});                  my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type});
                 if (@curr > 0) {                  if (@curr > 0) {
                     foreach my $item (@curr) {                      foreach my $item (@curr) {
Line 6792  sub check_can_request { Line 8021  sub check_can_request {
                             }                              }
                         }                          }
                     }                      }
                     unless($dom eq $env{'user.domain'}) {                      unless ($dom eq $env{'user.domain'}) {
                         $canreq ++;                          $canreq ++;
                         if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) {                          if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) {
                             $can_request->{$type} = 1;                              $can_request->{$type} = 1;
Line 6857  sub customaccess { Line 8086  sub customaccess {
 # ------------------------------------------------- Check for a user privilege  # ------------------------------------------------- Check for a user privilege
   
 sub allowed {  sub allowed {
     my ($priv,$uri,$symb,$role,$clientip,$noblockcheck)=@_;      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 6874  sub allowed { Line 8103  sub allowed {
   
     if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }      if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
 # Free bre access to adm and meta resources  # Free bre access to adm and meta resources
     if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$}))       if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|viewclasslist|aboutme|ext\.tool)$})) 
  || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) ))    || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) 
  && ($priv eq 'bre')) {   && ($priv eq 'bre')) {
  return 'F';   return 'F';
Line 6922  sub allowed { Line 8151  sub allowed {
 # Free bre to public access  # Free bre to public access
   
     if ($priv eq 'bre') {      if ($priv eq 'bre') {
         my $copyright=&metadata($uri,'copyright');          my $copyright;
           unless ($uri =~ /ext\.tool/) {
               $copyright=&metadata($uri,'copyright');
           }
  if (($copyright eq 'public') && (!$env{'request.course.id'})) {    if (($copyright eq 'public') && (!$env{'request.course.id'})) { 
            return 'F';              return 'F'; 
         }          }
Line 7039  sub allowed { Line 8271  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 7053  sub allowed { Line 8311  sub allowed {
             if ($env{'user.priv.'.$env{'request.role'}.'./'}              if ($env{'user.priv.'.$env{'request.role'}.'./'}
                   =~/\Q$priv\E\&([^\:]*)/) {                    =~/\Q$priv\E\&([^\:]*)/) {
                 my $value = $1;                  my $value = $1;
                 if ($noblockcheck) {                  my $deeplinkblock = &deeplink_check($priv,$symb,$uri);
                   if ($deeplinkblock) {
                       $thisallowed='D';
                   } elsif ($noblockcheck) {
                     $thisallowed.=$value;                      $thisallowed.=$value;
                 } else {                  } else {
                     my @blockers = &has_comm_blocking($priv,$symb,$uri);                      my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);
                     if (@blockers > 0) {                      if (@blockers > 0) {
                         $thisallowed = 'B';                          $thisallowed = 'B';
                     } else {                      } else {
Line 7073  sub allowed { Line 8334  sub allowed {
                     $refuri=&declutter($refuri);                      $refuri=&declutter($refuri);
                     my ($match) = &is_on_map($refuri);                      my ($match) = &is_on_map($refuri);
                     if ($match) {                      if ($match) {
                         if ($noblockcheck) {                          my $deeplinkblock = &deeplink_check($priv,$symb,$refuri);
                           if ($deeplinkblock) {
                               $thisallowed='D';
                           } elsif ($noblockcheck) {
                             $thisallowed='F';                              $thisallowed='F';
                         } else {                          } else {
                             my @blockers = &has_comm_blocking($priv,$symb,$refuri);                              my @blockers = &has_comm_blocking($priv,'',$refuri,'',1);
                             if (@blockers > 0) {                              if (@blockers > 0) {
                                 $thisallowed = 'B';                                  $thisallowed = 'B';
                             } else {                              } else {
Line 7123  sub allowed { Line 8387  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 7139  sub allowed { Line 8413  sub allowed {
                    if ($noblockcheck) {                     if ($noblockcheck) {
                        $thisallowed.=$value;                         $thisallowed.=$value;
                    } else {                     } else {
                        my @blockers = &has_comm_blocking($priv,$symb,$uri);                         my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);
                        if (@blockers > 0) {                         if (@blockers > 0) {
                            $thisallowed = 'B';                             $thisallowed = 'B';
                        } else {                         } else {
Line 7152  sub allowed { Line 8426  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 7178  sub allowed { Line 8452  sub allowed {
                   =~/\Q$priv\E\&([^\:]*)/) {                    =~/\Q$priv\E\&([^\:]*)/) {
                   my $value = $1;                    my $value = $1;
                   if ($priv eq 'bre') {                    if ($priv eq 'bre') {
                       if ($noblockcheck) {                        my $deeplinkblock = &deeplink_check($priv,$symb,$refuri);
                         if ($deeplinkblock) {
                             $thisallowed = 'D';
                         } elsif ($noblockcheck) {
                           $thisallowed.=$value;                            $thisallowed.=$value;
                       } else {                        } else {
                           my @blockers = &has_comm_blocking($priv,$symb,$refuri);                            my @blockers = &has_comm_blocking($priv,'',$refuri,'',1);
                           if (@blockers > 0) {                            if (@blockers > 0) {
                               $thisallowed = 'B';                                $thisallowed = 'B';
                           } else {                            } else {
Line 7267  sub allowed { Line 8544  sub allowed {
    }     }
        }         }
     }      }
      
 #  #
 # Rest of the restrictions depend on selected course  # Rest of the restrictions depend on selected course
 #  #
Line 7346  sub allowed { Line 8623  sub allowed {
  return 'A';   return 'A';
     } elsif ($thisallowed eq 'B') {      } elsif ($thisallowed eq 'B') {
         return 'B';          return 'B';
       } elsif ($thisallowed eq 'D') {
           return 'D';
     }      }
    return 'F';     return 'F';
 }  }
Line 7362  sub constructaccess { Line 8641  sub constructaccess {
     my ($ownername,$ownerdomain,$ownerhome);      my ($ownername,$ownerdomain,$ownerhome);
   
     ($ownerdomain,$ownername) =      ($ownerdomain,$ownername) =
         ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)(?:/daxepage|/daxeopen)?/priv/($match_domain)/($match_username)/});          ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)(?:/daxepage|/daxeopen)?/priv/($match_domain)/($match_username)(?:/|$)});
   
 # The URL does not really point to any authorspace, forget it  # The URL does not really point to any authorspace, forget it
     unless (($ownername) && ($ownerdomain)) { return ''; }      unless (($ownername) && ($ownerdomain)) { return ''; }
Line 7383  sub constructaccess { Line 8662  sub constructaccess {
             $ownerhome = &homeserver($ownername,$ownerdomain);              $ownerhome = &homeserver($ownername,$ownerdomain);
             return ($ownername,$ownerdomain,$ownerhome);              return ($ownername,$ownerdomain,$ownerhome);
         }          }
           if ($env{'request.course.id'}) {
               if (($ownername eq $env{'course.'.$env{'request.course.id'}.'.num'}) &&
                   ($ownerdomain eq $env{'course.'.$env{'request.course.id'}.'.domain'})) {
                   if (&allowed('mdc',$env{'request.course.id'})) {
                       $ownerhome = $env{'course.'.$env{'request.course.id'}.'.home'};
                       return ($ownername,$ownerdomain,$ownerhome);
                   }
               }
           }
     }      }
   
 # We don't have any access right now. If we are not possibly going to do anything about this,  # We don't have any access right now. If we are not possibly going to do anything about this,
Line 7425  sub constructaccess { Line 8713  sub constructaccess {
 #  #
 # User for whom data are being temporarily cached.  # User for whom data are being temporarily cached.
 my $cacheduser='';  my $cacheduser='';
   # Course for which data are being temporarily cached.
   my $cachedcid='';
 # Cached blockers for this user (a hash of blocking items).   # Cached blockers for this user (a hash of blocking items). 
 my %cachedblockers=();  my %cachedblockers=();
 # When the data were last cached.  # When the data were last cached.
 my $cachedlast='';  my $cachedlast='';
   
 sub load_all_blockers {  sub load_all_blockers {
     my ($uname,$udom,$blocks)=@_;      my ($uname,$udom)=@_;
     if (($uname ne '') && ($udom ne '')) {       if (($uname ne '') && ($udom ne '')) { 
         if (($cacheduser eq $uname.':'.$udom) &&          if (($cacheduser eq $uname.':'.$udom) &&
               ($cachedcid eq $env{'request.course.id'}) &&
             (abs($cachedlast-time)<5)) {              (abs($cachedlast-time)<5)) {
             return;              return;
         }          }
     }      }
     $cachedlast=time;      $cachedlast=time;
     $cacheduser=$uname.':'.$udom;      $cacheduser=$uname.':'.$udom;
     %cachedblockers = &get_commblock_resources($blocks);      $cachedcid=$env{'request.course.id'};
       %cachedblockers = &get_commblock_resources();
       return;
 }  }
   
 sub get_comm_blocks {  sub get_comm_blocks {
Line 7520  sub get_commblock_resources { Line 8813  sub get_commblock_resources {
                             if ($mapsymb) {                              if ($mapsymb) {
                                 if (ref($navmap)) {                                  if (ref($navmap)) {
                                     my $mapres = $navmap->getBySymb($mapsymb);                                      my $mapres = $navmap->getBySymb($mapsymb);
                                     @to_test = $mapres->retrieveResources($mapres,undef,0,0,0,1);                                      if (ref($mapres)) {
                                     foreach my $res (@to_test) {                                          my $first = $mapres->map_start();
                                         my $symb = $res->symb();                                          my $finish = $mapres->map_finish();
                                         next if ($symb eq $mapsymb);                                          my $it = $navmap->getIterator($first,$finish,undef,0,0);
                                         if ($symb ne '') {                                          if (ref($it)) {
                                             @interval=&EXT("resource.0.interval",$symb);                                              my $res;
                                             if ($interval[1] eq 'map') {                                              while ($res = $it->next(undef,1)) {
                                                 last;                                                  next unless (ref($res));
                                                   my $symb = $res->symb();
                                                   next if (($symb eq $mapsymb) || ($symb eq ''));
                                                   @interval=&EXT("resource.0.interval",$symb);
                                                   if ($interval[1] eq 'map') {
                                                       if ($res->answerable()) {
                                                           push(@to_test,$res);
                                                           last;
                                                       }
                                                   }
                                             }                                              }
                                         }                                          }
                                     }                                      }
Line 7578  sub get_commblock_resources { Line 8880  sub get_commblock_resources {
 }  }
   
 sub has_comm_blocking {  sub has_comm_blocking {
     my ($priv,$symb,$uri,$blocks) = @_;      my ($priv,$symb,$uri,$ignoresymbdb,$noenccheck,$blocked,$blocks) = @_;
     my @blockers;      my @blockers;
     return unless ($env{'request.course.id'});      return unless ($env{'request.course.id'});
     return unless ($priv eq 'bre');      return unless ($priv eq 'bre');
     return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);      return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);
     return if ($env{'request.state'} eq 'construct');      return if ($env{'request.state'} eq 'construct');
     &load_all_blockers($env{'user.name'},$env{'user.domain'},$blocks);      my %blockinfo;
     return unless (keys(%cachedblockers) > 0);      if (ref($blocks) eq 'HASH') {
           %blockinfo = &get_commblock_resources($blocks);
       } else {
           &load_all_blockers($env{'user.name'},$env{'user.domain'});
           %blockinfo = %cachedblockers;
       }
       return unless (keys(%blockinfo) > 0);
     my (%possibles,@symbs);      my (%possibles,@symbs);
     if (!$symb) {      if (!$symb) {
         $symb = &symbread($uri,1,1,1,\%possibles);          $symb = &symbread($uri,1,1,1,\%possibles,$ignoresymbdb,$noenccheck);
     }      }
     if ($symb) {      if ($symb) {
         @symbs = ($symb);          @symbs = ($symb);
Line 7599  sub has_comm_blocking { Line 8907  sub has_comm_blocking {
     foreach my $symb (@symbs) {      foreach my $symb (@symbs) {
         last if ($noblock);          last if ($noblock);
         my ($map,$resid,$resurl)=&decode_symb($symb);          my ($map,$resid,$resurl)=&decode_symb($symb);
         foreach my $block (keys(%cachedblockers)) {          foreach my $block (keys(%blockinfo)) {
             if ($block =~ /^firstaccess____(.+)$/) {              if ($block =~ /^firstaccess____(.+)$/) {
                 my $item = $1;                  my $item = $1;
                 if (($item eq $map) || ($item eq $symb)) {                  unless ($blocked) {
                     $noblock = 1;                      if (($item eq $map) || ($item eq $symb)) {
                     last;                          $noblock = 1;
                           last;
                       }
                 }                  }
             }              }
             if (ref($cachedblockers{$block}) eq 'HASH') {              if (ref($blockinfo{$block}) eq 'HASH') {
                 if (ref($cachedblockers{$block}{'resources'}) eq 'HASH') {                  if (ref($blockinfo{$block}{'resources'}) eq 'HASH') {
                     if ($cachedblockers{$block}{'resources'}{$symb}) {                      if ($blockinfo{$block}{'resources'}{$symb}) {
                         unless (grep(/^\Q$block\E$/,@blockers)) {                          unless (grep(/^\Q$block\E$/,@blockers)) {
                             push(@blockers,$block);                              push(@blockers,$block);
                         }                          }
                     }                      }
                 }                  }
             }                  if (ref($blockinfo{$block}{'maps'}) eq 'HASH') {
             if (ref($cachedblockers{$block}{'maps'}) eq 'HASH') {                      if ($blockinfo{$block}{'maps'}{$map}) {
                 if ($cachedblockers{$block}{'maps'}{$map}) {                          unless (grep(/^\Q$block\E$/,@blockers)) {
                     unless (grep(/^\Q$block\E$/,@blockers)) {                              push(@blockers,$block);
                         push(@blockers,$block);                          }
                     }                      }
                 }                  }
             }              }
         }          }
     }      }
     return if ($noblock);      unless ($noblock) { 
     return @blockers;          return @blockers;
       }
       return;
   }
 }  }
   
   sub deeplink_check {
       my ($priv,$symb,$uri) = @_;
       return unless ($env{'request.course.id'});
       return unless ($priv eq 'bre');
       return if ($env{'request.state'} eq 'construct');
       return if ($env{'request.role.adv'});
       my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
       my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
       my (%possibles,@symbs);
       if (!$symb) {
           $symb = &symbread($uri,1,1,1,\%possibles);
       }
       if ($symb) {
           @symbs = ($symb);
       } elsif (keys(%possibles)) {
           @symbs = keys(%possibles);
       }
   
       my ($login,$switchrole,$allow);
       if ($env{'request.deeplink.login'} =~ m{^\Q/tiny/$cdom/\E(\w+)$}) {
           my $key = $1;
           my $tinyurl;
           my ($result,$cached)=&Apache::lonnet::is_cached_new('tiny',$cdom."\0".$key);
           if (defined($cached)) {
                $tinyurl = $result;
           } else {
                my $configuname = &Apache::lonnet::get_domainconfiguser($cdom);
                my %currtiny = &Apache::lonnet::get('tiny',[$key],$cdom,$configuname);
                if ($currtiny{$key} ne '') {
                    $tinyurl = $currtiny{$key};
                    &Apache::lonnet::do_cache_new('tiny',$cdom."\0".$key,$currtiny{$key},600);
                }
           }
           if ($tinyurl ne '') {
               my ($cnumreq,$posslogin) = split(/\&/,$tinyurl);
               if ($cnumreq eq $cnum) {
                   $login = $posslogin;
               } else {
                   $switchrole = 1;
               }
           }
       }
       foreach my $symb (@symbs) {
           last if ($allow);
           my $deeplink = &EXT("resource.0.deeplink",$symb);
           if ($deeplink eq '') {
               $allow = 1;
           } else {
               my ($listed,$scope,$access) = split(/,/,$deeplink);
               if ($access eq 'any') {
                   $allow = 1;
               } elsif ($login) {
                   if ($access eq 'only') {
                       if ($scope eq 'res') {
                           if ($symb eq $login) {
                               $allow = 1;
                           }
                       } elsif ($scope eq 'map') {
   #FIXME Compare map for $env{'request.deeplink.login'} with map for $symb
                       } elsif ($scope eq 'rec') {
   #FIXME Recurse up for $env{'request.deeplink.login'} with map for $symb
                       }
                   } else {
                       my ($acctype,$item) = split(/:/,$access);
                       if (($acctype eq 'lti') && ($env{'user.linkprotector'})) {
                           if (grep(/^\Q$item\E$/,split(/,/,$env{'user.linkprotector'}))) {
                               my %tinyurls = &get('tiny',[$symb],$cdom,$cnum);
                               if (grep(/\Q$tinyurls{$symb}\E$/,split(/,/,$env{'user.linkproturis'}))) {
                                   $allow = 1;
                               }
                           }
                       } elsif (($acctype eq 'key') && ($env{'user.deeplinkkey'})) {
                           if (grep(/^\Q$item\E$/,split(/,/,$env{'user.deeplinkkey'}))) {
                               my %tinyurls = &get('tiny',[$symb],$cdom,$cnum);
                               if (grep(/\Q$tinyurls{$symb}\E$/,split(/,/,$env{'user.keyedlinkuri'}))) {
                                   $allow = 1;
                               }
                           }
                       }
                   }
               }
           }
       }
       return if ($allow);
       return 1;
 }  }
   
 # -------------------------------- Deversion and split uri into path an filename     # -------------------------------- Deversion and split uri into path an filename   
Line 7701  sub get_symb_from_alias { Line 9100  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 7729  sub definerole { Line 9128  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 7815  sub update_allusers_table { Line 9222  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 7836  sub fetch_enrollment_query { Line 9245  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 7864  sub fetch_enrollment_query { Line 9273  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 7881  sub fetch_enrollment_query { Line 9290  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(0.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 8279  sub auto_validate_class_sec { Line 9694  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 {  sub auto_crsreq_update {
     my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title,      my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title,
         $code,$accessstart,$accessend,$inbound) = @_;          $code,$accessstart,$accessend,$inbound) = @_;
Line 8638  sub assignrole { Line 10080  sub assignrole {
             }              }
             if ($refused) {              if ($refused) {
                 my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});                  my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
                 if (!$selfenroll && $context eq 'course') {                  if (!$selfenroll && (($context eq 'course') || ($context eq 'ltienroll' && $env{'request.lti.login'}))) {
                     my %crsenv;                      my %crsenv;
                     if ($role eq 'cc' || $role eq 'co') {                      if ($role eq 'cc' || $role eq 'co') {
                         %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));                          %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
Line 8658  sub assignrole { Line 10100  sub assignrole {
                             }                              }
                         }                          }
                     }                      }
                 } elsif (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {                  } elsif (($selfenroll == 1) && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
                     $refused = '';                      if ($role eq 'st') {
                           $refused = '';
                       } elsif (($context eq 'ltienroll') && ($env{'request.lti.login'})) {
                           $refused = '';
                       }
                 } elsif ($context eq 'requestcourses') {                  } elsif ($context eq 'requestcourses') {
                     my @possroles = ('st','ta','ep','in','cc','co');                      my @possroles = ('st','ta','ep','in','cc','co');
                     if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {                      if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {
Line 8774  sub assignrole { Line 10220  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 8878  sub store_coowners { Line 10325  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 8924  sub modifyuser { Line 10387  sub modifyuser {
     my $newuser;      my $newuser;
     if ($uhome eq 'no_host') {      if ($uhome eq 'no_host') {
         $newuser = 1;          $newuser = 1;
           unless (($umode && ($upass ne '')) || ($umode eq 'localauth') ||
                   ($umode eq 'lti')) {
               return 'error: more information needed to create new user';
           }
     }      }
 # ----------------------------------------------------------------- Create User  # ----------------------------------------------------------------- Create User
     if (($uhome eq 'no_host') &&       if (($uhome eq 'no_host') && 
  (($umode && $upass) || ($umode eq 'localauth'))) {   (($umode && $upass) || ($umode eq 'localauth') || ($umode eq 'lti'))) {
         my $unhome='';          my $unhome='';
         if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) {           if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) { 
             $unhome = $desiredhome;              $unhome = $desiredhome;
Line 9079  sub modifyuser { Line 10546  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 9095  sub modifystudent { Line 10562  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 9148  sub modify_student_enrollment { Line 10615  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 9215  sub writecoursepref { Line 10682  sub writecoursepref {
   
 sub createcourse {  sub createcourse {
     my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,      my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
         $course_owner,$crstype,$cnum,$context,$category)=@_;          $course_owner,$crstype,$cnum,$context,$category,$callercontext)=@_;
     $url=&declutter($url);      $url=&declutter($url);
     my $cid='';      my $cid='';
     if ($context eq 'requestcourses') {      if ($context eq 'requestcourses') {
         my $can_create = 0;          my $can_create = 0;
         my ($ownername,$ownerdom) = split(':',$course_owner);          my ($ownername,$ownerdom) = split(':',$course_owner);
         if ($udom eq $ownerdom) {          if ($udom eq $ownerdom) {
             if (&usertools_access($ownername,$ownerdom,$category,undef,              my $reload;
               if (($callercontext eq 'auto') &&
                  ($ownerdom eq $env{'user.domain'}) && ($ownername eq $env{'user.name'})) {
                   $reload = 'reload';
               }
               if (&usertools_access($ownername,$ownerdom,$category,$reload,
                                   $context)) {                                    $context)) {
                 $can_create = 1;                  $can_create = 1;
             }              }
Line 9372  sub is_course { Line 10844  sub is_course {
     my ($cdom, $cnum) = scalar(@_) == 1 ?       my ($cdom, $cnum) = scalar(@_) == 1 ? 
          ($_[0] =~ /^($match_domain)_($match_courseid)$/)  :  @_;           ($_[0] =~ /^($match_domain)_($match_courseid)$/)  :  @_;
   
     return unless $cdom and $cnum;      return unless (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/));
       my $uhome=&homeserver($cnum,$cdom);
     my %courses = &courseiddump($cdom, '.', 1, '.', '.', $cnum, undef, undef,      my $iscourse;
         '.');      if (grep { $_ eq $uhome } current_machine_ids()) {
           $iscourse = &LONCAPA::Lond::is_course($cdom,$cnum);
     return unless(exists($courses{$cdom.'_'.$cnum}));      } else {
           my $hashid = $cdom.':'.$cnum;
           ($iscourse,my $cached) = &is_cached_new('iscourse',$hashid);
           unless (defined($cached)) {
               my %courses = &courseiddump($cdom, '.', 1, '.', '.',
                                           $cnum,undef,undef,'.');
               $iscourse = 0;
               if (exists($courses{$cdom.'_'.$cnum})) {
                   $iscourse = 1;
               }
               &do_cache_new('iscourse',$hashid,$iscourse,3600);
           }
       }
       return unless ($iscourse);
     return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum;      return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum;
 }  }
   
Line 9394  sub store_userdata { Line 10879  sub store_userdata {
             if (($uhome eq '') || ($uhome eq 'no_host')) {              if (($uhome eq '') || ($uhome eq 'no_host')) {
                 $result = 'error: no_host';                  $result = 'error: no_host';
             } else {              } else {
                 $storehash->{'ip'} = $ENV{'REMOTE_ADDR'};                  $storehash->{'ip'} = &get_requestor_ip();
                 $storehash->{'host'} = $perlvar{'lonHostID'};                  $storehash->{'host'} = $perlvar{'lonHostID'};
   
                 my $namevalue='';                  my $namevalue='';
Line 9513  sub save_selected_files { Line 10998  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 9527  sub save_selected_files { Line 11012  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 9537  sub files_in_path { Line 11022  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 9559  sub files_not_in_path { Line 11044  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 10134  sub dirlist { Line 11619  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 10207  sub stat_file { Line 11709  sub stat_file {
     return ();      return ();
 }  }
   
   # --------------------------------------------------------- recursedirs
   # Recursive function to traverse either a specific user's Authoring Space
   # or corresponding Published Resource Space, and populate the hash ref:
   # $dirhashref with URLs of all directories, and if $filehashref hash
   # ref arg is provided, the URLs of any files, excluding versioned, .meta,
   # or .rights files in resource space, and .meta, .save, .log, and .bak
   # files in Authoring Space.
   #
   # Inputs:
   #
   # $is_home - true if current server is home server for user's space
   # $context - either: priv, or res respectively for Authoring or Resource Space.
   # $docroot - Document root (i.e., /home/httpd/html
   # $toppath - Top level directory (i.e., /res/$dom/$uname or /priv/$dom/$uname
   # $relpath - Current path (relative to top level).
   # $dirhashref - reference to hash to populate with URLs of directories (Required)
   # $filehashref - reference to hash to populate with URLs of files (Optional)
   #
   # Returns: nothing
   #
   # Side Effects: populates $dirhashref, and $filehashref (if provided).
   #
   # Currently used by interface/londocs.pm to create linked select boxes for
   # directory and filename to import a Course "Author" resource into a course, and
   # also to create linked select boxes for Authoring Space and Directory to choose
   # save location for creation of a new "standard" problem from the Course Editor.
   #
   
   sub recursedirs {
       my ($is_home,$context,$docroot,$toppath,$relpath,$dirhashref,$filehashref) = @_;
       return unless (ref($dirhashref) eq 'HASH');
       my $currpath = $docroot.$toppath;
       if ($relpath) {
           $currpath .= "/$relpath";
       }
       my $savefile;
       if (ref($filehashref)) {
           $savefile = 1;
       }
       if ($is_home) {
           if (opendir(my $dirh,$currpath)) {
               foreach my $item (sort { lc($a) cmp lc($b) } grep(!/^\.+$/,readdir($dirh))) {
                   next if ($item eq '');
                   if (-d "$currpath/$item") {
                       my $newpath;
                       if ($relpath) {
                           $newpath = "$relpath/$item";
                       } else {
                           $newpath = $item;
                       }
                       $dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;
                       &recursedirs($is_home,$context,$docroot,$toppath,$newpath,$dirhashref,$filehashref);
                   } elsif ($savefile) {
                       if ($context eq 'priv') {
                           unless ($item =~ /\.(meta|save|log|bak|DS_Store)$/) {
                               $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;
                           }
                       } else {
                           unless (($item =~ /\.meta$/) || ($item =~ /\.\d+\.\w+$/) || ($item =~ /\.rights$/)) {
                               $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;
                           }
                       }
                   }
               }
               closedir($dirh);
           }
       } else {
           my ($dirlistref,$listerror) =
               &dirlist($toppath.$relpath);
           my @dir_lines;
           my $dirptr=16384;
           if (ref($dirlistref) eq 'ARRAY') {
               foreach my $dir_line (sort
                                 {
                                     my ($afile)=split('&',$a,2);
                                     my ($bfile)=split('&',$b,2);
                                     return (lc($afile) cmp lc($bfile));
                                 } (@{$dirlistref})) {
                   my ($item,$dom,undef,$testdir,undef,undef,undef,undef,$size,undef,$mtime,undef,undef,undef,$obs,undef) =
                       split(/\&/,$dir_line,16);
                   $item =~ s/\s+$//;
                   next if (($item =~ /^\.\.?$/) || ($obs));
                   if ($dirptr&$testdir) {
                       my $newpath;
                       if ($relpath) {
                           $newpath = "$relpath/$item";
                       } else {
                           $relpath = '/';
                           $newpath = $item;
                       }
                       $dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;
                       &recursedirs($is_home,$context,$docroot,$toppath,$newpath,$dirhashref,$filehashref);
                   } elsif ($savefile) {
                       if ($context eq 'priv') {
                           unless ($item =~ /\.(meta|save|log|bak|DS_Store)$/) {
                               $filehashref->{$relpath}{$item} = 1;
                           }
                       } else {
                           unless (($item =~ /\.meta$/) || ($item =~ /\.\d+\.\w+$/)) {
                               $filehashref->{$relpath}{$item} = 1;
                           }
                       }
                   }
               }
           }
       }
       return;
   }
   
 # -------------------------------------------------------- Value of a Condition  # -------------------------------------------------------- Value of a Condition
   
 # gets the value of a specific preevaluated condition  # gets the value of a specific preevaluated condition
Line 10418  sub resdata { Line 12029  sub resdata {
     return undef;      return undef;
 }  }
   
 sub get_domain_ltitools {  sub get_domain_lti {
     my ($cdom) = @_;      my ($cdom,$context) = @_;
     my %ltitools;      my ($name,%lti);
     my ($result,$cached)=&is_cached_new('ltitools',$cdom);      if ($context eq 'consumer') {
           $name = 'ltitools';
       } elsif ($context eq 'provider') {
           $name = 'lti';
       } else {
           return %lti;
       }
       my ($result,$cached)=&is_cached_new($name,$cdom);
     if (defined($cached)) {      if (defined($cached)) {
         if (ref($result) eq 'HASH') {          if (ref($result) eq 'HASH') {
             %ltitools = %{$result};              %lti = %{$result};
         }          }
     } else {      } else {
         my %domconfig = &get_dom('configuration',['ltitools'],$cdom);          my %domconfig = &get_dom('configuration',[$name],$cdom);
         if (ref($domconfig{'ltitools'}) eq 'HASH') {          if (ref($domconfig{$name}) eq 'HASH') {
             %ltitools = %{$domconfig{'ltitools'}};              %lti = %{$domconfig{$name}};
               my %encdomconfig = &get_dom('encconfig',[$name],$cdom);
               if (ref($encdomconfig{$name}) eq 'HASH') {
                   foreach my $id (keys(%lti)) {
                       if (ref($encdomconfig{$name}{$id}) eq 'HASH') {
                           foreach my $item ('key','secret') {
                               $lti{$id}{$item} = $encdomconfig{$name}{$id}{$item};
                           }
                       }
                   }
               }
         }          }
         my $cachetime = 24*60*60;          my $cachetime = 24*60*60;
         &do_cache_new('ltitools',$cdom,\%ltitools,$cachetime);          &do_cache_new($name,$cdom,\%lti,$cachetime);
     }      }
     return %ltitools;      return %lti;
 }  }
   
 sub get_numsuppfiles {  sub get_numsuppfiles {
Line 10447  sub get_numsuppfiles { Line 12075  sub get_numsuppfiles {
     unless (defined($cached)) {      unless (defined($cached)) {
         my $chome=&homeserver($cnum,$cdom);          my $chome=&homeserver($cnum,$cdom);
         unless ($chome eq 'no_host') {          unless ($chome eq 'no_host') {
             ($suppcount,my $errors) = (0,0);              ($suppcount,my $supptools,my $errors) = (0,0,0);
             my $suppmap = 'supplemental.sequence';              my $suppmap = 'supplemental.sequence';
             ($suppcount,$errors) =               ($suppcount,$supptools,$errors) =
                 &Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount,$errors);                  &Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount,
                                                            $supptools,$errors);
         }          }
         &do_cache_new('suppcount',$hashid,$suppcount,600);          &do_cache_new('suppcount',$hashid,$suppcount,600);
     }      }
Line 10740  sub EXT { Line 12369  sub EXT {
  } else {   } else {
     $filename=$env{'request.filename'};      $filename=$env{'request.filename'};
  }   }
  my $metadata=&metadata($filename,$what);          my $toolsymb;
           if (($filename =~ /ext\.tool$/) && ($what ne '0_gradable')) {
               $toolsymb = $symbparm;
           }
    my $metadata=&metadata($filename,$what,$toolsymb);
  if (defined($metadata)) { return &get_reply([$metadata,'resource']); }   if (defined($metadata)) { return &get_reply([$metadata,'resource']); }
  $metadata=&metadata($filename,'parameter_'.$what);   $metadata=&metadata($filename,'parameter_'.$what,$toolsymb);
  if (defined($metadata)) { return &get_reply([$metadata,'resource']); }   if (defined($metadata)) { return &get_reply([$metadata,'resource']); }
   
 # ----------------------------------------------- fifth, look in rest of course  # ----------------------------------------------- fifth, look in rest of course
Line 10768  sub EXT { Line 12401  sub EXT {
     if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); }      if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); }
  }   }
  if ($recurse) { return undef; }   if ($recurse) { return undef; }
  my $pack_def=&packages_tab_default($filename,$varname);   my $pack_def=&packages_tab_default($filename,$varname,$toolsymb);
  if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); }   if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); }
 # ---------------------------------------------------- Any other user namespace  # ---------------------------------------------------- Any other user namespace
     } elsif ($realm eq 'environment') {      } elsif ($realm eq 'environment') {
Line 10793  sub EXT { Line 12426  sub EXT {
  if ($space eq 'name') {   if ($space eq 'name') {
     return $ENV{'SERVER_NAME'};      return $ENV{'SERVER_NAME'};
         }          }
       } elsif ($realm eq 'client') {
           if ($space eq 'remote_addr') {
               return &get_requestor_ip();
           }
     }      }
     return '';      return '';
 }  }
Line 10862  sub sort_course_groups { # Sort groups b Line 12499  sub sort_course_groups { # Sort groups b
 }  }
   
 sub packages_tab_default {  sub packages_tab_default {
     my ($uri,$varname)=@_;      my ($uri,$varname,$toolsymb)=@_;
     my (undef,$part,$name)=split(/\./,$varname);      my (undef,$part,$name)=split(/\./,$varname);
   
     my (@extension,@specifics,$do_default);      my (@extension,@specifics,$do_default);
     foreach my $package (split(/,/,&metadata($uri,'packages'))) {      foreach my $package (split(/,/,&metadata($uri,'packages',$toolsymb))) {
  my ($pack_type,$pack_part)=split(/_/,$package,2);   my ($pack_type,$pack_part)=split(/_/,$package,2);
  if ($pack_type eq 'default') {   if ($pack_type eq 'default') {
     $do_default=1;      $do_default=1;
Line 10933  sub add_prefix_and_part { Line 12570  sub add_prefix_and_part {
   
 my %metaentry;  my %metaentry;
 my %importedpartids;  my %importedpartids;
   my %importedrespids;
 sub metadata {  sub metadata {
     my ($uri,$what,$liburi,$prefix,$depthcount)=@_;      my ($uri,$what,$toolsymb,$liburi,$prefix,$depthcount)=@_;
     $uri=&declutter($uri);      $uri=&declutter($uri);
     # if it is a non metadata possible uri return quickly      # if it is a non metadata possible uri return quickly
     if (($uri eq '') ||       if (($uri eq '') || 
  (($uri =~ m|^/*adm/|) &&    (($uri =~ m|^/*adm/|) && 
      ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard|exttools?)$})) ||       ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard|ext\.tool)$})) ||
         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {
  return undef;   return undef;
     }      }
Line 10958  sub metadata { Line 12596  sub metadata {
  my ($result,$cached)=&is_cached_new('meta',$uri);   my ($result,$cached)=&is_cached_new('meta',$uri);
  if (defined($cached)) { return $result->{':'.$what}; }   if (defined($cached)) { return $result->{':'.$what}; }
     }      }
   
   #
   # If the uri is for an external tool the file from
   # which metadata should be retrieved depends on whether
   # the tool had been configured to be gradable (set in the Course
   # Editor or Resource Editor).
   #
   # If a valid symb has been included as the third arg in the call
   # to &metadata() that can be used to retrieve the value of
   # parameter_0_gradable set for the resource, and included in the
   # uploaded map containing the tool. The value is retrieved via
   # &EXT(), if a valid symb is available.  Otherwise the value of
   # gradable in the exttool_$marker.db file for the tool instance
   # is retrieved via &get().
   #
   # When lonuserstate::traceroute() calls lonnet::EXT() for 
   # hiddenresource and encrypturl (during course initialization)
   # the map-level parameter for resource.0.gradable included in the 
   # uploaded map containing the tool will not yet have been stored
   # in the user_course_parms.db file for the user's session, so in 
   # this case fall back to retrieving gradable status from the
   # exttool_$marker.db file.
   #
   # In order to avoid an infinite loop, &metadata() will return
   # before a call to &EXT(), if the uri is for an external tool
   # and the $what for which metadata is being requested is
   # parameter_0_gradable or 0_gradable.
   #
   
       if ($uri =~ /ext\.tool$/) {
           if (($what eq 'parameter_0_gradable') || ($what eq '0_gradable')) {
               return;
           } else {
               my ($checked,$use_passback);
               if ($toolsymb ne '') {
                   (undef,undef,my $tooluri) = &decode_symb($toolsymb);
                   if (($tooluri eq $uri) && (&EXT('resource.0.gradable',$toolsymb))) {
                       $checked = 1;
                       if (&EXT('resource.0.gradable',$toolsymb) =~ /^yes$/i) {
                           $use_passback = 1;
                       }
                   }
               }
               unless ($checked) {
                   my ($ignore,$cdom,$cnum,$marker) = split(m{/},$uri);
                   $marker=~s/\D//g;
                   if ($marker) {
                       my %toolsettings=&get('exttool_'.$marker,['gradable'],$cdom,$cnum);
                       $use_passback = $toolsettings{'gradable'};
                   }
               }
               if ($use_passback) {
                   $filename = '/home/httpd/html/res/lib/templates/LTIpassback.tool';
               } else {
                   $filename = '/home/httpd/html/res/lib/templates/LTIstandard.tool';
               }
           }
       }
   
     {      {
 # Imported parts would go here  # Imported parts would go here
         my %importedids=();          my @origfiletagids=();
         my @origfileimportpartids=();  
         my $importedparts=0;          my $importedparts=0;
   
   # Imported responseids would go here
           my $importedresponses=0;
 #  #
 # Is this a recursive call for a library?  # Is this a recursive call for a library?
 #  #
Line 11057  sub metadata { Line 12756  sub metadata {
                         my $dir=$filename;                          my $dir=$filename;
                         $dir=~s|[^/]*$||;                          $dir=~s|[^/]*$||;
                         $location=&filelocation($dir,$location);                          $location=&filelocation($dir,$location);
                          
                           my $importid=$token->[2]->{'id'};
                         my $importmode=$token->[2]->{'importmode'};                          my $importmode=$token->[2]->{'importmode'};
                         if ($importmode eq 'problem') {  #
 # Import as problem/response  # Check metadata for imported file to
                            $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});  # see if it contained response items
                         } elsif ($importmode eq 'part') {  #
                           my ($origfile,@libfilekeys);
                           my %currmetaentry = %metaentry;
                           @libfilekeys = split(/,/,&metadata($location,'keys',undef,undef,undef,
                                                              $depthcount+1));
                           if (grep(/^responseorder$/,@libfilekeys)) {
                               my $libresponseorder = &metadata($location,'responseorder',undef,undef,
                                                                undef,$depthcount+1);
                               if ($libresponseorder ne '') {
                                   if ($#origfiletagids<0) {
                                       undef(%importedrespids);
                                       undef(%importedpartids);
                                   }
                                   my @respids = split(/\s*,\s*/,$libresponseorder);
                                   if (@respids) {
                                       $importedrespids{$importid} = join(',',map { $importid.'_'.$_ } @respids);
                                   }
                                   if ($importedrespids{$importid} ne '') {
                                       $importedresponses = 1;
   # We need to get the original file and the imported file to get the response order correct
   # Load and inspect original file
                                       if ($#origfiletagids<0) {
                                           my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
                                           $origfile=&getfile($origfilelocation);
                                           @origfiletagids=($origfile=~/<((?:\w+)response|import|part)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
                                       }
                                   }
                               }
                           }
   # Do not overwrite contents of %metaentry hash for resource itself with 
   # hash populated for imported library file
                           %metaentry = %currmetaentry;
                           undef(%currmetaentry);
                           if ($importmode eq 'part') {
 # Import as part(s)  # Import as part(s)
                            $importedparts=1;                             $importedparts=1;
 # We need to get the original file and the imported file to get the part order correct  # We need to get the original file and the imported file to get the part order correct
 # Good news: we do not need to worry about nested libraries, since parts cannot be nested  # Good news: we do not need to worry about nested libraries, since parts cannot be nested
 # Load and inspect original file  # Load and inspect original file if we didn't do that already
                            if ($#origfileimportpartids<0) {                             if ($#origfiletagids<0) {
                               undef(%importedpartids);                                 undef(%importedrespids);
                               my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);                                 undef(%importedpartids);
                               my $origfile=&getfile($origfilelocation);                                 if ($origfile eq '') {
                               @origfileimportpartids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);                                     my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
                                      $origfile=&getfile($origfilelocation);
                                      @origfiletagids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
                                  }
                              }
                              my @impfilepartids;
   # If <partorder> tag is included in metadata for the imported file
   # get the parts in the imported file from that.
                              if (grep(/^partorder$/,@libfilekeys)) {
                                  %currmetaentry = %metaentry;
                                  my $libpartorder = &metadata($location,'partorder',undef,undef,undef,
                                                               $depthcount+1);
                                  %metaentry = %currmetaentry;
                                  undef(%currmetaentry);
                                  if ($libpartorder ne '') {
                                      @impfilepartids=split(/\s*,\s*/,$libpartorder);
                                  }
                              } else {
   # If no <partorder> tag available, load and inspect imported file
                                  my $impfile=&getfile($location);
                                  @impfilepartids=($impfile=~/<part[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
                            }                             }
   
 # Load and inspect imported file  
                            my $impfile=&getfile($location);  
                            my @impfilepartids=($impfile=~/<part[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);  
                            if ($#impfilepartids>=0) {                             if ($#impfilepartids>=0) {
 # This problem had parts  # This problem had parts
                                $importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids);                                 $importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids);
Line 11088  sub metadata { Line 12837  sub metadata {
                                $importedpartids{$token->[2]->{'id'}}=$token->[2]->{'id'};                                 $importedpartids{$token->[2]->{'id'}}=$token->[2]->{'id'};
                            }                             }
                         } else {                          } else {
   # Import as problem or as normal import
                               $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
                               unless ($importmode eq 'problem') {
 # Normal import  # Normal import
                            $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});                                  if (defined($token->[2]->{'id'})) {
                            if (defined($token->[2]->{'id'})) {                                      $unikey.='_'.$token->[2]->{'id'};
                               $unikey.='_'.$token->[2]->{'id'};                                  }
                            }                              }
   # Check metadata for imported file to
   # see if it contained parts
                               if (grep(/^partorder$/,@libfilekeys)) {
                                   %currmetaentry = %metaentry;
                                   my $libpartorder = &metadata($location,'partorder',undef,undef,undef,
                                                                $depthcount+1);
                                   %metaentry = %currmetaentry;
                                   undef(%currmetaentry);
                                   if ($libpartorder ne '') {
                                       $importedparts = 1;
                                       $importedpartids{$token->[2]->{'id'}}=$libpartorder;
                                   }
                               }
                         }                          }
   
  if ($depthcount<20) {   if ($depthcount<20) {
     my $metadata =       my $metadata = 
  &metadata($uri,'keys', $location,$unikey,   &metadata($uri,'keys',$toolsymb,$location,$unikey,
   $depthcount+1);    $depthcount+1);
     foreach my $meta (split(',',$metadata)) {      foreach my $meta (split(',',$metadata)) {
  $metaentry{':'.$meta}=$metaentry{':'.$meta};   $metaentry{':'.$meta}=$metaentry{':'.$meta};
  $metathesekeys{$meta}=1;   $metathesekeys{$meta}=1;
     }      }
   
                         }                          }
     } else {      } else {
 #  #
Line 11172  sub metadata { Line 12935  sub metadata {
  $dir=~s|[^/]*$||;   $dir=~s|[^/]*$||;
  $location=&filelocation($dir,$location);   $location=&filelocation($dir,$location);
  my $rights_metadata =   my $rights_metadata =
     &metadata($uri,'keys',$location,'_rights',      &metadata($uri,'keys',$toolsymb,$location,'_rights',
       $depthcount+1);        $depthcount+1);
  foreach my $rights (split(',',$rights_metadata)) {   foreach my $rights (split(',',$rights_metadata)) {
     #$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights};      #$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights};
Line 11186  sub metadata { Line 12949  sub metadata {
     grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));      grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));
  $metaentry{':packages'} = join(',',@uniq_packages);   $metaentry{':packages'} = join(',',@uniq_packages);
   
         if ($importedparts) {          if (($importedresponses) || ($importedparts)) {
               if ($importedparts) {
 # We had imported parts and need to rebuild partorder  # We had imported parts and need to rebuild partorder
            $metaentry{':partorder'}='';                  $metaentry{':partorder'}='';
            $metathesekeys{'partorder'}=1;                  $metathesekeys{'partorder'}=1;
            for (my $index=0;$index<$#origfileimportpartids;$index+=2) {              }
                if ($origfileimportpartids[$index] eq 'part') {              if ($importedresponses) {
 # original part, part of the problem  # We had imported responses and need to rebuil responseorder
                   $metaentry{':partorder'}.=','.$origfileimportpartids[$index+1];                  $metaentry{':responseorder'}='';
                } else {                  $metathesekeys{'responseorder'}=1;
 # we have imported parts at this position              }
                   $metaentry{':partorder'}.=','.$importedpartids{$origfileimportpartids[$index+1]};              for (my $index=0;$index<$#origfiletagids;$index+=2) {
                }                  my $origid = $origfiletagids[$index+1];
            }                  if ($origfiletagids[$index] eq 'part') {
            $metaentry{':partorder'}=~s/^\,//;  # Original part, part of the problem
                       if ($importedparts) {
                           $metaentry{':partorder'}.=','.$origid;
                       }
                   } elsif ($origfiletagids[$index] eq 'import') {
                       if ($importedparts) {
   # We have imported parts at this position
                           if ($importedpartids{$origid} ne '') {
                               $metaentry{':partorder'}.=','.$importedpartids{$origid};
                           }
                       }
                       if ($importedresponses) {
   # We have imported responses at this position
                           if ($importedrespids{$origid} ne '') {
                               $metaentry{':responseorder'}.=','.$importedrespids{$origid};
                           }
                       }
                   } else {
   # Original response item, part of the problem
                       if ($importedresponses) {
                           $metaentry{':responseorder'}.=','.$origid;
                       }
                   }
               }
               if ($importedparts) {
                   $metaentry{':partorder'}=~s/^\,//;
               }
               if ($importedresponses) {
                   $metaentry{':responseorder'}=~s/^\,//;
               }
         }          }
   
  $metaentry{':keys'} = join(',',keys(%metathesekeys));   $metaentry{':keys'} = join(',',keys(%metathesekeys));
  &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);   &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
  $metaentry{':allpossiblekeys'}=join(',',keys(%metathesekeys));   $metaentry{':allpossiblekeys'}=join(',',keys(%metathesekeys));
  &do_cache_new('meta',$uri,\%metaentry,$cachetime);          unless ($liburi) {
       &do_cache_new('meta',$uri,\%metaentry,$cachetime);
           }
 # this is the end of "was not already recently cached  # this is the end of "was not already recently cached
     }      }
     return $metaentry{':'.$what};      return $metaentry{':'.$what};
Line 11464  sub symbverify { Line 13258  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 11575  sub deversion { Line 13367  sub deversion {
 # ------------------------------------------------------ Return symb list entry  # ------------------------------------------------------ Return symb list entry
   
 sub symbread {  sub symbread {
     my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles)=@_;      my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles,
           $ignoresymbdb,$noenccheck)=@_;
     my $cache_str='request.symbread.cached.'.$thisfn;      my $cache_str='request.symbread.cached.'.$thisfn;
     if (defined($env{$cache_str})) {      if (defined($env{$cache_str})) {
         if ($ignorecachednull) {          unless (ref($possibles) eq 'HASH') {
             return $env{$cache_str} unless ($env{$cache_str} eq '');              if ($ignorecachednull) {
         } else {                  return $env{$cache_str} unless ($env{$cache_str} eq '');
             return $env{$cache_str};              } else {
                   return $env{$cache_str};
               }
         }          }
     }      }
 # no filename provided? try from environment  # no filename provided? try from environment
     unless ($thisfn) {      unless ($thisfn) {
         if ($env{'request.symb'}) {          if ($env{'request.symb'}) {
     return $env{$cache_str}=&symbclean($env{'request.symb'});              return $env{$cache_str}=&symbclean($env{'request.symb'});
  }   }
  $thisfn=$env{'request.filename'};   $thisfn=$env{'request.filename'};
     }      }
Line 11610  sub symbread { Line 13405  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 11646  sub symbread { Line 13449  sub symbread {
      $syval=&encode_symb($bighash{'map_id_'.$mapid},       $syval=&encode_symb($bighash{'map_id_'.$mapid},
     $resid,$thisfn);      $resid,$thisfn);
                      if (ref($possibles) eq 'HASH') {                       if (ref($possibles) eq 'HASH') {
                          $possibles->{$syval} = 1;                               unless ($bighash{'randomout_'.$ids} || $env{'request.role.adv'}) {
                                $possibles->{$syval} = 1;
                            }
                      }                       }
                      if ($checkforblock) {                       if ($checkforblock) {
                          my @blockers = &has_comm_blocking('bre',$syval,$bighash{'src_'.$ids});                           unless ($bighash{'randomout_'.$ids} || $env{'request.role.adv'}) {
                          if (@blockers) {                               my @blockers = &has_comm_blocking('bre',$syval,$bighash{'src_'.$ids},'',$noenccheck);
                              $syval = '';                               if (@blockers) {
                              return;                                   $syval = '';
                                    untie(%bighash);
                                    return $env{$cache_str}='';
                                }
                          }                           }
                      }                       }
                  } elsif ((!$donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) {                    } elsif ((!$donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) { 
Line 11671  sub symbread { Line 13479  sub symbread {
                              if ($bighash{'map_type_'.$mapid} ne 'page') {                               if ($bighash{'map_type_'.$mapid} ne 'page') {
                                  my $poss_syval=&encode_symb($bighash{'map_id_'.$mapid},                                   my $poss_syval=&encode_symb($bighash{'map_id_'.$mapid},
              $resid,$thisfn);               $resid,$thisfn);
                                  if (ref($possibles) eq 'HASH') {                                   next if ($bighash{'randomout_'.$id} && !$env{'request.role.adv'});
                                      $possibles->{$syval} = 1;                                   next unless (($noenccheck) || ($bighash{'encrypted_'.$id} eq $env{'request.enc'}));
                                  }  
                                  if ($checkforblock) {                                   if ($checkforblock) {
                                      my @blockers = &has_comm_blocking('bre',$poss_syval,$file);                                       my @blockers = &has_comm_blocking('bre',$poss_syval,$file,'',$noenccheck);
                                      unless (@blockers > 0) {                                       if (@blockers > 0) {
                                            $syval = '';
                                        } else {
                                          $syval = $poss_syval;                                           $syval = $poss_syval;
                                          $realpossible++;                                           $realpossible++;
                                      }                                       }
Line 11684  sub symbread { Line 13493  sub symbread {
                                      $syval = $poss_syval;                                       $syval = $poss_syval;
                                      $realpossible++;                                       $realpossible++;
                                  }                                   }
                                    if ($syval) {
                                        if (ref($possibles) eq 'HASH') {
                                            $possibles->{$syval} = 1;
                                        }
                                    }
                              }                               }
  }   }
                      }                       }
Line 12215  sub repcopy_userfile { Line 14029  sub repcopy_userfile {
     }      }
 # now the path exists for sure  # now the path exists for sure
 # get a user agent  # get a user agent
     my $ua=new LWP::UserAgent;  
     my $transferfile=$file.'.in.transfer';      my $transferfile=$file.'.in.transfer';
 # FIXME: this should flock  # FIXME: this should flock
     if (-e $transferfile) { return 'ok'; }      if (-e $transferfile) { return 'ok'; }
     my $request;      my $request;
     $uri=~s/^\///;      $uri=~s/^\///;
     my $homeserver = &homeserver($cnum,$cdom);      my $homeserver = &homeserver($cnum,$cdom);
       my $hostname = &hostname($homeserver);
     my $protocol = $protocol{$homeserver};      my $protocol = $protocol{$homeserver};
     $protocol = 'http' if ($protocol ne 'https');      $protocol = 'http' if ($protocol ne 'https');
     $request=new HTTP::Request('GET',$protocol.'://'.&hostname($homeserver).'/raw/'.$uri);      $request=new HTTP::Request('GET',$protocol.'://'.$hostname.'/raw/'.$uri);
     my $response=$ua->request($request,$transferfile);      my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,$transferfile,\%perlvar,'',0,1);
 # did it work?  # did it work?
     if ($response->is_error()) {      if ($response->is_error()) {
  unlink($transferfile);   unlink($transferfile);
Line 12248  sub tokenwrapper { Line 14062  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 12266  sub getuploaded { Line 14081  sub getuploaded {
     my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;      my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
     $uri=~s/^\///;      $uri=~s/^\///;
     my $homeserver = &homeserver($cnum,$cdom);      my $homeserver = &homeserver($cnum,$cdom);
       my $hostname = &hostname($homeserver);
     my $protocol = $protocol{$homeserver};      my $protocol = $protocol{$homeserver};
     $protocol = 'http' if ($protocol ne 'https');      $protocol = 'http' if ($protocol ne 'https');
     $uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri;      $uri = $protocol.'://'.$hostname.'/raw/'.$uri;
     my $ua=new LWP::UserAgent;  
     my $request=new HTTP::Request($reqtype,$uri);      my $request=new HTTP::Request($reqtype,$uri);
     my $response=$ua->request($request);      my $response=&LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,'',0,1);
     $$rtncode = $response->code;      $$rtncode = $response->code;
     if (! $response->is_success()) {      if (! $response->is_success()) {
  return 'failed';   return 'failed';
Line 12288  sub readfile { Line 14103  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 12401  sub machine_ids { Line 14216  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 12422  sub default_login_domain { Line 14237  sub default_login_domain {
     return $domain;      return $domain;
 }  }
   
   sub shared_institution {
       my ($dom,$lonhost) = @_;
       if ($lonhost eq '') {
           $lonhost = $perlvar{'lonHostID'};
       }
       my $same_intdom;
       my $hostintdom = &internet_dom($lonhost);
       if ($hostintdom ne '') {
           my %iphost = &get_iphost();
           my $primary_id = &domain($dom,'primary');
           my $primary_ip = &get_host_ip($primary_id);
           if (ref($iphost{$primary_ip}) eq 'ARRAY') {
               foreach my $id (@{$iphost{$primary_ip}}) {
                   my $intdom = &internet_dom($id);
                   if ($intdom eq $hostintdom) {
                       $same_intdom = 1;
                       last;
                   }
               }
           }
       }
       return $same_intdom;
   }
   
   sub uses_sts {
       my ($ignore_cache) = @_;
       my $lonhost = $perlvar{'lonHostID'};
       my $hostname = &hostname($lonhost);
       my $sts_on;
       if ($protocol{$lonhost} eq 'https') {
           my $cachetime = 12*3600;
           if (!$ignore_cache) {
               ($sts_on,my $cached)=&is_cached_new('stspolicy',$lonhost);
               if (defined($cached)) {
                   return $sts_on;
               }
           }
           my $url = $protocol{$lonhost}.'://'.$hostname.'/index.html';
           my $request=new HTTP::Request('HEAD',$url);
           my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,'','','',1);
           if ($response->is_success) {
               my $has_sts = $response->header('Strict-Transport-Security');
               if ($has_sts eq '') {
                   $sts_on = 0;
               } else {
                   if ($has_sts =~ /\Qmax-age=\E(\d+)/) {
                       my $maxage = $1;
                       if ($maxage) {
                           $sts_on = 1;
                       } else {
                           $sts_on = 0;
                       }
                   } else {
                       $sts_on = 0;
                   }
               }
               return &do_cache_new('stspolicy',$lonhost,$sts_on,$cachetime);
           }
       }
       return;
   }
   
   sub 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 if ($noproxy); 
       # Who controls proxy settings for server
       my $dom_in_use = $Apache::lonnet::perlvar{'lonDefDomain'};
       my $proxyinfo = &get_proxy_settings($dom_in_use);
       if ((ref($proxyinfo) eq 'HASH') && ($from_ip)) {
           if ($proxyinfo->{'vpnint'}) {
               if (&ip_match($from_ip,$proxyinfo->{'vpnint'})) {
                   return $from_ip;
               }
           }
           if ($proxyinfo->{'trusted'}) {
               if (&ip_match($from_ip,$proxyinfo->{'trusted'})) {
                   my $ipheader = $proxyinfo->{'ipheader'};
                   my ($ip,$xfor);
                   if (ref($r)) {
                       if ($ipheader) {
                           $ip = $r->headers_in->{$ipheader};
                       }
                       $xfor = $r->headers_in->{'X-Forwarded-For'};
                   } else {
                       if ($ipheader) {
                           $ip = $ENV{'HTTP_'.uc($ipheader)};
                       }
                       $xfor = $ENV{'HTTP_X_FORWARDED_FOR'};
                   }
                   if (($ip eq '') && ($xfor ne '')) {
                       foreach my $poss_ip (reverse(split(/\s*,\s*/,$xfor))) {
                           unless (&ip_match($poss_ip,$proxyinfo->{'trusted'})) {
                               $ip = $poss_ip;
                               last;
                           }
                       }
                   }
                   if ($ip ne '') {
                       return $ip;
                   }
               }
           }
       }
       return $from_ip;
   }
   
   sub get_proxy_settings {
       my ($dom_in_use) = @_;
       my %domdefaults = &Apache::lonnet::get_domain_defaults($dom_in_use);
       my $proxyinfo = {
                          ipheader => $domdefaults{'waf_ipheader'},
                          trusted  => $domdefaults{'waf_trusted'},
                          vpnint   => $domdefaults{'waf_vpnint'},
                          vpnext   => $domdefaults{'waf_vpnext'},
                       };
       return $proxyinfo;
   }
   
   sub ip_match {
       my ($ip,$pattern_str) = @_;
       $ip=Net::CIDR::cidrvalidate($ip);
       if ($ip) {
           return Net::CIDR::cidrlookup($ip,split(/\s*,\s*/,$pattern_str));
       }
       return;
   }
   
   sub get_proxy_alias {
       my $lonhost = $perlvar{'lonHostID'};
       if ($lonhost ne '') {
           my ($alias,$cached) = &is_cached_new('proxyalias',$lonhost);
           if ($cached) {
               return $alias;
           }
           my $dom = &Apache::lonnet::host_domain($lonhost);
           if ($dom ne '') {
               my $cachetime = 60*60*24;
               my %domconfig =
                   &Apache::lonnet::get_dom('configuration',['wafproxy'],$dom);
               my $alias;
               if (ref($domconfig{'wafproxy'}) eq 'HASH') {
                   if (ref($domconfig{'wafproxy'}{'alias'}) eq 'HASH') {
                       $alias = $domconfig{'wafproxy'}{'alias'}{$lonhost};
                   }
               }
               return &do_cache_new('proxyalias',$lonhost,$alias,$cachetime);
           }
       }
       return;
   }
   
 # ------------------------------------------------------------- Declutters URLs  # ------------------------------------------------------------- Declutters URLs
   
 sub declutter {  sub declutter {
Line 12472  sub clutter { Line 14444  sub clutter {
 # &logthis("Got a blank emb style");  # &logthis("Got a blank emb style");
     }      }
  }   }
     } elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/exttools?$}) {      } elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/ext\.tool$}) {
         $thisfn='/adm/wrapper'.$thisfn;          $thisfn='/adm/wrapper'.$thisfn;
     }      }
     return $thisfn;      return $thisfn;
Line 12547  sub get_dns { Line 14519  sub get_dns {
     }      }
   
     my %alldns;      my %alldns;
     open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");      if (open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab")) {
     foreach my $dns (<$config>) {          foreach my $dns (<$config>) {
  next if ($dns !~ /^\^(\S*)/x);      next if ($dns !~ /^\^(\S*)/x);
         my $line = $1;              my $line = $1;
         my ($host,$protocol) = split(/:/,$line);              my ($host,$protocol) = split(/:/,$line);
         if ($protocol ne 'https') {              if ($protocol ne 'https') {
             $protocol = 'http';                  $protocol = 'http';
               }
       $alldns{$host} = $protocol;
         }          }
  $alldns{$host} = $protocol;          close($config);
     }      }
     while (%alldns) {      while (%alldns) {
  my ($dns) = sort { $b cmp $a } keys(%alldns);   my ($dns) = sort { $b cmp $a } keys(%alldns);
  my $ua=new LWP::UserAgent;  
         $ua->timeout(30);  
  my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");   my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
  my $response=$ua->request($request);          my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0);
         delete($alldns{$dns});          delete($alldns{$dns});
  next if ($response->is_error());   next if ($response->is_error());
  my @content = split("\n",$response->content);          if ($url eq '/adm/dns/loncapaCRL') {
  unless ($nocache) {              return &$func($response);
     &do_cache_new('dns',$url,\@content,30*24*60*60);          } else {
  }      my @content = split("\n",$response->content);
  &$func(\@content,$hashref);      unless ($nocache) {
  return;          &do_cache_new('dns',$url,\@content,30*24*60*60);
       }
       &$func(\@content,$hashref);
               return;
           }
       }
       my $which = (split('/',$url,4))[3];
       if ($which eq 'loncapaCRL') {
           my $diskfile = "$perlvar{'lonCertificateDirectory'}/$perlvar{'lonnetCertRevocationList'}";
           if (-e $diskfile) {
               &logthis("unable to contact DNS, on disk file $diskfile not updated");
           } else {
               &logthis("unable to contact DNS, no on disk file $diskfile available");
           }
       } else {
           &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");
           if (open(my $config,"<","$perlvar{'lonTabDir'}/dns_$which.tab")) {
               my @content = <$config>;
               close($config);
               &$func(\@content,$hashref);
           }
     }      }
     close($config);  
     my $which = (split('/',$url))[3];  
     &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");  
     open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab");  
     my @content = <$config>;  
     &$func(\@content,$hashref);  
     return;      return;
 }  }
   
Line 12637  sub fetch_dns_checksums { Line 14623  sub fetch_dns_checksums {
     return \%checksums;      return \%checksums;
 }  }
   
   sub fetch_crl_pemfile {
       return &get_dns("/adm/dns/loncapaCRL",\&save_crl_pem,1,1);
   }
   
   sub save_crl_pem {
       my ($response) = @_;
       my ($msg,$hadchanges);
       if (ref($response)) {
           my $now = time;
           my $lonca = $perlvar{'lonCertificateDirectory'}.'/'.$perlvar{'lonnetCertificateAuthority'};
           my $tmpcrl = $tmpdir.'/'.$perlvar{'lonnetCertRevocationList'}.'_'.$now.'.'.$$.'.tmp';
           if (open(my $fh,'>',"$tmpcrl")) {
               print $fh $response->content;
               close($fh);
               if (-e $lonca) {
                   if (open(PIPE,"openssl crl -in $tmpcrl -inform pem -CAfile $lonca -noout 2>&1 |")) {
                       my $check = <PIPE>;
                       close(PIPE);
                       chomp($check);
                       if ($check eq 'verify OK') {
                           my $dest = "$perlvar{'lonCertificateDirectory'}/$perlvar{'lonnetCertRevocationList'}";
                           my $backup;
                           if (-e $dest) {
                               if (&File::Copy::move($dest,"$dest.bak")) {
                                   $backup = 'ok';
                               }
                           }
                           if (&File::Copy::move($tmpcrl,$dest)) {
                               $msg = 'ok';
                               if ($backup) {
                                   my (%oldnums,%newnums);
                                   if (open(PIPE, "openssl crl -inform PEM -text -noout -in $dest.bak |grep 'Serial Number' |")) {
                                       while (<PIPE>) {
                                           $oldnums{(split(/:/))[1]} = 1;
                                       }
                                       close(PIPE);
                                   }
                                   if (open(PIPE, "openssl crl -inform PEM -text -noout -in $dest |grep 'Serial Number' |")) {
                                       while(<PIPE>) {
                                           $newnums{(split(/:/))[1]} = 1;
                                       }
                                       close(PIPE);
                                   }
                                   foreach my $key (sort {$b <=> $a } (keys(%newnums))) {
                                       unless (exists($oldnums{$key})) {
                                           $hadchanges = 1;
                                           last;
                                       }
                                   }
                                   unless ($hadchanges) {
                                       foreach my $key (sort {$b <=> $a } (keys(%oldnums))) {
                                           unless (exists($newnums{$key})) {
                                               $hadchanges = 1;
                                               last;
                                           }
                                       }
                                   }
                               }
                           }
                       } else {
                           unlink($tmpcrl);
                       }
                   } else {
                       unlink($tmpcrl);
                   }
               } else {
                   unlink($tmpcrl);
               }
           }
       }
       return ($msg,$hadchanges);
   }
   
 # ------------------------------------------------------------ Read domain file  # ------------------------------------------------------------ Read domain file
 {  {
     my $loaded;      my $loaded;
Line 12668  sub fetch_dns_checksums { Line 14727  sub fetch_dns_checksums {
  my ($ignore_cache,$nocache) = @_;   my ($ignore_cache,$nocache) = @_;
  &get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache,$nocache);   &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 12720  sub fetch_dns_checksums { Line 14779  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 12744  sub fetch_dns_checksums { Line 14818  sub fetch_dns_checksums {
  &purge_remembered();   &purge_remembered();
  &reset_domain_info();   &reset_domain_info();
  &reset_hosts_ip_info();   &reset_hosts_ip_info();
           undef(%internetdom);
  undef(%name_to_host);   undef(%name_to_host);
  undef(%hostname);   undef(%hostname);
  undef(%hostdom);   undef(%hostdom);
Line 12754  sub fetch_dns_checksums { Line 14829  sub fetch_dns_checksums {
     sub load_hosts_tab {      sub load_hosts_tab {
  my ($ignore_cache,$nocache) = @_;   my ($ignore_cache,$nocache) = @_;
  &get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache,$nocache);   &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 12786  sub fetch_dns_checksums { Line 14861  sub fetch_dns_checksums {
         return %hostdom;          return %hostdom;
     }      }
   
       sub all_host_intdom {
           &load_hosts_tab() if (!$loaded);
           return %internetdom;
       }
   
     sub is_library {      sub is_library {
  &load_hosts_tab() if (!$loaded);   &load_hosts_tab() if (!$loaded);
   
Line 13020  sub all_loncaparevs { Line 15100  sub all_loncaparevs {
 {  {
     sub load_loncaparevs {       sub load_loncaparevs { 
         if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") {          if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") {
             if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) {              if (open(my $config,"<","$perlvar{'lonTabDir'}/loncaparevs.tab")) {
                 while (my $configline=<$config>) {                  while (my $configline=<$config>) {
                     chomp($configline);                      chomp($configline);
                     my ($hostid,$loncaparev)=split(/:/,$configline);                      my ($hostid,$loncaparev)=split(/:/,$configline);
Line 13036  sub all_loncaparevs { Line 15116  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 13061  BEGIN { Line 15141  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 13075  BEGIN { Line 15155  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 13089  BEGIN { Line 15169  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 13109  BEGIN { Line 15189  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 13163  BEGIN { Line 15243  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 13182  BEGIN { Line 15262  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 13521  prevents recursive calls to &allowed. Line 15611  prevents recursive calls to &allowed.
  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.   B: access temporarily blocked because of a blocking event in a course.
    D: access blocked because access is required via session initiated via deep-link 
   
 =item *  =item *
   
Line 13539  in which case the null string is returne Line 15630  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 13745  Inputs: Line 15837  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 13848  Returns: Line 15942  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 13899  condval($condidx) : value of condition i Line 16075  condval($condidx) : value of condition i
   
 =item *  =item *
   
 metadata($uri,$what,$liburi,$prefix,$depthcount) : request a  metadata($uri,$what,$toolsymb,$liburi,$prefix,$depthcount) : request a
 resource's metadata, $what should be either a specific key, or either  resource's metadata, $what should be either a specific key, or either
 'keys' (to get a list of possible keys) or 'packages' to get a list of  'keys' (to get a list of possible keys) or 'packages' to get a list of
 packages that this resource currently uses, the last 3 arguments are only used internally for recursive metadata.  packages that this resource currently uses, the last 3 arguments are 
   only used internally for recursive metadata.
   
   the toolsymb is only used where the uri is for an external tool (for which
   the uri as well as the symb are guaranteed to be unique).
   
 this function automatically caches all requests  this function automatically caches all requests except any made recursively
   to retrieve a list of metadata keys for an imported library file ($liburi is 
   defined).
   
 =item *  =item *
   
Line 14539  userspace, probably shouldn't be called Line 16721  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.1311  
changed lines
  Added in v.1.1442

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