[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.1385 and 1.1456

version 1.1385, 2018/09/21 03:38:44 version 1.1456, 2021/06/06 23:14:18
Line 73  package Apache::lonnet; Line 73  package Apache::lonnet;
 use strict;  use strict;
 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 96  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 Sys::Hostname::FQDN();
 use LONCAPA qw(:DEFAULT :match);  use LONCAPA qw(:DEFAULT :match);
 use LONCAPA::Configuration;  use LONCAPA::Configuration;
 use LONCAPA::lonmetadata;  use LONCAPA::lonmetadata;
 use LONCAPA::Lond;  use LONCAPA::Lond;
 use LONCAPA::LWPReq;  use LONCAPA::LWPReq;
   use LONCAPA::transliterate;
   
 use File::Copy;  use File::Copy;
   
Line 127  our @EXPORT = qw(%env); Line 130  our @EXPORT = qw(%env);
  $logid ++;   $logid ++;
         my $now = time();          my $now = time();
  my $id=$now.'00000'.$$.'00000'.$logid;   my $id=$now.'00000'.$$.'00000'.$logid;
           my $ip = &get_requestor_ip();
         my $logentry = {           my $logentry = { 
                           $id => {                            $id => {
                                    'exe_uname' => $env{'user.name'},                                     'exe_uname' => $env{'user.name'},
                                    'exe_udom'  => $env{'user.domain'},                                     'exe_udom'  => $env{'user.domain'},
                                    'exe_time'  => $now,                                     'exe_time'  => $now,
                                    'exe_ip'    => $ENV{'REMOTE_ADDR'},                                     'exe_ip'    => $ip,
                                    'delflag'   => $delflag,                                     'delflag'   => $delflag,
                                    'logentry'  => $storehash,                                     'logentry'  => $storehash,
                                    'uname'     => $uname,                                     'uname'     => $uname,
Line 184  sub create_connection { Line 188  sub create_connection {
      Type    => SOCK_STREAM,       Type    => SOCK_STREAM,
      Timeout => 10);       Timeout => 10);
     return 0 if (!$client);      return 0 if (!$client);
     print $client (join(':',$hostname,$lonid,&machine_ids($hostname))."\n");      print $client (join(':',$hostname,$lonid,&machine_ids($hostname),$loncaparevs{$lonid})."\n");
     my $result = <$client>;      my $result = <$client>;
     chomp($result);      chomp($result);
     return 1 if ($result eq 'done');      return 1 if ($result eq 'done');
Line 237  sub get_servercerts_info { Line 241  sub get_servercerts_info {
     }      }
     return if ($hostname eq '');      return if ($hostname eq '');
     my ($rep,$uselocal);      my ($rep,$uselocal);
     if (grep { $_ eq $lonhost } &current_machine_ids()) {      if ($context eq 'install') {
           $uselocal = 1;
       } elsif (grep { $_ eq $lonhost } &current_machine_ids()) {
         $uselocal = 1;          $uselocal = 1;
     }      }
     if (($context ne 'cgi') && ($uselocal)) {      if (($context ne 'cgi') && ($context ne 'install') && ($uselocal)) {
         my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0];          my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0];
         if ($distro eq '') {          if ($distro eq '') {
             $uselocal = 0;              $uselocal = 0;
Line 309  sub get_server_loncaparev { Line 315  sub get_server_loncaparev {
             $answer = &reply('serverloncaparev',$lonhost);              $answer = &reply('serverloncaparev',$lonhost);
             if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) {              if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) {
                 if ($caller eq 'loncron') {                  if ($caller eq 'loncron') {
                       my $hostname = &hostname($lonhost);
                     my $protocol = $protocol{$lonhost};                      my $protocol = $protocol{$lonhost};
                     $protocol = 'http' if ($protocol ne 'https');                      $protocol = 'http' if ($protocol ne 'https');
                     my $url = $protocol.'://'.&hostname($lonhost).'/adm/about.html';                      my $url = $protocol.'://'.$hostname.'/adm/about.html';
                     my $request=new HTTP::Request('GET',$url);                      my $request=new HTTP::Request('GET',$url);
                     my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,4,1);                      my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,4,1);
                     unless ($response->is_error()) {                      unless ($response->is_error()) {
Line 456  sub reply { Line 463  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 669  sub check_for_valid_session { Line 694  sub check_for_valid_session {
             $lonid=$cookies{$secure};              $lonid=$cookies{$secure};
         } elsif (exists($cookies{$name})) {          } elsif (exists($cookies{$name})) {
             $lonid=$cookies{$name};              $lonid=$cookies{$name};
         } elsif (exists($cookies{$linkname})) {          } elsif ((exists($cookies{$linkname})) && ($ENV{'SERVER_PORT'} != 443)) {
             $lonid=$cookies{$linkname};              $lonid=$cookies{$linkname};
         } elsif (exists($cookies{$pubname})) {          } elsif (exists($cookies{$pubname})) {
             $lonid=$cookies{$pubname};              $lonid=$cookies{$pubname};
Line 709  sub check_for_valid_session { Line 734  sub check_for_valid_session {
   
     if (!defined($disk_env{'user.name'})      if (!defined($disk_env{'user.name'})
  || !defined($disk_env{'user.domain'})) {   || !defined($disk_env{'user.domain'})) {
           untie(%disk_env);
  return undef;   return undef;
     }      }
   
     if (ref($userhashref) eq 'HASH') {      if (ref($userhashref) eq 'HASH') {
         $userhashref->{'name'} = $disk_env{'user.name'};          $userhashref->{'name'} = $disk_env{'user.name'};
         $userhashref->{'domain'} = $disk_env{'user.domain'};          $userhashref->{'domain'} = $disk_env{'user.domain'};
           if ($disk_env{'request.role'}) {
               $userhashref->{'role'} = $disk_env{'request.role'};
           }
         $userhashref->{'lti'} = $disk_env{'request.lti.login'};          $userhashref->{'lti'} = $disk_env{'request.lti.login'};
         if ($userhashref->{'lti'}) {          if ($userhashref->{'lti'}) {
             $userhashref->{'ltitarget'} = $disk_env{'request.lti.target'};              $userhashref->{'ltitarget'} = $disk_env{'request.lti.target'};
             $userhashref->{'ltiuri'} = $disk_env{'request.lti.uri'};              $userhashref->{'ltiuri'} = $disk_env{'request.lti.uri'};
         }          }
     }      }
       untie(%disk_env);
   
     return $handle;      return $handle;
 }  }
Line 745  sub timed_flock { Line 775  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 898  sub userload { Line 959  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 915  sub userload { Line 977  sub userload {
 # ------------------------------ Find server with least workload from spare.tab  # ------------------------------ Find server with least workload from spare.tab
   
 sub spareserver {  sub spareserver {
     my ($loadpercent,$userloadpercent,$want_server_name,$udom) = @_;      my ($r,$loadpercent,$userloadpercent,$want_server_name,$udom) = @_;
     my $spare_server;      my $spare_server;
     if ($userloadpercent !~ /\d/) { $userloadpercent=0; }      if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
     my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent       my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent 
Line 953  sub spareserver { Line 1015  sub spareserver {
     }      }
   
     if (!$want_server_name) {      if (!$want_server_name) {
         my $protocol = 'http';  
         if ($protocol{$spare_server} eq 'https') {  
             $protocol = $protocol{$spare_server};  
         }  
         if (defined($spare_server)) {          if (defined($spare_server)) {
             my $hostname = &hostname($spare_server);              my $hostname = &hostname($spare_server);
             if (defined($hostname)) {              if (defined($hostname)) {
                   my $protocol = 'http';
                   if ($protocol{$spare_server} eq 'https') {
                       $protocol = $protocol{$spare_server};
                   }
                   my $alias = &Apache::lonnet::use_proxy_alias($r,$spare_server);
                   $hostname = $alias if ($alias ne '');
         $spare_server = $protocol.'://'.$hostname;          $spare_server = $protocol.'://'.$hostname;
             }              }
         }          }
Line 1026  sub find_existing_session { Line 1090  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 1061  sub choose_server { Line 1222  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 1092  sub choose_server { Line 1253  sub choose_server {
     return ($login_host,$hostname,$portal_path,$isredirect,$lowest_load);      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
   
 sub changepass {  sub changepass {
Line 1127  sub changepass { Line 1310  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 1265  sub spare_can_host { Line 1451  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 1363  sub get_lonbalancer_config { Line 1558  sub get_lonbalancer_config {
 sub check_loadbalancing {  sub check_loadbalancing {
     my ($uname,$udom,$caller) = @_;      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 1390  sub check_loadbalancing { Line 1585  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 1451  sub check_loadbalancing { Line 1646  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 1483  sub check_loadbalancing { Line 1678  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 1517  sub check_loadbalancing { Line 1712  sub check_loadbalancing {
                 $is_balancer = 0;                  $is_balancer = 0;
                 if ($uname ne '' && $udom ne '') {                  if ($uname ne '' && $udom ne '') {
                     if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {                      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 1539  sub check_balancer_result { Line 1736  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 1629  sub trusted_domains { Line 1831  sub trusted_domains {
     if (&domain($calldom) eq '') {      if (&domain($calldom) eq '') {
         return ($trusted,$untrusted);          return ($trusted,$untrusted);
     }      }
     unless ($cmdtype =~ /^(content|shared|enroll|coaurem|domroles|catalog|reqcrs|msg)$/) {      unless ($cmdtype =~ /^(content|shared|enroll|coaurem|othcoau|domroles|catalog|reqcrs|msg)$/) {
         return ($trusted,$untrusted);          return ($trusted,$untrusted);
     }      }
     my $callprimary = &domain($calldom,'primary');      my $callprimary = &domain($calldom,'primary');
Line 1651  sub trusted_domains { Line 1853  sub trusted_domains {
                 map { $possexc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'exc'}};                   map { $possexc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'exc'}}; 
             }              }
             if (ref($trustconfig->{$cmdtype}->{'inc'}) eq 'ARRAY') {              if (ref($trustconfig->{$cmdtype}->{'inc'}) eq 'ARRAY') {
                   $possinc{$intcalldom} = 1;
                 map { $possinc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'inc'}};                  map { $possinc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'inc'}};
             }              }
         }          }
Line 1685  sub trusted_domains { Line 1888  sub trusted_domains {
             }              }
             foreach my $exc (@allexc) {              foreach my $exc (@allexc) {
                 if (ref($doms_by_intdom{$exc}) eq 'ARRAY') {                  if (ref($doms_by_intdom{$exc}) eq 'ARRAY') {
                     $untrusted = $doms_by_intdom{$exc};                      push(@{$untrusted},@{$doms_by_intdom{$exc}});
                 }                  }
             }              }
             foreach my $inc (@allinc) {              foreach my $inc (@allinc) {
                 if (ref($doms_by_intdom{$inc}) eq 'ARRAY') {                  if (ref($doms_by_intdom{$inc}) eq 'ARRAY') {
                     $trusted = $doms_by_intdom{$inc};                      push(@{$trusted},@{$doms_by_intdom{$inc}});
                 }                  }
             }              }
         }          }
Line 1967  sub get_dom { Line 2170  sub get_dom {
     }      }
     if ($udom && $uhome && ($uhome ne 'no_host')) {      if ($udom && $uhome && ($uhome ne 'no_host')) {
         my $rep;          my $rep;
         if ($namespace =~ /^enc/) {          if (grep { $_ eq $uhome } &current_machine_ids()) {
             $rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome);              # 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 {          } else {
             $rep=&reply("getdom:$udom:$namespace:$items",$uhome);              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 /) {
Line 2112  sub inst_directory_query { Line 2324  sub inst_directory_query {
     if ($homeserver ne '') {      if ($homeserver ne '') {
         unless ($homeserver eq $perlvar{'lonHostID'}) {          unless ($homeserver eq $perlvar{'lonHostID'}) {
             if ($srch->{'srchby'} eq 'email') {              if ($srch->{'srchby'} eq 'email') {
                 my $lcrev = &get_server_loncaparev(undef,$homeserver);                  my $lcrev = &get_server_loncaparev($udom,$homeserver);
                 my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);                  my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
                 if (($major eq '' && $minor eq '') || ($major < 2) ||                  if (($major eq '' && $minor eq '') || ($major < 2) ||
                     (($major == 2) && ($minor < 12))) {                      (($major == 2) && ($minor < 12))) {
Line 2163  sub usersearch { Line 2375  sub usersearch {
         if (&host_domain($tryserver) eq $dom) {          if (&host_domain($tryserver) eq $dom) {
             unless ($tryserver eq $perlvar{'lonHostID'}) {              unless ($tryserver eq $perlvar{'lonHostID'}) {
                 if ($srch->{'srchby'} eq 'email') {                  if ($srch->{'srchby'} eq 'email') {
                     my $lcrev = &get_server_loncaparev(undef,$tryserver);                      my $lcrev = &get_server_loncaparev($dom,$tryserver);
                     my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);                      my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
                     next if (($major eq '' && $minor eq '') || ($major < 2) ||                      next if (($major eq '' && $minor eq '') || ($major < 2) ||
                              (($major == 2) && ($minor < 12)));                               (($major == 2) && ($minor < 12)));
Line 2408  sub get_domain_defaults { Line 2620  sub get_domain_defaults {
                                   'coursedefaults','usersessions',                                    'coursedefaults','usersessions',
                                   'requestauthor','selfenrollment',                                    'requestauthor','selfenrollment',
                                   'coursecategories','ssl','autoenroll',                                    'coursecategories','ssl','autoenroll',
                                   'trust','helpsettings'],$domain);                                    '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 2501  sub get_domain_defaults { Line 2713  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 2533  sub get_domain_defaults { Line 2748  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'}) {
Line 2568  sub get_domain_defaults { Line 2783  sub get_domain_defaults {
             $domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'};              $domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'};
         }          }
     }      }
       if (ref($domconfig{'wafproxy'}) eq 'HASH') {
           foreach my $item ('ipheader','trusted','vpnint','vpnext','sslopt') {
               if ($domconfig{'wafproxy'}{$item}) {
                   $domdefaults{'waf_'.$item} = $domconfig{'wafproxy'}{$item};
               }
           }
       } 
     &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,$r) = @_;
     my $chome = &homeserver($cnum,$cdom);      my $chome = &homeserver($cnum,$cdom);
     my $hostname = &hostname($chome);      my $hostname = &hostname($chome);
     my $protocol = $protocol{$chome};      my $protocol = $protocol{$chome};
Line 2583  sub course_portal_url { Line 2864  sub course_portal_url {
     if ($domdefaults{'portal_def'}) {      if ($domdefaults{'portal_def'}) {
         $firsturl = $domdefaults{'portal_def'};          $firsturl = $domdefaults{'portal_def'};
     } else {      } else {
           my $alias = &Apache::lonnet::use_proxy_alias($r,$chome);
           $hostname = $alias if ($alias ne '');
         $firsturl = $protocol.'://'.$hostname;          $firsturl = $protocol.'://'.$hostname;
     }      }
     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 3130  sub repcopy { Line 3436  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 3158  sub ssi_body { Line 3490  sub ssi_body {
 # --------------------------------------------------------- Server Side Include  # --------------------------------------------------------- Server Side Include
   
 sub absolute_url {  sub absolute_url {
     my ($host_name) = @_;      my ($host_name,$unalias,$keep_proto) = @_;
     my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');      my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');
     if ($host_name eq '') {      if ($host_name eq '') {
  $host_name = $ENV{'SERVER_NAME'};   $host_name = $ENV{'SERVER_NAME'};
     }      }
       if ($unalias) {
           my $alias = &get_proxy_alias();
           if ($alias eq $host_name) {
               my $lonhost = $perlvar{'lonHostID'};
               my $hostname = &hostname($lonhost);
               my $lcproto; 
               if (($keep_proto) || ($hostname eq '')) {
                   $lcproto = $protocol;
               } else {
                   $lcproto = $protocol{$lonhost};
                   $lcproto = 'http' if ($lcproto ne 'https');
                   $lcproto .= '://';
               }
               unless ($hostname eq '') {
                   return $lcproto.$hostname;
               }
           }
       }
     return $protocol.$host_name;      return $protocol.$host_name;
 }  }
   
Line 3179  sub absolute_url { Line 3529  sub absolute_url {
 sub ssi {  sub ssi {
   
     my ($fn,%form)=@_;      my ($fn,%form)=@_;
     my $request;      my ($host,$request,$response);
       $host = &absolute_url('',1);
   
     $form{'no_update_last_known'}=1;      $form{'no_update_last_known'}=1;
     &Apache::lonenc::check_encrypt(\$fn);      &Apache::lonenc::check_encrypt(\$fn);
     if (%form) {      if (%form) {
       $request=new HTTP::Request('POST',&absolute_url().$fn);        $request=new HTTP::Request('POST',$host.$fn);
       $request->content(join('&',map {         $request->content(join('&',map { 
             my $name = escape($_);              my $name = escape($_);
             "$name=" . ( ref($form{$_}) eq 'ARRAY'               "$name=" . ( ref($form{$_}) eq 'ARRAY' 
Line 3192  sub ssi { Line 3543  sub ssi {
             : &escape($form{$_}) );                  : &escape($form{$_}) );    
         } keys(%form)));          } keys(%form)));
     } else {      } else {
       $request=new HTTP::Request('GET',&absolute_url().$fn);        $request=new HTTP::Request('GET',$host.$fn);
     }      }
   
     $request->header(Cookie => $ENV{'HTTP_COOKIE'});      $request->header(Cookie => $ENV{'HTTP_COOKIE'});
Line 3206  sub ssi { Line 3557  sub ssi {
                                  ($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:'')))) {                                   ($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:'')))) {
         $islocal = 1;          $islocal = 1;
     }      }
     my $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,      $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,
                                                 '','','',$islocal);                                               '','','',$islocal);
   
     if (wantarray) {      if (wantarray) {
  return ($response->content, $response);   return ($response->content, $response);
Line 3245  sub remove_stale_resfile { Line 3596  sub remove_stale_resfile {
                     (grep { $_ eq $homeserver } &current_machine_ids())) {                      (grep { $_ eq $homeserver } &current_machine_ids())) {
                 my $fname = &filelocation('',$url);                  my $fname = &filelocation('',$url);
                 if (-e $fname) {                  if (-e $fname) {
                     my $protocol = $protocol{$homeserver};  
                     $protocol = 'http' if ($protocol ne 'https');  
                     my $hostname = &hostname($homeserver);                      my $hostname = &hostname($homeserver);
                     if ($hostname) {                      if ($hostname) {
                           my $protocol = $protocol{$homeserver};
                           $protocol = 'http' if ($protocol ne 'https');
                         my $uri = &declutter($url);                          my $uri = &declutter($url);
                         my $request=new HTTP::Request('HEAD',$protocol.'://'.$hostname.'/raw/'.$uri);                          my $request=new HTTP::Request('HEAD',$protocol.'://'.$hostname.'/raw/'.$uri);
                         my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,5,0,1);                          my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,5,0,1);
Line 3275  sub remove_stale_resfile { Line 3626  sub remove_stale_resfile {
                                     $stale = 1;                                      $stale = 1;
                                 }                                  }
                                 if ($stale) {                                  if ($stale) {
                                     unlink($fname);                                      if (unlink($fname)) {
                                     if ($uri!~/\.meta$/) {                                          if ($uri!~/\.meta$/) {
                                         unlink($fname.'.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;
                                     }                                      }
                                     &reply("unsub:$fname",$homeserver);  
                                     $removed = 1;  
                                 }                                  }
                             }                              }
                         }                          }
Line 3430  sub can_edit_resource { Line 3787  sub can_edit_resource {
                         $forceedit = 1;                          $forceedit = 1;
                     }                      }
                     $cfile = $resurl;                      $cfile = $resurl;
                   } elsif (($resurl =~ m{^/ext/}) && ($symb ne '')) {
                       my ($map,$id,$res) = &decode_symb($symb);
                       if ($map =~ /\.page$/) {
                           $incourse = 1;
                           if ($env{'form.forceedit'}) {
                               $forceview = 1;
                               $cfile = $map;
                           } else {
                               $forceedit = 1;
                               $cfile =  '/adm/wrapper'.$resurl;
                           }
                       }
                 } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) {                  } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) {
                     $incourse = 1;                      $incourse = 1;
                     if ($env{'form.forceedit'}) {                      if ($env{'form.forceedit'}) {
Line 3455  sub can_edit_resource { Line 3824  sub can_edit_resource {
                     $cfile = $template;                      $cfile = $template;
                 }                  }
             } elsif (($resurl =~ m{^/adm/wrapper/ext/}) && ($env{'form.folderpath'} =~ /^supplemental/)) {              } elsif (($resurl =~ m{^/adm/wrapper/ext/}) && ($env{'form.folderpath'} =~ /^supplemental/)) {
                     $incourse = 1;                  $incourse = 1;
                     if ($env{'form.forceedit'}) {                  if ($env{'form.forceedit'}) {
                         $forceview = 1;                      $forceview = 1;
                     } else {                  } else {
                         $forceedit = 1;                      $forceedit = 1;
                     }                  }
                     $cfile = $resurl;                  $cfile = $resurl;
             } elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($env{'form.folderpath'} =~ /^supplemental/)) {              } 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'}) {
Line 3724  sub clean_filename { Line 4093  sub clean_filename {
     }      }
 # Replace spaces by underscores  # Replace spaces by underscores
     $fname=~s/\s+/\_/g;      $fname=~s/\s+/\_/g;
   # Transliterate non-ascii text to ascii
       my $lang = &Apache::lonlocal::current_language();
       $fname = &LONCAPA::transliterate::fname_to_ascii($fname,$lang);
 # Replace all other weird characters by nothing  # Replace all other weird characters by nothing
     $fname=~s{[^/\w\.\-]}{}g;      $fname=~s{[^/\w\.\-]}{}g;
 # Replace all .\d. sequences with _\d. so they no longer look like version  # Replace all .\d. sequences with _\d. so they no longer look like version
 # numbers  # numbers
     $fname=~s/\.(\d+)(?=\.)/_$1/g;      $fname=~s/\.(\d+)(?=\.)/_$1/g;
   # Replace three or more adjacent underscores with one for consistency 
   # with loncfile::filename_check() so complete url can be extracted by
   # lonnet::decode_symb()
       $fname=~s/_{3,}/_/g;
     return $fname;      return $fname;
 }  }
   
 # This Function checks if an Image's dimensions exceed either $resizewidth (width)   # This Function checks if an Image's dimensions exceed either $resizewidth (width) 
 # or $resizeheight (height) - both pixels. If so, the image is scaled to produce an   # or $resizeheight (height) - both pixels. If so, the image is scaled to produce an 
 # image with the same aspect ratio as the original, but with dimensions which do   # image with the same aspect ratio as the original, but with dimensions which do 
Line 3773  sub resizeImage { Line 4150  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 3802  sub userfileupload { Line 4182  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 3969  sub finishuserfileupload { Line 4357  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 3978  sub finishuserfileupload { Line 4366  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;
Line 4218  sub embedded_dependency { Line 4609  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 4444  sub courseacclog { Line 5075  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 5241  sub set_first_access { Line 5876  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 5257  sub set_first_access { Line 5897  sub set_first_access {
             if (($cachedtime) && (abs($start-$cachedtime) < 5)) {              if (($cachedtime) && (abs($start-$cachedtime) < 5)) {
                 $cachedtimes{"$courseid\0$res"} = $start;                  $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 5518  sub tmpreset { Line 6161  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 5555  sub tmpstore { Line 6198  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 5599  sub tmprestore { Line 6242  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 5655  sub store { Line 6298  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 5691  sub cstore { Line 6334  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 6397  sub set_adhoc_privileges { Line 7040  sub set_adhoc_privileges {
     my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%rolehash);      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 ".$spec);      &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'  => $sec,                    'request.course.sec'  => $sec,
Line 6685  sub putstore { Line 7329  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 7472  sub customaccess { Line 8117  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 7489  sub allowed { Line 8134  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|ext\.tool)$}))       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 7598  sub allowed { Line 8243  sub allowed {
                         my $adom = $1;                          my $adom = $1;
                         foreach my $key (keys(%env)) {                          foreach my $key (keys(%env)) {
                             if ($key =~ m{^user\.role\.(ca|aa)/\Q$adom\E}) {                              if ($key =~ m{^user\.role\.(ca|aa)/\Q$adom\E}) {
                                 my ($start,$end) = split('.',$env{$key});                                  my ($start,$end) = split(/\./,$env{$key});
                                 if (($now >= $start) && (!$end || $end < $now)) {                                  if (($now >= $start) && (!$end || $end > $now)) {
                                     $ownaccess = 1;                                      $ownaccess = 1;
                                     last;                                      last;
                                 }                                  }
Line 7611  sub allowed { Line 8256  sub allowed {
                         foreach my $role ('ca','aa') {                           foreach my $role ('ca','aa') { 
                             if ($env{"user.role.$role./$adom/$aname"}) {                              if ($env{"user.role.$role./$adom/$aname"}) {
                                 my ($start,$end) =                                  my ($start,$end) =
                                     split('.',$env{"user.role.$role./$adom/$aname"});                                      split(/\./,$env{"user.role.$role./$adom/$aname"});
                                 if (($now >= $start) && (!$end || $end < $now)) {                                  if (($now >= $start) && (!$end || $end > $now)) {
                                     $ownaccess = 1;                                      $ownaccess = 1;
                                     last;                                      last;
                                 }                                  }
Line 7657  sub allowed { Line 8302  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 7671  sub allowed { Line 8342  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 7691  sub allowed { Line 8365  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 7741  sub allowed { Line 8418  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 7757  sub allowed { Line 8444  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 7770  sub allowed { Line 8457  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 7796  sub allowed { Line 8483  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 7841  sub allowed { Line 8531  sub allowed {
 #  #
   
 # Possibly locked functionality, check all courses  # Possibly locked functionality, check all courses
   # In roles.tab, L (unless locked) available for bre, pch, plc, pac and sma.
 # Locks might take effect only after 10 minutes cache expiration for other  # Locks might take effect only after 10 minutes cache expiration for other
 # courses, and 2 minutes for current course  # courses, and 2 minutes for current course, in which user has st or ta role
   # which is neither expired nor a future role (unless current course).
   
     my $envkey;      my ($needlockcheck,$now,$crsonly);
     if ($thisallowed=~/L/) {      if ($thisallowed=~/L/) {
         foreach $envkey (keys(%env)) {          $now = time;
           if ($priv eq 'bre') {
               if ($uri ne '') {
                   if ($orguri =~ m{^/+res/}) {
                       if ($uri =~ m{^lib/templates/}) {
                           if ($env{'request.course.id'}) {
                               $crsonly = 1;
                               $needlockcheck = 1;
                           }
                       } else {
                           $needlockcheck = 1;
                       }
                   } elsif ($env{'request.course.id'}) {
                       my ($crsdom,$crsnum) = split('_',$env{'request.course.id'});
                       if (($uri =~ m{^(adm|uploaded|public)/$crsdom/$crsnum/}) ||
                           ($uri =~ m{^adm/$match_domain/$match_username/\d+/(smppg|bulletinboard)$})) {
                           $crsonly = 1;
                       }
                       $needlockcheck = 1;
                   }
               }
           } elsif (($priv eq 'pch') || ($priv eq 'plc') || ($priv eq 'pac') || ($priv eq 'sma')) {
               $needlockcheck = 1;
           }
       }
       if ($needlockcheck) {
           foreach my $envkey (keys(%env)) {
            if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {             if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
                my $courseid=$2;                 my $courseid=$2;
                my $roleid=$1.'.'.$2;                 my $roleid=$1.'.'.$2;
                $courseid=~s/^\///;                 $courseid=~s/^\///;
                  unless ($env{'request.role'} eq $roleid) {
                      my ($start,$end) = split(/\./,$env{$envkey});
                      next unless (($now >= $start) && (!$end || $end > $now));
                  }
                my $expiretime=600;                 my $expiretime=600;
                if ($env{'request.role'} eq $roleid) {                 if ($env{'request.role'} eq $roleid) {
   $expiretime=120;    $expiretime=120;
Line 7873  sub allowed { Line 8595  sub allowed {
                }                 }
                if (($env{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/)                 if (($env{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/)
                 || ($env{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {                  || ($env{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {
    if ($env{'priv.'.$priv.'.lock.expire'}>time) {     if ($env{$prefix.'priv.'.$priv.'.lock.expire'}>time) {
                        &log($env{'user.domain'},$env{'user.name'},                         &log($env{'user.domain'},$env{'user.name'},
                             $env{'user.home'},                              $env{'user.home'},
                             'Locked by priv: '.$priv.' for '.$uri.' due to '.                              'Locked by priv: '.$priv.' for '.$uri.' due to '.
Line 7885  sub allowed { Line 8607  sub allowed {
    }     }
        }         }
     }      }
      
 #  #
 # Rest of the restrictions depend on selected course  # Rest of the restrictions depend on selected course
 #  #
Line 7964  sub allowed { Line 8686  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 8052  sub constructaccess { Line 8776  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 8147  sub get_commblock_resources { Line 8876  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 8205  sub get_commblock_resources { Line 8943  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 8226  sub has_comm_blocking { Line 8970  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 8651  sub auto_validate_instcode { Line 9486  sub auto_validate_instcode {
     return ($outcome,$description,$defaultcredits);      return ($outcome,$description,$defaultcredits);
 }  }
   
   sub auto_validate_inst_crosslist {
       my ($cnum,$cdom,$instcode,$inst_xlist,$coowner) = @_;
       my ($homeserver,$response);
       if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
           $homeserver = &homeserver($cnum,$cdom);
       }
       if (!defined($homeserver)) {
           if ($cdom =~ /^$match_domain$/) {
               $homeserver = &domain($cdom,'primary');
           }
       }
       unless (($homeserver eq '') || ($homeserver eq 'no_host')) {
           $response=&reply('autovalidateinstcrosslist:'.$cdom.':'.
                            &escape($instcode).':'.&escape($inst_xlist).':'.
                            &escape($coowner),$homeserver);
       }
       return $response;
   }
   
 sub auto_create_password {  sub auto_create_password {
     my ($cnum,$cdom,$authparam,$udom) = @_;      my ($cnum,$cdom,$authparam,$udom) = @_;
     my ($homeserver,$response);      my ($homeserver,$response);
Line 9472  sub autoupdate_coowners { Line 10326  sub autoupdate_coowners {
         if ($domdesign{$cdom.'.autoassign.co-owners'}) {          if ($domdesign{$cdom.'.autoassign.co-owners'}) {
             my %coursehash = &coursedescription($cdom.'_'.$cnum);              my %coursehash = &coursedescription($cdom.'_'.$cnum);
             my $instcode = $coursehash{'internal.coursecode'};              my $instcode = $coursehash{'internal.coursecode'};
               my $xlists = $coursehash{'internal.crosslistings'};
             if ($instcode ne '') {              if ($instcode ne '') {
                 if (($start && $start <= $now) && ($end == 0) || ($end > $now)) {                  if (($start && $start <= $now) && ($end == 0) || ($end > $now)) {
                     unless ($coursehash{'internal.courseowner'} eq $uname.':'.$udom) {                      unless ($coursehash{'internal.courseowner'} eq $uname.':'.$udom) {
                         my ($delcoowners,@newcoowners,$putresult,$delresult,$coowners);                          my ($delcoowners,@newcoowners,$putresult,$delresult,$coowners);
                         my ($result,$desc) = &auto_validate_instcode($cnum,$cdom,$instcode,$uname.':'.$udom);                          my ($result,$desc) = &auto_validate_instcode($cnum,$cdom,$instcode,$uname.':'.$udom);
                           unless ($result eq 'valid') {
                               if ($xlists ne '') {
                                   foreach my $xlist (split(',',$xlists)) {
                                       my ($inst_crosslist,$lcsec) = split(':',$xlist);
                                       $result =
                                           &auto_validate_inst_crosslist($cnum,$cdom,$instcode,
                                                                         $inst_crosslist,$uname.':'.$udom);
                                       last if ($result eq 'valid');
                                   }
                               }
                           }
                         if ($result eq 'valid') {                          if ($result eq 'valid') {
                             if ($coursehash{'internal.co-owners'}) {                              if ($coursehash{'internal.co-owners'}) {
                                 foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {                                  foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
Line 9489  sub autoupdate_coowners { Line 10355  sub autoupdate_coowners {
                             } else {                              } else {
                                 push(@newcoowners,$uname.':'.$udom);                                  push(@newcoowners,$uname.':'.$udom);
                             }                              }
                         } else {                          } elsif ($coursehash{'internal.co-owners'}) {
                             if ($coursehash{'internal.co-owners'}) {                              foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
                                 foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {                                  unless ($coowner eq $uname.':'.$udom) {
                                     unless ($coowner eq $uname.':'.$udom) {                                      push(@newcoowners,$coowner);
                                         push(@newcoowners,$coowner);  
                                     }  
                                 }  
                                 unless (@newcoowners > 0) {  
                                     $delcoowners = 1;  
                                     $coowners = '';  
                                 }                                  }
                             }                              }
                               unless (@newcoowners > 0) {
                                   $delcoowners = 1;
                                   $coowners = '';
                               }
                         }                          }
                         if (@newcoowners || $delcoowners) {                          if (@newcoowners || $delcoowners) {
                             &store_coowners($cdom,$cnum,$coursehash{'home'},                              &store_coowners($cdom,$cnum,$coursehash{'home'},
Line 9553  sub store_coowners { Line 10417  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 9894  sub writecoursepref { Line 10774  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 10086  sub store_userdata { Line 10971  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 11633  sub EXT { Line 12518  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 12461  sub symbverify { Line 13350  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 12572  sub deversion { Line 13459  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 12607  sub symbread { Line 13497  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 12643  sub symbread { Line 13541  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 12668  sub symbread { Line 13571  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 12681  sub symbread { Line 13585  sub symbread {
                                      $syval = $poss_syval;                                       $syval = $poss_syval;
                                      $realpossible++;                                       $realpossible++;
                                  }                                   }
                                    if ($syval) {
                                        if (ref($possibles) eq 'HASH') {
                                            $possibles->{$syval} = 1;
                                        }
                                    }
                              }                               }
  }   }
                      }                       }
Line 13218  sub repcopy_userfile { Line 14127  sub repcopy_userfile {
     my $request;      my $request;
     $uri=~s/^\///;      $uri=~s/^\///;
     my $homeserver = &homeserver($cnum,$cdom);      my $homeserver = &homeserver($cnum,$cdom);
       my $hostname = &hostname($homeserver);
     my $protocol = $protocol{$homeserver};      my $protocol = $protocol{$homeserver};
     $protocol = 'http' if ($protocol ne 'https');      $protocol = 'http' if ($protocol ne 'https');
     $request=new HTTP::Request('GET',$protocol.'://'.&hostname($homeserver).'/raw/'.$uri);      $request=new HTTP::Request('GET',$protocol.'://'.$hostname.'/raw/'.$uri);
     my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,$transferfile,\%perlvar,'',0,1);      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()) {
Line 13244  sub tokenwrapper { Line 14154  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 13262  sub getuploaded { Line 14173  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 $request=new HTTP::Request($reqtype,$uri);      my $request=new HTTP::Request($reqtype,$uri);
     my $response=&LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,'',0,1);      my $response=&LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,'',0,1);
     $$rtncode = $response->code;      $$rtncode = $response->code;
Line 13417  sub default_login_domain { Line 14329  sub default_login_domain {
     return $domain;      return $domain;
 }  }
   
   sub shared_institution {
       my ($dom,$lonhost) = @_;
       if ($lonhost eq '') {
           $lonhost = $perlvar{'lonHostID'};
       }
       my $same_intdom;
       my $hostintdom = &internet_dom($lonhost);
       if ($hostintdom ne '') {
           my %iphost = &get_iphost();
           my $primary_id = &domain($dom,'primary');
           my $primary_ip = &get_host_ip($primary_id);
           if (ref($iphost{$primary_ip}) eq 'ARRAY') {
               foreach my $id (@{$iphost{$primary_ip}}) {
                   my $intdom = &internet_dom($id);
                   if ($intdom eq $hostintdom) {
                       $same_intdom = 1;
                       last;
                   }
               }
           }
       }
       return $same_intdom;
   }
   
   sub uses_sts {
       my ($ignore_cache) = @_;
       my $lonhost = $perlvar{'lonHostID'};
       my $hostname = &hostname($lonhost);
       my $sts_on;
       if ($protocol{$lonhost} eq 'https') {
           my $cachetime = 12*3600;
           if (!$ignore_cache) {
               ($sts_on,my $cached)=&is_cached_new('stspolicy',$lonhost);
               if (defined($cached)) {
                   return $sts_on;
               }
           }
           my $url = $protocol{$lonhost}.'://'.$hostname.'/index.html';
           my $request=new HTTP::Request('HEAD',$url);
           my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,'','','',1);
           if ($response->is_success) {
               my $has_sts = $response->header('Strict-Transport-Security');
               if ($has_sts eq '') {
                   $sts_on = 0;
               } else {
                   if ($has_sts =~ /\Qmax-age=\E(\d+)/) {
                       my $maxage = $1;
                       if ($maxage) {
                           $sts_on = 1;
                       } else {
                           $sts_on = 0;
                       }
                   } else {
                       $sts_on = 0;
                   }
               }
               return &do_cache_new('stspolicy',$lonhost,$sts_on,$cachetime);
           }
       }
       return;
   }
   
   sub waf_allssl {
       my ($host_name) = @_;
       my $alias = &get_proxy_alias();
       if ($host_name eq '') {
           $host_name = $ENV{'SERVER_NAME'};
       }
       if (($host_name ne '') && ($alias eq $host_name)) {
           my $serverhomedom = &host_domain($perlvar{'lonHostID'});
           my %defdomdefaults = &get_domain_defaults($serverhomedom);
           if ($defdomdefaults{'waf_sslopt'}) {
               return $defdomdefaults{'waf_sslopt'};
           }
       }
       return;
   }
   
   sub get_requestor_ip {
       my ($r,$nolookup,$noproxy) = @_;
       my $from_ip;
       if (ref($r)) {
           if ($r->can('useragent_ip')) {
               if ($noproxy && $r->can('client_ip')) {
                   $from_ip = $r->client_ip();
               } else {
                   $from_ip = $r->useragent_ip();
               }
           } elsif ($r->connection->can('remote_ip')) {
               $from_ip = $r->connection->remote_ip();
           } else {
               $from_ip = $r->get_remote_host($nolookup);
           }
       } else {
           $from_ip = $ENV{'REMOTE_ADDR'};
       }
       return $from_ip if ($noproxy); 
       # Who controls proxy settings for server
       my $dom_in_use = $Apache::lonnet::perlvar{'lonDefDomain'};
       my $proxyinfo = &get_proxy_settings($dom_in_use);
       if ((ref($proxyinfo) eq 'HASH') && ($from_ip)) {
           if ($proxyinfo->{'vpnint'}) {
               if (&ip_match($from_ip,$proxyinfo->{'vpnint'})) {
                   return $from_ip;
               }
           }
           if ($proxyinfo->{'trusted'}) {
               if (&ip_match($from_ip,$proxyinfo->{'trusted'})) {
                   my $ipheader = $proxyinfo->{'ipheader'};
                   my ($ip,$xfor);
                   if (ref($r)) {
                       if ($ipheader) {
                           $ip = $r->headers_in->{$ipheader};
                       }
                       $xfor = $r->headers_in->{'X-Forwarded-For'};
                   } else {
                       if ($ipheader) {
                           $ip = $ENV{'HTTP_'.uc($ipheader)};
                       }
                       $xfor = $ENV{'HTTP_X_FORWARDED_FOR'};
                   }
                   if (($ip eq '') && ($xfor ne '')) {
                       foreach my $poss_ip (reverse(split(/\s*,\s*/,$xfor))) {
                           unless (&ip_match($poss_ip,$proxyinfo->{'trusted'})) {
                               $ip = $poss_ip;
                               last;
                           }
                       }
                   }
                   if ($ip ne '') {
                       return $ip;
                   }
               }
           }
       }
       return $from_ip;
   }
   
   sub get_proxy_settings {
       my ($dom_in_use) = @_;
       my %domdefaults = &Apache::lonnet::get_domain_defaults($dom_in_use);
       my $proxyinfo = {
                          ipheader => $domdefaults{'waf_ipheader'},
                          trusted  => $domdefaults{'waf_trusted'},
                          vpnint   => $domdefaults{'waf_vpnint'},
                          vpnext   => $domdefaults{'waf_vpnext'},
                          sslopt   => $domdefaults{'waf_sslopt'},
                       };
       return $proxyinfo;
   }
   
   sub ip_match {
       my ($ip,$pattern_str) = @_;
       $ip=Net::CIDR::cidrvalidate($ip);
       if ($ip) {
           return Net::CIDR::cidrlookup($ip,split(/\s*,\s*/,$pattern_str));
       }
       return;
   }
   
   sub get_proxy_alias {
       my ($lonid) = @_;
       if ($lonid eq '') {
           $lonid = $perlvar{'lonHostID'};
       }
       if (!defined(&hostname($lonid))) {
           return;
       }
       if ($lonid ne '') {
           my ($alias,$cached) = &is_cached_new('proxyalias',$lonid);
           if ($cached) {
               return $alias;
           }
           my $dom = &Apache::lonnet::host_domain($lonid);
           if ($dom ne '') {
               my $cachetime = 60*60*24;
               my %domconfig =
                   &Apache::lonnet::get_dom('configuration',['wafproxy'],$dom);
               my $alias;
               if (ref($domconfig{'wafproxy'}) eq 'HASH') {
                   if (ref($domconfig{'wafproxy'}{'alias'}) eq 'HASH') {
                       $alias = $domconfig{'wafproxy'}{'alias'}{$lonid};
                   }
               }
               return &do_cache_new('proxyalias',$lonid,$alias,$cachetime);
           }
       }
       return;
   }
   
   sub use_proxy_alias {
       my ($r,$lonid) = @_;
       my $alias = &get_proxy_alias($lonid);
       if ($alias) {
           my $dom = &host_domain($lonid);
           if ($dom ne '') {
               my $proxyinfo = &get_proxy_settings($dom );
               my ($vpnint,$remote_ip);
               if (ref($proxyinfo) eq 'HASH') {
                   $vpnint = $proxyinfo->{'vpnint'};
                   if ($vpnint) {
                       $remote_ip = &get_requestor_ip($r,1,1);
                   }
               }
               unless ($vpnint && &ip_match($remote_ip,$vpnint)) {
                   return $alias;
               }
           }
       }
       return;
   }
   
 # ------------------------------------------------------------- Declutters URLs  # ------------------------------------------------------------- Declutters URLs
   
 sub declutter {  sub declutter {
Line 13556  sub get_dns { Line 14680  sub get_dns {
     }      }
     while (%alldns) {      while (%alldns) {
  my ($dns) = sort { $b cmp $a } keys(%alldns);   my ($dns) = sort { $b cmp $a } keys(%alldns);
  my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");          my ($contents,@content);
         my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0);          if ($dns eq Sys::Hostname::FQDN::fqdn()) {
         delete($alldns{$dns});              my $command = (split('/',$url))[3];
  next if ($response->is_error());              my ($dir,$file) = &parse_getdns_url($command,$url);
               delete($alldns{$dns});
               next if (($dir eq '') || ($file eq ''));
               if (open(my $config,'<',"$dir/$file")) {
                   @content = <$config>);
                   close($config);
               }
               if ($url eq '/adm/dns/loncapaCRL') {
                   $contents = join('',@content);
               }
           } else {
       my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
               my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0);
               delete($alldns{$dns});
       next if ($response->is_error());
               if ($url eq '/adm/dns/loncapaCRL') {
                   $contents = $response->content;
               } else {
                   @content = split("\n",$response->content);
               }
           }
         if ($url eq '/adm/dns/loncapaCRL') {          if ($url eq '/adm/dns/loncapaCRL') {
             return &$func($response);              return &$func($contents);
         } else {          } else {
     my @content = split("\n",$response->content);  
     unless ($nocache) {      unless ($nocache) {
         &do_cache_new('dns',$url,\@content,30*24*60*60);          &do_cache_new('dns',$url,\@content,30*24*60*60);
     }      }
Line 13651  sub fetch_crl_pemfile { Line 14794  sub fetch_crl_pemfile {
 }  }
   
 sub save_crl_pem {  sub save_crl_pem {
     my ($response) = @_;      my ($content) = @_;
     my ($msg,$hadchanges);      my ($msg,$hadchanges);
     if (ref($response)) {      if ($content ne '') {
         my $now = time;          my $now = time;
         my $lonca = $perlvar{'lonCertificateDirectory'}.'/'.$perlvar{'lonnetCertificateAuthority'};          my $lonca = $perlvar{'lonCertificateDirectory'}.'/'.$perlvar{'lonnetCertificateAuthority'};
         my $tmpcrl = $tmpdir.'/'.$perlvar{'lonnetCertRevocationList'}.'_'.$now.'.'.$$.'.tmp';          my $tmpcrl = $tmpdir.'/'.$perlvar{'lonnetCertRevocationList'}.'_'.$now.'.'.$$.'.tmp';
         if (open(my $fh,'>',"$tmpcrl")) {          if (open(my $fh,'>',"$tmpcrl")) {
             print $fh $response->content;              print $fh $content;
             close($fh);              close($fh);
             if (-e $lonca) {              if (-e $lonca) {
                 if (open(PIPE,"openssl crl -in $tmpcrl -inform pem -CAfile $lonca -noout 2>&1 |")) {                  if (open(PIPE,"openssl crl -in $tmpcrl -inform pem -CAfile $lonca -noout 2>&1 |")) {
Line 13719  sub save_crl_pem { Line 14862  sub save_crl_pem {
     return ($msg,$hadchanges);      return ($msg,$hadchanges);
 }  }
   
   sub parse_getdns_url {
       my ($command,$url) = @_;
       my $dir = $perlvar{'lonTabDir'};
       my $file;
       if ($command eq 'hosts') {
           $file = 'dns_hosts.tab';
       } elsif ($command eq 'domain') {
           $file = 'dns_domain.tab';
       } elsif ($command eq 'checksums') {
           my $version = (split('/',$url))[4];
           $file = "dns_checksums/$version.tab",
       } elsif ($command eq 'loncapaCRL') {
           $dir = $perlvar{'lonCertificateDirectory'};
           $file = $perlvar{'lonnetCertRevocationList'};
       }
       return ($dir,$file);
   }
   
 # ------------------------------------------------------------ Read domain file  # ------------------------------------------------------------ Read domain file
 {  {
     my $loaded;      my $loaded;
Line 14285  BEGIN { Line 15446  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 14624  prevents recursive calls to &allowed. Line 15795  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 14954  Returns: Line 16126  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 15651  userspace, probably shouldn't be called Line 16905  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.1385  
changed lines
  Added in v.1.1456

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