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

Diff for /loncom/interface/loncommon.pm between versions 1.1075.2.127.6.1 and 1.1075.2.151

version 1.1075.2.127.6.1, 2019/03/02 16:25:45 version 1.1075.2.151, 2021/01/29 02:42:15
Line 71  use Apache::lonuserutils(); Line 71  use Apache::lonuserutils();
 use Apache::lonuserstate();  use Apache::lonuserstate();
 use Apache::courseclassifier();  use Apache::courseclassifier();
 use LONCAPA qw(:DEFAULT :match);  use LONCAPA qw(:DEFAULT :match);
   use HTTP::Request;
 use DateTime::TimeZone;  use DateTime::TimeZone;
 use DateTime::Locale;  use DateTime::Locale;
 use Encode();  use Encode();
Line 80  use JSON::DWIW; Line 81  use JSON::DWIW;
 use LWP::UserAgent;  use LWP::UserAgent;
 use Crypt::DES;  use Crypt::DES;
 use DynaLoader; # for Crypt::DES version  use DynaLoader; # for Crypt::DES version
   use File::Copy();
   use File::Path();
   
 # ---------------------------------------------- Designs  # ---------------------------------------------- Designs
 use vars qw(%defaultdesign);  use vars qw(%defaultdesign);
Line 194  BEGIN { Line 197  BEGIN {
     {      {
         my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}.          my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}.
                                    '/language.tab';                                     '/language.tab';
         if ( open(my $fh,"<$langtabfile") ) {          if ( open(my $fh,'<',$langtabfile) ) {
             while (my $line = <$fh>) {              while (my $line = <$fh>) {
                 next if ($line=~/^\#/);                  next if ($line=~/^\#/);
                 chomp($line);                  chomp($line);
Line 215  BEGIN { Line 218  BEGIN {
     {      {
         my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.          my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
                                   '/copyright.tab';                                    '/copyright.tab';
         if ( open (my $fh,"<$copyrightfile") ) {          if ( open (my $fh,'<',$copyrightfile) ) {
             while (my $line = <$fh>) {              while (my $line = <$fh>) {
                 next if ($line=~/^\#/);                  next if ($line=~/^\#/);
                 chomp($line);                  chomp($line);
Line 229  BEGIN { Line 232  BEGIN {
     {      {
         my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.          my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
                                   '/source_copyright.tab';                                    '/source_copyright.tab';
         if ( open (my $fh,"<$sourcecopyrightfile") ) {          if ( open (my $fh,'<',$sourcecopyrightfile) ) {
             while (my $line = <$fh>) {              while (my $line = <$fh>) {
                 next if ($line =~ /^\#/);                  next if ($line =~ /^\#/);
                 chomp($line);                  chomp($line);
Line 243  BEGIN { Line 246  BEGIN {
 # -------------------------------------------------------------- default domain designs  # -------------------------------------------------------------- default domain designs
     my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';      my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
     my $designfile = $designdir.'/default.tab';      my $designfile = $designdir.'/default.tab';
     if ( open (my $fh,"<$designfile") ) {      if ( open (my $fh,'<',$designfile) ) {
         while (my $line = <$fh>) {          while (my $line = <$fh>) {
             next if ($line =~ /^\#/);              next if ($line =~ /^\#/);
             chomp($line);              chomp($line);
Line 257  BEGIN { Line 260  BEGIN {
     {      {
         my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}.          my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}.
                                   '/filecategories.tab';                                    '/filecategories.tab';
         if ( open (my $fh,"<$categoryfile") ) {          if ( open (my $fh,'<',$categoryfile) ) {
     while (my $line = <$fh>) {      while (my $line = <$fh>) {
  next if ($line =~ /^\#/);   next if ($line =~ /^\#/);
  chomp($line);   chomp($line);
Line 272  BEGIN { Line 275  BEGIN {
     {      {
         my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}.          my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}.
                '/filetypes.tab';                 '/filetypes.tab';
         if ( open (my $fh,"<$typesfile") ) {          if ( open (my $fh,'<',$typesfile) ) {
             while (my $line = <$fh>) {              while (my $line = <$fh>) {
  next if ($line =~ /^\#/);   next if ($line =~ /^\#/);
  chomp($line);   chomp($line);
Line 425  sub studentbrowser_javascript { Line 428  sub studentbrowser_javascript {
 <script type="text/javascript" language="Javascript">  <script type="text/javascript" language="Javascript">
 // <![CDATA[  // <![CDATA[
     var stdeditbrowser;      var stdeditbrowser;
     function openstdbrowser(formname,uname,udom,clicker,roleflag,ignorefilter,courseadvonly) {      function openstdbrowser(formname,uname,udom,clicker,roleflag,ignorefilter,courseadv) {
         var url = '/adm/pickstudent?';          var url = '/adm/pickstudent?';
         var filter;          var filter;
  if (!ignorefilter) {   if (!ignorefilter) {
Line 440  sub studentbrowser_javascript { Line 443  sub studentbrowser_javascript {
                                     '&udomelement='+udom+                                      '&udomelement='+udom+
                                     '&clicker='+clicker;                                      '&clicker='+clicker;
  if (roleflag) { url+="&roles=1"; }   if (roleflag) { url+="&roles=1"; }
         if (courseadvonly) { url+="&courseadvonly=1"; }          if (courseadv == 'condition') {
               if (document.getElementById('courseadv')) {
                   courseadv = document.getElementById('courseadv').value;
               }
           }
           if ((courseadv == 'only') || (courseadv == 'none')) { url+="&courseadv="+courseadv; }
         var title = 'Student_Browser';          var title = 'Student_Browser';
         var options = 'scrollbars=1,resizable=1,menubar=0';          var options = 'scrollbars=1,resizable=1,menubar=0';
         options += ',width=700,height=600';          options += ',width=700,height=600';
Line 472  ENDRESBRW Line 480  ENDRESBRW
 }  }
   
 sub selectstudent_link {  sub selectstudent_link {
    my ($form,$unameele,$udomele,$courseadvonly,$clickerid)=@_;     my ($form,$unameele,$udomele,$courseadv,$clickerid)=@_;
    my $callargs = "'".&Apache::lonhtmlcommon::entity_encode($form)."','".     my $callargs = "'".&Apache::lonhtmlcommon::entity_encode($form)."','".
                       &Apache::lonhtmlcommon::entity_encode($unameele)."','".                        &Apache::lonhtmlcommon::entity_encode($unameele)."','".
                       &Apache::lonhtmlcommon::entity_encode($udomele)."'";                        &Apache::lonhtmlcommon::entity_encode($udomele)."'";
Line 483  sub selectstudent_link { Line 491  sub selectstudent_link {
    return '';     return '';
        }         }
        $callargs.=",'".&Apache::lonhtmlcommon::entity_encode($clickerid)."'";         $callargs.=",'".&Apache::lonhtmlcommon::entity_encode($clickerid)."'";
        if ($courseadvonly)  {         if ($courseadv eq 'only') {
            $callargs .= ",'',1,1";             $callargs .= ",'',1,'$courseadv'";
          } elsif ($courseadv eq 'none') {
              $callargs .= ",'','','$courseadv'";
          } elsif ($courseadv eq 'condition') {
              $callargs .= ",'','','$courseadv'";
        }         }
        return '<span class="LC_nobreak">'.         return '<span class="LC_nobreak">'.
               '<a href="javascript:openstdbrowser('.$callargs.');">'.                '<a href="javascript:openstdbrowser('.$callargs.');">'.
Line 1401  sub help_menu_js { Line 1413  sub help_menu_js {
         &Apache::loncommon::start_page('Help Menu', undef,          &Apache::loncommon::start_page('Help Menu', undef,
        {'frameset'    => 1,         {'frameset'    => 1,
  'js_ready'    => 1,   'js_ready'    => 1,
                                         'use_absolute' => $httphost,                                           'use_absolute' => $httphost,
  'add_entries' => {   'add_entries' => {
     'border' => '0',      'border' => '0',
     'rows'   => "110,*",},});      'rows'   => "110,*",},});
Line 2260  sub select_form { Line 2272  sub select_form {
     if ($onchange) {      if ($onchange) {
         $onchange = ' onchange="'.$onchange.'"';          $onchange = ' onchange="'.$onchange.'"';
     }      }
     my $selectform = "<select name=\"$name\" size=\"1\"$onchange>\n";      my $disabled;
       if ($readonly) {
           $disabled = ' disabled="disabled"';
       }
       my $selectform = "<select name=\"$name\" size=\"1\"$onchange$disabled>\n";
     my @keys;      my @keys;
     if (exists($hashref->{'select_form_order'})) {      if (exists($hashref->{'select_form_order'})) {
  @keys=@{$hashref->{'select_form_order'}};   @keys=@{$hashref->{'select_form_order'}};
Line 3164  sub get_assignable_auth { Line 3180  sub get_assignable_auth {
     return ($authnum,%can_assign);      return ($authnum,%can_assign);
 }  }
   
   sub check_passwd_rules {
       my ($domain,$plainpass) = @_;
       my %passwdconf = &Apache::lonnet::get_passwdconf($domain);
       my ($min,$max,@chars,@brokerule,$warning);
       $min = $Apache::lonnet::passwdmin;
       if (ref($passwdconf{'chars'}) eq 'ARRAY') {
           if ($passwdconf{'min'} =~ /^\d+$/) {
               if ($passwdconf{'min'} > $min) {
                   $min = $passwdconf{'min'};
               }
           }
           if ($passwdconf{'max'} =~ /^\d+$/) {
               $max = $passwdconf{'max'};
           }
           @chars = @{$passwdconf{'chars'}};
       }
       if (($min) && (length($plainpass) < $min)) {
           push(@brokerule,'min');
       }
       if (($max) && (length($plainpass) > $max)) {
           push(@brokerule,'max');
       }
       if (@chars) {
           my %rules;
           map { $rules{$_} = 1; } @chars;
           if ($rules{'uc'}) {
               unless ($plainpass =~ /[A-Z]/) {
                   push(@brokerule,'uc');
               }
           }
           if ($rules{'lc'}) {
               unless ($plainpass =~ /[a-z]/) {
                   push(@brokerule,'lc');
               }
           }
           if ($rules{'num'}) {
               unless ($plainpass =~ /\d/) {
                   push(@brokerule,'num');
               }
           }
           if ($rules{'spec'}) {
               unless ($plainpass =~ /[!"#$%&'()*+,\-.\/:;<=>?@[\\\]^_`{|}~]/) {
                   push(@brokerule,'spec');
               }
           }
       }
       if (@brokerule) {
           my %rulenames = &Apache::lonlocal::texthash(
               uc   => 'At least one upper case letter',
               lc   => 'At least one lower case letter',
               num  => 'At least one number',
               spec => 'At least one non-alphanumeric',
           );
           $rulenames{'uc'} .= ': ABCDEFGHIJKLMNOPQRSTUVWXYZ';
           $rulenames{'lc'} .= ': abcdefghijklmnopqrstuvwxyz';
           $rulenames{'num'} .= ': 0123456789';
           $rulenames{'spec'} .= ': !&quot;\#$%&amp;\'()*+,-./:;&lt;=&gt;?@[\]^_\`{|}~';
           $rulenames{'min'} = &mt('Minimum password length: [_1]',$min);
           $rulenames{'max'} = &mt('Maximum password length: [_1]',$max);
           $warning = &mt('Password did not satisfy the following:').'<ul>';
           foreach my $rule ('min','max','uc','lc','num','spec') {
               if (grep(/^$rule$/,@brokerule)) {
                   $warning .= '<li>'.$rulenames{$rule}.'</li>';
               }
           }
           $warning .= '</ul>';
       }
       if (wantarray) {
           return @brokerule;
       }
       return $warning;
   }
   
 ###############################################################  ###############################################################
 ##    Get Kerberos Defaults for Domain                 ##  ##    Get Kerberos Defaults for Domain                 ##
 ###############################################################  ###############################################################
Line 4334  sub get_student_view_with_retries { Line 4423  sub get_student_view_with_retries {
     }      }
 }  }
   
   sub css_links {
       my ($currsymb,$level) = @_;
       my ($links,@symbs,%cssrefs,%httpref);
       if ($level eq 'map') {
           my $navmap = Apache::lonnavmaps::navmap->new();
           if (ref($navmap)) {
               my ($map,undef,$url)=&Apache::lonnet::decode_symb($currsymb);
               my @resources = $navmap->retrieveResources($map,sub { $_[0]->is_problem() },0,0);
               foreach my $res (@resources) {
                   if (ref($res) && $res->symb()) {
                       push(@symbs,$res->symb());
                   }
               }
           }
       } else {
           @symbs = ($currsymb);
       }
       foreach my $symb (@symbs) {
           my $css_href = &Apache::lonnet::EXT('resource.0.cssfile',$symb);
           if ($css_href =~ /\S/) {
               unless ($css_href =~ m{https?://}) {
                   my $url = (&Apache::lonnet::decode_symb($symb))[-1];
                   my $proburl =  &Apache::lonnet::clutter($url);
                   my ($probdir) = ($proburl =~ m{(.+)/[^/]+$});
                   unless ($css_href =~ m{^/}) {
                       $css_href = &Apache::lonnet::hreflocation($probdir,$css_href);
                   }
                   if ($css_href =~ m{^/(res|uploaded)/}) {
                       unless (($httpref{'httpref.'.$css_href}) ||
                               (&Apache::lonnet::is_on_map($css_href))) {
                           my $thisurl = $proburl;
                           if ($env{'httpref.'.$proburl}) {
                               $thisurl = $env{'httpref.'.$proburl};
                           }
                           $httpref{'httpref.'.$css_href} = $thisurl;
                       }
                   }
               }
               $cssrefs{$css_href} = 1;
           }
       }
       if (keys(%httpref)) {
           &Apache::lonnet::appenv(\%httpref);
       }
       if (keys(%cssrefs)) {
           foreach my $css_href (keys(%cssrefs)) {
               next unless ($css_href =~ m{^(/res/|/uploaded/|https?://)});
               $links .= '<link rel="stylesheet" type="text/css" href="'.$css_href.'" />'."\n";
           }
       }
       return $links;
   }
   
 =pod  =pod
   
 =item * &get_student_answers()   =item * &get_student_answers() 
Line 4589  sub findallcourses { Line 4731  sub findallcourses {
 ###############################################  ###############################################
   
 sub blockcheck {  sub blockcheck {
     my ($setters,$activity,$uname,$udom,$url,$is_course) = @_;      my ($setters,$activity,$uname,$udom,$url,$is_course,$symb,$caller) = @_;
   
     if (defined($udom) && defined($uname)) {      if (defined($udom) && defined($uname)) {
         # If uname and udom are for a course, check for blocks in the course.          # If uname and udom are for a course, check for blocks in the course.
         if (($is_course) || (&Apache::lonnet::is_course($udom,$uname))) {          if (($is_course) || (&Apache::lonnet::is_course($udom,$uname))) {
             my ($startblock,$endblock,$triggerblock) =              my ($startblock,$endblock,$triggerblock) =
                 &get_blocks($setters,$activity,$udom,$uname,$url);                  &get_blocks($setters,$activity,$udom,$uname,$url,$symb,$caller);
             return ($startblock,$endblock,$triggerblock);              return ($startblock,$endblock,$triggerblock);
         }          }
     } else {      } else {
Line 4718  sub blockcheck { Line 4860  sub blockcheck {
                  ($env{'request.role'} !~ m{^st\./\Q$cdom\E/\Q$cnum\E}));                   ($env{'request.role'} !~ m{^st\./\Q$cdom\E/\Q$cnum\E}));
         next if ($no_userblock);          next if ($no_userblock);
   
         # Retrieve blocking times and identity of locker for course          # Retrieve blocking times and identity of blocker for course
         # of specified user, unless user has 'evb' privilege.          # of specified user, unless user has 'evb' privilege.
                   
         my ($start,$end,$trigger) =           my ($start,$end,$trigger) = 
             &get_blocks($setters,$activity,$cdom,$cnum,$url);              &get_blocks($setters,$activity,$cdom,$cnum,$url,$symb,$caller);
         if (($start != 0) &&           if (($start != 0) && 
             (($startblock == 0) || ($startblock > $start))) {              (($startblock == 0) || ($startblock > $start))) {
             $startblock = $start;              $startblock = $start;
Line 4742  sub blockcheck { Line 4884  sub blockcheck {
 }  }
   
 sub get_blocks {  sub get_blocks {
     my ($setters,$activity,$cdom,$cnum,$url) = @_;      my ($setters,$activity,$cdom,$cnum,$url,$symb,$caller) = @_;
     my $startblock = 0;      my $startblock = 0;
     my $endblock = 0;      my $endblock = 0;
     my $triggerblock = '';      my $triggerblock = '';
Line 4755  sub get_blocks { Line 4897  sub get_blocks {
     my $now = time;      my $now = time;
     my %commblocks = &Apache::lonnet::get_comm_blocks($cdom,$cnum);      my %commblocks = &Apache::lonnet::get_comm_blocks($cdom,$cnum);
     if ($activity eq 'docs') {      if ($activity eq 'docs') {
         @blockers = &Apache::lonnet::has_comm_blocking('bre',undef,$url,\%commblocks);          my ($blocked,$nosymbcache,$noenccheck);
           if (($caller eq 'blockedaccess') || ($caller eq 'blockingstatus')) {
               $blocked = 1;
               $nosymbcache = 1;
               $noenccheck = 1;
           }
           @blockers = &Apache::lonnet::has_comm_blocking('bre',$symb,$url,$nosymbcache,$noenccheck,$blocked,\%commblocks);
         foreach my $block (@blockers) {          foreach my $block (@blockers) {
             if ($block =~ /^firstaccess____(.+)$/) {              if ($block =~ /^firstaccess____(.+)$/) {
                 my $item = $1;                  my $item = $1;
Line 4877  sub parse_block_record { Line 5025  sub parse_block_record {
 }  }
   
 sub blocking_status {  sub blocking_status {
     my ($activity,$uname,$udom,$url,$is_course) = @_;      my ($activity,$uname,$udom,$url,$is_course,$symb,$caller) = @_;
     my %setters;      my %setters;
   
 # check for active blocking  # check for active blocking
     my ($startblock,$endblock,$triggerblock) =       my ($startblock,$endblock,$triggerblock) = 
         &blockcheck(\%setters,$activity,$uname,$udom,$url,$is_course);          &blockcheck(\%setters,$activity,$uname,$udom,$url,$is_course,$symb,$caller);
     my $blocked = 0;      my $blocked = 0;
     if ($startblock && $endblock) {      if ($startblock && $endblock) {
         $blocked = 1;          $blocked = 1;
Line 4898  sub blocking_status { Line 5046  sub blocking_status {
         $querystring .= "&amp;udom=$udom"      if ($udom =~ /^$match_domain$/);          $querystring .= "&amp;udom=$udom"      if ($udom =~ /^$match_domain$/);
         $querystring .= "&amp;uname=$uname"    if ($uname =~ /^$match_username$/);          $querystring .= "&amp;uname=$uname"    if ($uname =~ /^$match_username$/);
     } elsif ($activity eq 'docs') {      } elsif ($activity eq 'docs') {
         $querystring .= '&amp;url='.&HTML::Entities::encode($url,'&"');          my $showurl = &Apache::lonenc::check_encrypt($url);
           $querystring .= '&amp;url='.&HTML::Entities::encode($showurl,'\'&"<>');
           if ($symb) {
               my $showsymb = &Apache::lonenc::check_encrypt($symb);
               $querystring .= '&amp;symb='.&HTML::Entities::encode($showsymb,'\'&"<>');
           }
     }      }
   
     my $output .= <<'END_MYBLOCK';      my $output .= <<'END_MYBLOCK';
Line 4946  sub check_ip_acc { Line 5099  sub check_ip_acc {
     if (!defined($acc) || $acc =~ /^\s*$/ || $acc =~/^\s*no\s*$/i) {      if (!defined($acc) || $acc =~ /^\s*$/ || $acc =~/^\s*no\s*$/i) {
         return 1;          return 1;
     }      }
     my $allowed;      my $allowed=0;
     my $ip=$ENV{'REMOTE_ADDR'} || $clientip || $env{'request.host'};      my $ip;
       if (($ENV{'REMOTE_ADDR'} eq '127.0.0.1') ||
           ($ENV{'REMOTE_ADDR'} eq &Apache::lonnet::get_host_ip($Apache::lonnet::perlvar{'lonHostID'}))) {
           $ip = $env{'request.host'} || $ENV{'REMOTE_ADDR'} || $clientip;
       } else {
           my $remote_ip = &Apache::lonnet::get_requestor_ip();
           $ip = $remote_ip || $env{'request.host'} || $clientip;
       }
   
     my $name;      my $name;
     my %access = (      foreach my $pattern (split(',',$acc)) {
                      allowfrom => 1,          $pattern =~ s/^\s*//;
                      denyfrom  => 0,          $pattern =~ s/\s*$//;
                  );  
     my @allows;  
     my @denies;  
     foreach my $item (split(',',$acc)) {  
         $item =~ s/^\s*//;  
         $item =~ s/\s*$//;  
         if ($item =~ /^\!(.+)$/) {  
             push(@denies,$1);  
         } else {  
             push(@allows,$item);  
         }  
     }  
     my $numdenies = scalar(@denies);  
     my $numallows = scalar(@allows);  
     my $count = 0;  
     foreach my $pattern (@denies,@allows) {  
         $count ++;  
         my $acctype = 'allowfrom';  
         if ($count <= $numdenies) {  
             $acctype = 'denyfrom';  
         }  
         if ($pattern =~ /\*$/) {          if ($pattern =~ /\*$/) {
             #35.8.*              #35.8.*
             $pattern=~s/\*//;              $pattern=~s/\*//;
             if ($ip =~ /^\Q$pattern\E/) { $allowed=$access{$acctype}; }              if ($ip =~ /^\Q$pattern\E/) { $allowed=1; }
         } elsif ($pattern =~ /(\d+\.\d+\.\d+)\.\[(\d+)-(\d+)\]$/) {          } elsif ($pattern =~ /(\d+\.\d+\.\d+)\.\[(\d+)-(\d+)\]$/) {
             #35.8.3.[34-56]              #35.8.3.[34-56]
             my $low=$2;              my $low=$2;
Line 4985  sub check_ip_acc { Line 5124  sub check_ip_acc {
             $pattern=$1;              $pattern=$1;
             if ($ip =~ /^\Q$pattern\E/) {              if ($ip =~ /^\Q$pattern\E/) {
                 my $last=(split(/\./,$ip))[3];                  my $last=(split(/\./,$ip))[3];
                 if ($last <=$high && $last >=$low) { $allowed=$access{$acctype}; }                  if ($last <=$high && $last >=$low) { $allowed=1; }
             }              }
         } elsif ($pattern =~ /^\*/) {          } elsif ($pattern =~ /^\*/) {
             #*.msu.edu              #*.msu.edu
Line 4995  sub check_ip_acc { Line 5134  sub check_ip_acc {
                 my $netaddr=inet_aton($ip);                  my $netaddr=inet_aton($ip);
                 ($name)=gethostbyaddr($netaddr,AF_INET);                  ($name)=gethostbyaddr($netaddr,AF_INET);
             }              }
             if ($name =~ /\Q$pattern\E$/i) { $allowed=$access{$acctype}; }              if ($name =~ /\Q$pattern\E$/i) { $allowed=1; }
         } elsif ($pattern =~ /\d+\.\d+\.\d+\.\d+/) {          } elsif ($pattern =~ /\d+\.\d+\.\d+\.\d+/) {
             #127.0.0.1              #127.0.0.1
             if ($ip =~ /^\Q$pattern\E/) { $allowed=$access{$acctype}; }              if ($ip =~ /^\Q$pattern\E/) { $allowed=1; }
         } else {          } else {
             #some.name.com              #some.name.com
             if (!defined($name)) {              if (!defined($name)) {
Line 5006  sub check_ip_acc { Line 5145  sub check_ip_acc {
                 my $netaddr=inet_aton($ip);                  my $netaddr=inet_aton($ip);
                 ($name)=gethostbyaddr($netaddr,AF_INET);                  ($name)=gethostbyaddr($netaddr,AF_INET);
             }              }
             if ($name =~ /\Q$pattern\E$/i) { $allowed=$access{$acctype}; }              if ($name =~ /\Q$pattern\E$/i) { $allowed=1; }
         }  
         if ($allowed =~ /^(0|1)$/) { last; }  
     }  
     if ($allowed eq '') {  
         if ($numdenies && !$numallows) {  
             $allowed = 1;  
         } else {  
             $allowed = 0;  
         }          }
           if ($allowed) { last; }
     }      }
     return $allowed;      return $allowed;
 }  }
Line 5160  sub get_legacy_domconf { Line 5292  sub get_legacy_domconf {
     my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';      my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
     my $designfile =  $designdir.'/'.$udom.'.tab';      my $designfile =  $designdir.'/'.$udom.'.tab';
     if (-e $designfile) {      if (-e $designfile) {
         if ( open (my $fh,"<$designfile") ) {          if ( open (my $fh,'<',$designfile) ) {
             while (my $line = <$fh>) {              while (my $line = <$fh>) {
                 next if ($line =~ /^\#/);                  next if ($line =~ /^\#/);
                 chomp($line);                  chomp($line);
Line 5416  Inputs: Line 5548  Inputs:
   
 =item * $args, optional argument valid values are  =item * $args, optional argument valid values are
             no_auto_mt_title -> prevents &mt()ing the title arg              no_auto_mt_title -> prevents &mt()ing the title arg
               use_absolute     -> for external resource or syllabus, this will
                                   contain https://<hostname> if server uses
                                   https (as per hosts.tab), but request is for http
               hostname         -> hostname, from $r->hostname().
   
 =item * $advtoolsref, optional argument, ref to an array containing  =item * $advtoolsref, optional argument, ref to an array containing
             inlineremote items to be added in "Functions" menu below              inlineremote items to be added in "Functions" menu below
Line 5441  sub bodytag { Line 5577  sub bodytag {
     }      }
     if (!$args->{'no_auto_mt_title'}) { $title = &mt($title); }      if (!$args->{'no_auto_mt_title'}) { $title = &mt($title); }
     my $httphost = $args->{'use_absolute'};      my $httphost = $args->{'use_absolute'};
       my $hostname = $args->{'hostname'};
   
     $function = &get_users_function() if (!$function);      $function = &get_users_function() if (!$function);
     my $img =    &designparm($function.'.img',$domain);      my $img =    &designparm($function.'.img',$domain);
Line 5529  sub bodytag { Line 5666  sub bodytag {
         &Apache::lonmenu::prepare_functions($env{'request.noversionuri'},          &Apache::lonmenu::prepare_functions($env{'request.noversionuri'},
                                             $forcereg,$args->{'group'},                                              $forcereg,$args->{'group'},
                                             $args->{'bread_crumbs'},                                              $args->{'bread_crumbs'},
                                             $advtoolsref,'',\$forbodytag);                                              $advtoolsref,'','',\$forbodytag);
         unless (ref($args->{'bread_crumbs'}) eq 'ARRAY') {          unless (ref($args->{'bread_crumbs'}) eq 'ARRAY') {
             $funclist = $forbodytag;              $funclist = $forbodytag;
         }          }
Line 5575  sub bodytag { Line 5712  sub bodytag {
             $bodytag .= Apache::lonhtmlcommon::scripttag('', 'end');              $bodytag .= Apache::lonhtmlcommon::scripttag('', 'end');
             if ($env{'request.state'} eq 'construct') {              if ($env{'request.state'} eq 'construct') {
                 $bodytag .= &Apache::lonmenu::innerregister($forcereg,                  $bodytag .= &Apache::lonmenu::innerregister($forcereg,
                                 $args->{'bread_crumbs'});                                  $args->{'bread_crumbs'},'','',$hostname);
             } elsif ($forcereg) {              } elsif ($forcereg) {
                 $bodytag .= &Apache::lonmenu::innerregister($forcereg,undef,                  $bodytag .= &Apache::lonmenu::innerregister($forcereg,undef,
                                                             $args->{'group'},                                                              $args->{'group'},
                                                             $args->{'hide_buttons'});                                                              $args->{'hide_buttons',
                                                               $hostname});
             } else {              } else {
                 my $forbodytag;                  my $forbodytag;
                 &Apache::lonmenu::prepare_functions($env{'request.noversionuri'},                  &Apache::lonmenu::prepare_functions($env{'request.noversionuri'},
                                                     $forcereg,$args->{'group'},                                                      $forcereg,$args->{'group'},
                                                     $args->{'bread_crumbs'},                                                      $args->{'bread_crumbs'},
                                                     $advtoolsref,'',\$forbodytag);                                                      $advtoolsref,'',$hostname,
                                                       \$forbodytag);
                 unless (ref($args->{'bread_crumbs'}) eq 'ARRAY') {                  unless (ref($args->{'bread_crumbs'}) eq 'ARRAY') {
                     $bodytag .= $forbodytag;                      $bodytag .= $forbodytag;
                 }                  }
Line 6099  td.LC_menubuttons_text { Line 6238  td.LC_menubuttons_text {
   background: $tabbg;    background: $tabbg;
 }  }
   
   td.LC_zero_height {
     line-height: 0;
     cellpadding: 0;
   }
   
 table.LC_data_table {  table.LC_data_table {
   border: 1px solid #000000;    border: 1px solid #000000;
   border-collapse: separate;    border-collapse: separate;
Line 6689  table.LC_prior_tries td { Line 6833  table.LC_prior_tries td {
   padding: 6px;    padding: 6px;
 }  }
   
 .LC_answer_unknown {  .LC_answer_unknown,
   .LC_answer_warning {
   background: orange;    background: orange;
   color: black;    color: black;
   padding: 6px;    padding: 6px;
Line 6771  table.LC_data_table tr > td.LC_docs_entr Line 6916  table.LC_data_table tr > td.LC_docs_entr
   color: #990000;    color: #990000;
 }  }
   
   .LC_domprefs_email,
 .LC_docs_reinit_warn,  .LC_docs_reinit_warn,
 .LC_docs_ext_edit {  .LC_docs_ext_edit {
   font-size: x-small;    font-size: x-small;
Line 7679  ul.LC_funclist li { Line 7825  ul.LC_funclist li {
  cursor:pointer;   cursor:pointer;
 }  }
   
   pre.LC_wordwrap {
     white-space: pre-wrap;
     white-space: -moz-pre-wrap;
     white-space: -pre-wrap;
     white-space: -o-pre-wrap;
     word-wrap: break-word;
   }
   
 /*  /*
   styles used by TTH when "Default set of options to pass to tth/m    styles used by TTH when "Default set of options to pass to tth/m
   when converting TeX" in course settings has been set    when converting TeX" in course settings has been set
Line 7838  ADDMETA Line 7992  ADDMETA
                 my $dom_in_use = $Apache::lonnet::perlvar{'lonDefDomain'};                  my $dom_in_use = $Apache::lonnet::perlvar{'lonDefDomain'};
                 unless (&Apache::lonnet::allowed('mau',$dom_in_use)) {                  unless (&Apache::lonnet::allowed('mau',$dom_in_use)) {
                     my %domdefs = &Apache::lonnet::get_domain_defaults($dom_in_use);                      my %domdefs = &Apache::lonnet::get_domain_defaults($dom_in_use);
                       my $lonhost = $Apache::lonnet::perlvar{'lonHostID'};
                       my ($offload,$offloadoth);
                     if (ref($domdefs{'offloadnow'}) eq 'HASH') {                      if (ref($domdefs{'offloadnow'}) eq 'HASH') {
                         my $lonhost = $Apache::lonnet::perlvar{'lonHostID'};  
                         if ($domdefs{'offloadnow'}{$lonhost}) {                          if ($domdefs{'offloadnow'}{$lonhost}) {
                             my $newserver = &Apache::lonnet::spareserver(30000,undef,1,$dom_in_use);                              $offload = 1;
                             if (($newserver) && ($newserver ne $lonhost)) {                              if (($env{'user.domain'} ne '') && ($env{'user.domain'} ne $dom_in_use) &&
                                 my $numsec = 5;                                  (!(($env{'user.name'} eq 'public') && ($env{'user.domain'} eq 'public')))) {
                                 my $timeout = $numsec * 1000;                                  unless (&Apache::lonnet::shared_institution($env{'user.domain'})) {
                                 my ($newurl,$locknum,%locks,$msg);                                      $offloadoth = 1;
                                 if ($env{'request.role.adv'}) {                                      $dom_in_use = $env{'user.domain'};
                                     ($locknum,%locks) = &Apache::lonnet::get_locks();  
                                 }                                  }
                                 my $disable_submit = 0;                              }
                                 if ($requrl =~ /$LONCAPA::assess_re/) {                          }
                                     $disable_submit = 1;                      }
                       unless ($offload) {
                           if (ref($domdefs{'offloadoth'}) eq 'HASH') {
                               if ($domdefs{'offloadoth'}{$lonhost}) {
                                   if (($env{'user.domain'} ne '') && ($env{'user.domain'} ne $dom_in_use) &&
                                       (!(($env{'user.name'} eq 'public') && ($env{'user.domain'} eq 'public')))) {
                                       unless (&Apache::lonnet::shared_institution($env{'user.domain'})) {
                                           $offload = 1;
                                           $offloadoth = 1;
                                           $dom_in_use = $env{'user.domain'};
                                       }
                                 }                                  }
                                 if ($locknum) {                              }
                                     my @lockinfo = sort(values(%locks));                          }
                                     $msg = &mt('Once the following tasks are complete: ')."\\n".                      }
                                            join(", ",sort(values(%locks)))."\\n".                      if ($offload) {
                                            &mt('your session will be transferred to a different server, after you click "Roles".');                          my $newserver = &Apache::lonnet::spareserver(30000,undef,1,$dom_in_use);
                           if (($newserver eq '') && ($offloadoth)) {
                               my @domains = &Apache::lonnet::current_machine_domains();
                               if (($dom_in_use ne '') && (!grep(/^\Q$dom_in_use\E$/,@domains))) { 
                                   ($newserver) = &Apache::lonnet::choose_server($dom_in_use);
                               }
                           }
                           if (($newserver) && ($newserver ne $lonhost)) {
                               my $numsec = 5;
                               my $timeout = $numsec * 1000;
                               my ($newurl,$locknum,%locks,$msg);
                               if ($env{'request.role.adv'}) {
                                   ($locknum,%locks) = &Apache::lonnet::get_locks();
                               }
                               my $disable_submit = 0;
                               if ($requrl =~ /$LONCAPA::assess_re/) {
                                   $disable_submit = 1;
                               }
                               if ($locknum) {
                                   my @lockinfo = sort(values(%locks));
                                   $msg = &mt('Once the following tasks are complete: ')."\n".
                                          join(", ",sort(values(%locks)))."\n";
                                   if (&show_course()) {
                                       $msg .= &mt('your session will be transferred to a different server, after you click "Courses".');
                                 } else {                                  } else {
                                     if (($requrl =~ m{^/res/}) && ($env{'form.submitted'} =~ /^part_/)) {                                      $msg .= &mt('your session will be transferred to a different server, after you click "Roles".');
                                         $msg = &mt('Your LON-CAPA submission has been recorded')."\\n";                                  }
                                     }                              } else {
                                     $msg .= &mt('Your current LON-CAPA session will be transferred to a different server in [quant,_1,second].',$numsec);                                  if (($requrl =~ m{^/res/}) && ($env{'form.submitted'} =~ /^part_/)) {
                                     $newurl = '/adm/switchserver?otherserver='.$newserver;                                      $msg = &mt('Your LON-CAPA submission has been recorded')."\n";
                                     if (($env{'request.role'}) && ($env{'request.role'} ne 'cm')) {                                  }
                                         $newurl .= '&role='.$env{'request.role'};                                  $msg .= &mt('Your current LON-CAPA session will be transferred to a different server in [quant,_1,second].',$numsec);
                                   $newurl = '/adm/switchserver?otherserver='.$newserver;
                                   if (($env{'request.role'}) && ($env{'request.role'} ne 'cm')) {
                                       $newurl .= '&role='.$env{'request.role'};
                                   }
                                   if ($env{'request.symb'}) {
                                       my $shownsymb = &Apache::lonenc::check_encrypt($env{'request.symb'});
                                       if ($shownsymb =~ m{^/enc/}) {
                                           my $reqdmajor = 2;
                                           my $reqdminor = 11;
                                           my $reqdsubminor = 3;
                                           my $newserverrev = &Apache::lonnet::get_server_loncaparev('',$newserver);
                                           my $remoterev = &Apache::lonnet::get_server_loncaparev(undef,$newserver);
                                           my ($major,$minor,$subminor) = ($remoterev =~ /^\'?(\d+)\.(\d+)\.(\d+|)[\w.\-]+\'?$/);
                                           if (($major eq '' && $minor eq '') ||
                                               (($reqdmajor > $major) || (($reqdmajor == $major) && ($reqdminor > $minor)) ||
                                               (($reqdmajor == $major) && ($reqdminor == $minor) && (($subminor eq '') ||
                                                ($reqdsubminor > $subminor))))) {
                                               undef($shownsymb);
                                           }
                                     }                                      }
                                     if ($env{'request.symb'}) {                                      if ($shownsymb) {
                                         $newurl .= '&symb='.$env{'request.symb'};                                          &js_escape(\$shownsymb);
                                     } else {                                          $newurl .= '&symb='.$shownsymb;
                                         $newurl .= '&origurl='.$requrl;  
                                     }                                      }
                                   } else {
                                       my $shownurl = &Apache::lonenc::check_encrypt($requrl);
                                       &js_escape(\$shownurl);
                                       $newurl .= '&origurl='.$shownurl;
                                 }                                  }
                                 &js_escape(\$msg);                              }
                                 $result.=<<OFFLOAD                              &js_escape(\$msg);
                               $result.=<<OFFLOAD
 <meta http-equiv="pragma" content="no-cache" />  <meta http-equiv="pragma" content="no-cache" />
 <script type="text/javascript">  <script type="text/javascript">
 // <![CDATA[  // <![CDATA[
Line 7895  function LC_Offload_Now() { Line 8105  function LC_Offload_Now() {
 // ]]>  // ]]>
 </script>  </script>
 OFFLOAD  OFFLOAD
                             }  
                         }                          }
                     }                      }
                 }                  }
Line 8111  $args - additional optional args support Line 8320  $args - additional optional args support
                                     to lonhtmlcommon::breadcrumbs                                      to lonhtmlcommon::breadcrumbs
              group          -> includes the current group, if page is for a               group          -> includes the current group, if page is for a
                                specific group                                 specific group
                use_absolute   -> for request for external resource or syllabus, this
                                  will contain https://<hostname> if server uses
                                  https (as per hosts.tab), but request is for http
                hostname       -> hostname, originally from $r->hostname(), (optional).
   
 =back  =back
   
Line 8312  sub modal_link { Line 8525  sub modal_link {
         $target_attr = 'target="'.$target.'"';          $target_attr = 'target="'.$target.'"';
     }      }
     return <<"ENDLINK";      return <<"ENDLINK";
 <a href="$link" $target_attr title="$title" onclick="javascript:openMyModal('$link',$width,$height,'$scrolling','$transparency','$style'); return false;">  <a href="$link" $target_attr title="$title" onclick="javascript:openMyModal('$link',$width,$height,'$scrolling','$transparency','$style'); return false;">$linktext</a>
            $linktext</a>  
 ENDLINK  ENDLINK
 }  }
   
Line 8416  sub end_togglebox { Line 8628  sub end_togglebox {
 }  }
   
 sub LCprogressbar_script {  sub LCprogressbar_script {
    my ($id)=@_;     my ($id,$number_to_do)=@_;
    return(<<ENDPROGRESS);     if ($number_to_do) {
          return(<<ENDPROGRESS);
 <script type="text/javascript">  <script type="text/javascript">
 // <![CDATA[  // <![CDATA[
 \$('#progressbar$id').progressbar({  \$('#progressbar$id').progressbar({
Line 8430  sub LCprogressbar_script { Line 8643  sub LCprogressbar_script {
 // ]]>  // ]]>
 </script>  </script>
 ENDPROGRESS  ENDPROGRESS
      } else {
          return(<<ENDPROGRESS);
   <script type="text/javascript">
   // <![CDATA[
   \$('#progressbar$id').progressbar({
     value: false,
     create: function(event, ui) {
       \$('.ui-widget-header', this).css({'background':'#F0F0F0'});
       \$('.ui-progressbar-overlay', this).css({'margin':'0'});
     }
   });
   // ]]>
   </script>
   ENDPROGRESS
      }
 }  }
   
 sub LCprogressbarUpdate_script {  sub LCprogressbarUpdate_script {
    return(<<ENDPROGRESSUPDATE);     return(<<ENDPROGRESSUPDATE);
 <style type="text/css">  <style type="text/css">
 .ui-progressbar { position:relative; }  .ui-progressbar { position:relative; }
   .progress-label {position: absolute; width: 100%; text-align: center; top: 1px; font-weight: bold; text-shadow: 1px 1px 0 #fff;margin: 0; line-height: 200%; }
 .pblabel { position: absolute; width: 100%; text-align: center; line-height: 1.9em; }  .pblabel { position: absolute; width: 100%; text-align: center; line-height: 1.9em; }
 </style>  </style>
 <script type="text/javascript">  <script type="text/javascript">
 // <![CDATA[  // <![CDATA[
 var LCprogressTxt='---';  var LCprogressTxt='---';
   
 function LCupdateProgress(percent,progresstext,id) {  function LCupdateProgress(percent,progresstext,id,maxnum) {
    LCprogressTxt=progresstext;     LCprogressTxt=progresstext;
    \$('#progressbar'+id).progressbar('value',percent);     if ((maxnum == '') || (maxnum == undefined) || (maxnum == null)) {
          \$('#progressbar'+id).find('.progress-label').text(LCprogressTxt);
      } else if (percent === \$('#progressbar'+id).progressbar( "value" )) {
          \$('#progressbar'+id).find('.pblabel').text(LCprogressTxt);
      } else {
          \$('#progressbar'+id).progressbar('value',percent);
      }
 }  }
 // ]]>  // ]]>
 </script>  </script>
Line 8456  my $LCidcnt; Line 8691  my $LCidcnt;
 my $LCcurrentid;  my $LCcurrentid;
   
 sub LCprogressbar {  sub LCprogressbar {
     my ($r)=(@_);      my ($r,$number_to_do,$preamble)=@_;
     $LClastpercent=0;      $LClastpercent=0;
     $LCidcnt++;      $LCidcnt++;
     $LCcurrentid=$$.'_'.$LCidcnt;      $LCcurrentid=$$.'_'.$LCidcnt;
     my $starting=&mt('Starting');      my ($starting,$content);
     my $content=(<<ENDPROGBAR);      if ($number_to_do) {
           $starting=&mt('Starting');
           $content=(<<ENDPROGBAR);
   $preamble
   <div id="progressbar$LCcurrentid">    <div id="progressbar$LCcurrentid">
     <span class="pblabel">$starting</span>      <span class="pblabel">$starting</span>
   </div>    </div>
 ENDPROGBAR  ENDPROGBAR
     &r_print($r,$content.&LCprogressbar_script($LCcurrentid));      } else {
           $starting=&mt('Loading...');
           $LClastpercent='false';
           $content=(<<ENDPROGBAR);
   $preamble
     <div id="progressbar$LCcurrentid">
         <div class="progress-label">$starting</div>
     </div>
   ENDPROGBAR
       }
       &r_print($r,$content.&LCprogressbar_script($LCcurrentid,$number_to_do));
 }  }
   
 sub LCprogressbarUpdate {  sub LCprogressbarUpdate {
     my ($r,$val,$text)=@_;      my ($r,$val,$text,$number_to_do)=@_;
     unless ($val) {       if ($number_to_do) {
        if ($LClastpercent) {          unless ($val) { 
            $val=$LClastpercent;              if ($LClastpercent) {
        } else {                  $val=$LClastpercent;
            $val=0;              } else {
        }                  $val=0;
               }
           }
           if ($val<0) { $val=0; }
           if ($val>100) { $val=0; }
           $LClastpercent=$val;
           unless ($text) { $text=$val.'%'; }
       } else {
           $val = 'false';
     }      }
     if ($val<0) { $val=0; }  
     if ($val>100) { $val=0; }  
     $LClastpercent=$val;  
     unless ($text) { $text=$val.'%'; }  
     $text=&js_ready($text);      $text=&js_ready($text);
     &r_print($r,<<ENDUPDATE);      &r_print($r,<<ENDUPDATE);
 <script type="text/javascript">  <script type="text/javascript">
 // <![CDATA[  // <![CDATA[
 LCupdateProgress($val,'$text','$LCcurrentid');  LCupdateProgress($val,'$text','$LCcurrentid','$number_to_do');
 // ]]>  // ]]>
 </script>  </script>
 ENDUPDATE  ENDUPDATE
Line 11448  sub modify_html_refs { Line 11700  sub modify_html_refs {
                 return;                  return;
             }              }
         }           } 
         if (open(my $fh,"<$container")) {          if (open(my $fh,'<',$container)) {
             $content = join('', <$fh>);              $content = join('', <$fh>);
             close($fh);              close($fh);
         } else {          } else {
Line 11513  sub modify_html_refs { Line 11765  sub modify_html_refs {
                         }                          }
                     }                      }
                 } else {                  } else {
                     if (open(my $fh,">$container")) {                      if (open(my $fh,'>',$container)) {
                         print $fh $content;                          print $fh $content;
                         close($fh);                          close($fh);
                         $output = '<p>'.&mt('Updated [quant,_1,reference] in [_2].',                          $output = '<p>'.&mt('Updated [quant,_1,reference] in [_2].',
Line 12030  sub decompress_uploaded_file { Line 12282  sub decompress_uploaded_file {
   
 sub process_decompression {  sub process_decompression {
     my ($docudom,$docuname,$file,$destination,$dir_root,$hiddenelem) = @_;      my ($docudom,$docuname,$file,$destination,$dir_root,$hiddenelem) = @_;
       unless (($dir_root eq '/userfiles') && ($destination =~ m{^(docs|supplemental)/(default|\d+)/\d+$})) {
           return '<p class="LC_error">'.&mt('Not extracted.').'<br />'.
                  &mt('Unexpected file path.').'</p>'."\n";
       }
       unless (($docudom =~ /^$match_domain$/) && ($docuname =~ /^$match_courseid$/)) {
           return '<p class="LC_error">'.&mt('Not extracted.').'<br />'.
                  &mt('Unexpected course context.').'</p>'."\n";
       }
       unless ($file eq &Apache::lonnet::clean_filename($file)) {
           return '<p class="LC_error">'.&mt('Not extracted.').'<br />'.
                  &mt('Filename contained unexpected characters.').'</p>'."\n";
       }
     my ($dir,$error,$warning,$output);      my ($dir,$error,$warning,$output);
     if ($file !~ /\.(zip|tar|bz2|gz|tar.gz|tar.bz2|tgz)$/i) {      if ($file !~ /\.(zip|tar|bz2|gz|tar.gz|tar.bz2|tgz)$/i) {
         $error = &mt('Filename not a supported archive file type.').          $error = &mt('Filename not a supported archive file type.').
Line 12064  sub process_decompression { Line 12328  sub process_decompression {
                 }                  }
             }              }
             my $numskip = scalar(@to_skip);              my $numskip = scalar(@to_skip);
             if (($numskip > 0) &&               my $numoverwrite = scalar(@to_overwrite);
                 ($numskip == $env{'form.archive_itemcount'})) {              if (($numskip) && (!$numoverwrite)) {
                 $warning = &mt('All items in the archive file already exist, and no overwriting of existing files has been requested.');                           $warning = &mt('All items in the archive file already exist, and no overwriting of existing files has been requested.');         
             } elsif ($dir eq '') {              } elsif ($dir eq '') {
                 $error = &mt('Directory containing archive file unavailable.');                  $error = &mt('Directory containing archive file unavailable.');
             } elsif (!$error) {              } elsif (!$error) {
                 my ($decompressed,$display);                  my ($decompressed,$display);
                 if ($numskip > 0) {                  if (($numskip) || ($numoverwrite)) {
                     my $tempdir = time.'_'.$$.int(rand(10000));                      my $tempdir = time.'_'.$$.int(rand(10000));
                     mkdir("$dir/$tempdir",0755);                      mkdir("$dir/$tempdir",0755);
                     system("mv $dir/$file $dir/$tempdir/$file");                      if (&File::Copy::move("$dir/$file","$dir/$tempdir/$file")) {
                     ($decompressed,$display) =                           ($decompressed,$display) =
                         &decompress_uploaded_file($file,"$dir/$tempdir");                              &decompress_uploaded_file($file,"$dir/$tempdir");
                     foreach my $item (@to_skip) {                          foreach my $item (@to_skip) {
                         if (($item ne '') && ($item !~ /\.\./)) {                              if (($item ne '') && ($item !~ /\.\./)) {
                             if (-f "$dir/$tempdir/$item") {                                   if (-f "$dir/$tempdir/$item") {
                                 unlink("$dir/$tempdir/$item");                                      unlink("$dir/$tempdir/$item");
                             } elsif (-d "$dir/$tempdir/$item") {                                  } elsif (-d "$dir/$tempdir/$item") {
                                 system("rm -rf $dir/$tempdir/$item");                                      &File::Path::remove_tree("$dir/$tempdir/$item",{ safe => 1 });
                                   }
                               }
                           }
                           foreach my $item (@to_overwrite) {
                               if ((-e "$dir/$tempdir/$item") && (-e "$dir/$item")) {
                                   if (($item ne '') && ($item !~ /\.\./)) {
                                       if (-f "$dir/$item") {
                                           unlink("$dir/$item");
                                       } elsif (-d "$dir/$item") {
                                           &File::Path::remove_tree("$dir/$item",{ safe => 1 });
                                       }
                                       &File::Copy::move("$dir/$tempdir/$item","$dir/$item");
                                   }
                             }                              }
                         }                          }
                           if (&File::Copy::move("$dir/$tempdir/$file","$dir/$file")) {
                               &File::Path::remove_tree("$dir/$tempdir",{ safe => 1 });
                           }
                     }                      }
                     system("mv $dir/$tempdir/* $dir");  
                     rmdir("$dir/$tempdir");     
                 } else {                  } else {
                     ($decompressed,$display) =                       ($decompressed,$display) = 
                         &decompress_uploaded_file($file,$dir);                          &decompress_uploaded_file($file,$dir);
Line 12105  sub process_decompression { Line 12383  sub process_decompression {
                     if (ref($newdirlistref) eq 'ARRAY') {                      if (ref($newdirlistref) eq 'ARRAY') {
                         foreach my $dir_line (@{$newdirlistref}) {                          foreach my $dir_line (@{$newdirlistref}) {
                             my ($item,undef,undef,$testdir)=split(/\&/,$dir_line,5);                              my ($item,undef,undef,$testdir)=split(/\&/,$dir_line,5);
                             unless (($item =~ /^\.+$/) || ($item eq $file) ||                               unless (($item =~ /^\.+$/) || ($item eq $file)) { 
                                     ((@to_skip > 0) && (grep(/^\Q$item\E$/,@to_skip)))) {  
                                 push(@newitems,$item);                                  push(@newitems,$item);
                                 if ($dirptr&$testdir) {                                  if ($dirptr&$testdir) {
                                     $is_dir{$item} = 1;                                      $is_dir{$item} = 1;
Line 12591  END Line 12868  END
 sub process_extracted_files {  sub process_extracted_files {
     my ($context,$docudom,$docuname,$destination,$dir_root,$hiddenelem) = @_;      my ($context,$docudom,$docuname,$destination,$dir_root,$hiddenelem) = @_;
     my $numitems = $env{'form.archive_count'};      my $numitems = $env{'form.archive_count'};
     return unless ($numitems);      return if ((!$numitems) || ($numitems =~ /\D/));
     my @ids=&Apache::lonnet::current_machine_ids();      my @ids=&Apache::lonnet::current_machine_ids();
     my ($prefix,$pathtocheck,$dir,$ishome,$error,$warning,%toplevelitems,%is_dir,      my ($prefix,$pathtocheck,$dir,$ishome,$error,$warning,%toplevelitems,%is_dir,
         %folders,%containers,%mapinner,%prompttofetch);          %folders,%containers,%mapinner,%prompttofetch);
Line 12604  sub process_extracted_files { Line 12881  sub process_extracted_files {
     } else {      } else {
         $prefix = $Apache::lonnet::perlvar{'lonDocRoot'};          $prefix = $Apache::lonnet::perlvar{'lonDocRoot'};
         $pathtocheck = "$dir_root/$docudom/$docuname/$destination";          $pathtocheck = "$dir_root/$docudom/$docuname/$destination";
         $dir = "$dir_root/$docudom/$docuname";              $dir = "$dir_root/$docudom/$docuname";
     }      }
     my $currdir = "$dir_root/$destination";      my $currdir = "$dir_root/$destination";
     (my $docstype,$mapinner{'0'}) = ($destination =~ m{^(docs|supplemental)/(\w+)/});      (my $docstype,$mapinner{'0'}) = ($destination =~ m{^(docs|supplemental)/(\w+)/});
Line 12693  sub process_extracted_files { Line 12970  sub process_extracted_files {
                                                         '.'.$containers{$outer},1,1);                                                          '.'.$containers{$outer},1,1);
                             $newseqid{$i} = $newidx;                              $newseqid{$i} = $newidx;
                             unless ($errtext) {                              unless ($errtext) {
                                 $result .=  '<li>'.&mt('Folder: [_1] added to course',$docstitle).'</li>'."\n";                                  $result .=  '<li>'.&mt('Folder: [_1] added to course',
                                                          &HTML::Entities::encode($docstitle,'<>&"'))..
                                               '</li>'."\n";
                             }                              }
                         }                          }
                     } else {                      } else {
Line 12702  sub process_extracted_files { Line 12981  sub process_extracted_files {
                             my $url = '/uploaded/'.$docudom.'/'.$docuname.'/'.                              my $url = '/uploaded/'.$docudom.'/'.$docuname.'/'.
                                       $docstype.'/'.$mapinner{$outer}.'/'.$newidx.'/'.                                        $docstype.'/'.$mapinner{$outer}.'/'.$newidx.'/'.
                                       $title;                                        $title;
                             if (!-e "$prefix$dir/$docstype/$mapinner{$outer}") {                              if (($outer !~ /\D/) && ($mapinner{$outer} !~ /\D/) && ($newidx !~ /\D/)) {
                                 mkdir("$prefix$dir/$docstype/$mapinner{$outer}",0755);                                  if (!-e "$prefix$dir/$docstype/$mapinner{$outer}") {
                             }                                      mkdir("$prefix$dir/$docstype/$mapinner{$outer}",0755);
                             if (!-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") {  
                                 mkdir("$prefix$dir/$docstype/$mapinner{$outer}/$newidx");  
                             }  
                             if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") {  
                                 system("mv $prefix$path $prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title");  
                                 $newdest{$i} = "$prefix$dir/$docstype/$mapinner{$outer}/$newidx";  
                                 unless ($ishome) {  
                                     my $fetch = "$newdest{$i}/$title";  
                                     $fetch =~ s/^\Q$prefix$dir\E//;  
                                     $prompttofetch{$fetch} = 1;  
                                 }                                  }
                             }                                  if (!-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") {
                             $LONCAPA::map::resources[$newidx]=                                      mkdir("$prefix$dir/$docstype/$mapinner{$outer}/$newidx");
                                 $docstitle.':'.$url.':false:normal:res';                                  }
                             push(@LONCAPA::map::order, $newidx);                                  if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") {
                             my ($outtext,$errtext)=                                      if (rename("$prefix$path","$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title")) {
                                 &LONCAPA::map::storemap('/uploaded/'.$docudom.'/'.                                          $newdest{$i} = "$prefix$dir/$docstype/$mapinner{$outer}/$newidx";
                                                         $docuname.'/'.$folders{$outer}.                                          unless ($ishome) {
                                                         '.'.$containers{$outer},1,1);                                              my $fetch = "$newdest{$i}/$title";
                             unless ($errtext) {                                              $fetch =~ s/^\Q$prefix$dir\E//;
                                 if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title") {                                              $prompttofetch{$fetch} = 1;
                                     $result .= '<li>'.&mt('File: [_1] added to course',$docstitle).'</li>'."\n";                                          }
                                      }
                                   }
                                   $LONCAPA::map::resources[$newidx]=
                                       $docstitle.':'.$url.':false:normal:res';
                                   push(@LONCAPA::map::order, $newidx);
                                   my ($outtext,$errtext)=
                                       &LONCAPA::map::storemap('/uploaded/'.$docudom.'/'.
                                                               $docuname.'/'.$folders{$outer}.
                                                               '.'.$containers{$outer},1,1);
                                   unless ($errtext) {
                                       if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title") {
                                           $result .= '<li>'.&mt('File: [_1] added to course',
                                                                 &HTML::Entities::encode($docstitle,'<>&"')).
                                                      '</li>'."\n";
                                       }
                                 }                                  }
                               } else {
                                   $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',
                                                   &HTML::Entities::encode($path,'<>&"')).'<br />';
                             }                              }
                         }                          }
                     }                      }
                 }                  }
             } else {              } else {
                 $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',$path).'<br />';                  $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',
                                   &HTML::Entities::encode($path,'<>&"')).'<br />';
             }              }
         }          }
         for (my $i=1; $i<=$numitems; $i++) {          for (my $i=1; $i<=$numitems; $i++) {
Line 12794  sub process_extracted_files { Line 13082  sub process_extracted_files {
                         }                          }
                         if ($fullpath ne '') {                          if ($fullpath ne '') {
                             if (-e "$prefix$path") {                              if (-e "$prefix$path") {
                                 system("mv $prefix$path $fullpath/$title");                                  unless (rename("$prefix$path","$fullpath/$title")) {
                                        $warning .= &mt('Failed to rename dependency').'<br />';
                                   }
                             }                              }
                             if (-e "$fullpath/$title") {                              if (-e "$fullpath/$title") {
                                 my $showpath;                                  my $showpath;
Line 12803  sub process_extracted_files { Line 13093  sub process_extracted_files {
                                 } else {                                  } else {
                                     $showpath = "/$title";                                      $showpath = "/$title";
                                 }                                  }
                                 $result .= '<li>'.&mt('[_1] included as a dependency',$showpath).'</li>'."\n";                                  $result .= '<li>'.&mt('[_1] included as a dependency',
                             }                                                        &HTML::Entities::encode($showpath,'<>&"')).
                             unless ($ishome) {                                             '</li>'."\n";
                                 my $fetch = "$fullpath/$title";                                  unless ($ishome) {
                                 $fetch =~ s/^\Q$prefix$dir\E//;                                      my $fetch = "$fullpath/$title";
                                 $prompttofetch{$fetch} = 1;                                      $fetch =~ s/^\Q$prefix$dir\E//;
                                       $prompttofetch{$fetch} = 1;
                                   }
                             }                              }
                         }                          }
                     }                      }
                 } elsif ($env{'form.archive_'.$referrer{$i}} eq 'discard') {                  } elsif ($env{'form.archive_'.$referrer{$i}} eq 'discard') {
                     $warning .= &mt('[_1] is a dependency of [_2], which was discarded.',                      $warning .= &mt('[_1] is a dependency of [_2], which was discarded.',
                                     $path,$env{'form.archive_content_'.$referrer{$i}}).'<br />';                                      &HTML::Entities::encode($path,'<>&"'),
                                       &HTML::Entities::encode($env{'form.archive_content_'.$referrer{$i}},'<>&"')).
                                   '<br />';
                 }                  }
             } else {              } else {
                 $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',$path).'<br />';                  $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',
                                   &HTML::Entities::encode($path)).'<br />';
             }              }
         }          }
         if (keys(%todelete)) {          if (keys(%todelete)) {
Line 13091  sub upfile_store { Line 13386  sub upfile_store {
     $env{'form.upfile'}=~s/\n+/\n/gs;      $env{'form.upfile'}=~s/\n+/\n/gs;
     $env{'form.upfile'}=~s/\n+$//gs;      $env{'form.upfile'}=~s/\n+$//gs;
   
     my $datatoken=$env{'user.name'}.'_'.$env{'user.domain'}.      my $datatoken = &valid_datatoken($env{'user.name'}.'_'.$env{'user.domain'}.
  '_enroll_'.$env{'request.course.id'}.'_'.time.'_'.$$;                                       '_enroll_'.$env{'request.course.id'}.'_'.
                                        time.'_'.$$);
       return if ($datatoken eq '');
   
     {      {
         my $datafile = $r->dir_config('lonDaemons').          my $datafile = $r->dir_config('lonDaemons').
                            '/tmp/'.$datatoken.'.tmp';                             '/tmp/'.$datatoken.'.tmp';
         if ( open(my $fh,">$datafile") ) {          if ( open(my $fh,'>',$datafile) ) {
             print $fh $env{'form.upfile'};              print $fh $env{'form.upfile'};
             close($fh);              close($fh);
         }          }
Line 13106  sub upfile_store { Line 13404  sub upfile_store {
   
 =pod  =pod
   
 =item * &load_tmp_file($r)  =item * &load_tmp_file($r,$datatoken)
   
 Load uploaded file from tmp, $r should be the HTTP Request object,  Load uploaded file from tmp, $r should be the HTTP Request object,
 needs $env{'form.datatoken'},  $datatoken is the name to assign to the temporary file.
 sets $env{'form.upfile'} to the contents of the file  sets $env{'form.upfile'} to the contents of the file
   
 =cut  =cut
   
 sub load_tmp_file {  sub load_tmp_file {
     my $r=shift;      my ($r,$datatoken) = @_;
       return if ($datatoken eq '');
     my @studentdata=();      my @studentdata=();
     {      {
         my $studentfile = $r->dir_config('lonDaemons').          my $studentfile = $r->dir_config('lonDaemons').
                               '/tmp/'.$env{'form.datatoken'}.'.tmp';                                '/tmp/'.$datatoken.'.tmp';
         if ( open(my $fh,"<$studentfile") ) {          if ( open(my $fh,'<',$studentfile) ) {
             @studentdata=<$fh>;              @studentdata=<$fh>;
             close($fh);              close($fh);
         }          }
Line 13128  sub load_tmp_file { Line 13427  sub load_tmp_file {
     $env{'form.upfile'}=join('',@studentdata);      $env{'form.upfile'}=join('',@studentdata);
 }  }
   
   sub valid_datatoken {
       my ($datatoken) = @_;
       if ($datatoken =~ /^$match_username\_$match_domain\_enroll_(|$match_domain\_$match_courseid)\_\d+_\d+$/) {
           return $datatoken;
       }
       return;
   }
   
 =pod  =pod
   
 =item * &upfile_record_sep()  =item * &upfile_record_sep()
Line 14016  defdom (domain for which to retrieve con Line 14323  defdom (domain for which to retrieve con
 origmail (scalar - email address of recipient from loncapa.conf,  origmail (scalar - email address of recipient from loncapa.conf,
 i.e., predates configuration by DC via domainprefs.pm  i.e., predates configuration by DC via domainprefs.pm
   
   $requname username of requester (if mailing type is helpdeskmail)
   
   $requdom domain of requester (if mailing type is helpdeskmail)
   
   $reqemail e-mail address of requester (if mailing type is helpdeskmail)
   
 Returns: comma separated list of addresses to which to send e-mail.  Returns: comma separated list of addresses to which to send e-mail.
   
 =back  =back
Line 14025  Returns: comma separated list of address Line 14338  Returns: comma separated list of address
 ############################################################  ############################################################
 ############################################################  ############################################################
 sub build_recipient_list {  sub build_recipient_list {
     my ($defmail,$mailing,$defdom,$origmail) = @_;      my ($defmail,$mailing,$defdom,$origmail,$requname,$requdom,$reqemail) = @_;
     my @recipients;      my @recipients;
     my ($otheremails,$lastresort,$allbcc,$addtext);      my ($otheremails,$lastresort,$allbcc,$addtext);
     my %domconfig =      my %domconfig =
Line 14066  sub build_recipient_list { Line 14379  sub build_recipient_list {
         } elsif ($origmail ne '') {          } elsif ($origmail ne '') {
             $lastresort = $origmail;              $lastresort = $origmail;
         }          }
           if ($mailing eq 'helpdeskmail') {
               if ((ref($domconfig{'contacts'}{'overrides'}) eq 'HASH') &&
                   (keys(%{$domconfig{'contacts'}{'overrides'}}))) {
                   my ($inststatus,$inststatus_checked);
                   if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '') &&
                       ($env{'user.domain'} ne 'public')) {
                       $inststatus_checked = 1;
                       $inststatus = $env{'environment.inststatus'};
                   }
                   unless ($inststatus_checked) {
                       if (($requname ne '') && ($requdom ne '')) {
                           if (($requname =~ /^$match_username$/) &&
                               ($requdom =~ /^$match_domain$/) &&
                               (&Apache::lonnet::domain($requdom))) {
                               my $requhome = &Apache::lonnet::homeserver($requname,
                                                                         $requdom);
                               unless ($requhome eq 'no_host') {
                                   my %userenv = &Apache::lonnet::userenvironment($requdom,$requname,'inststatus');
                                   $inststatus = $userenv{'inststatus'};
                                   $inststatus_checked = 1;
                               }
                           }
                       }
                   }
                   unless ($inststatus_checked) {
                       if ($reqemail =~ /^[^\@]+\@[^\@]+$/) {
                           my %srch = (srchby     => 'email',
                                       srchdomain => $defdom,
                                       srchterm   => $reqemail,
                                       srchtype   => 'exact');
                           my %srch_results = &Apache::lonnet::usersearch(\%srch);
                           foreach my $uname (keys(%srch_results)) {
                               if (ref($srch_results{$uname}{'inststatus'}) eq 'ARRAY') {
                                   $inststatus = join(',',@{$srch_results{$uname}{'inststatus'}});
                                   $inststatus_checked = 1;
                                   last;
                               }
                           }
                           unless ($inststatus_checked) {
                               my ($dirsrchres,%srch_results) = &Apache::lonnet::inst_directory_query(\%srch);
                               if ($dirsrchres eq 'ok') {
                                   foreach my $uname (keys(%srch_results)) {
                                       if (ref($srch_results{$uname}{'inststatus'}) eq 'ARRAY') {
                                           $inststatus = join(',',@{$srch_results{$uname}{'inststatus'}});
                                           $inststatus_checked = 1;
                                           last;
                                       }
                                   }
                               }
                           }
                       }
                   }
                   if ($inststatus ne '') {
                       foreach my $status (split(/\:/,$inststatus)) {
                           if (ref($domconfig{'contacts'}{'overrides'}{$status}) eq 'HASH') {
                               my @contacts = ('adminemail','supportemail');
                               foreach my $item (@contacts) {
                                   if ($domconfig{'contacts'}{'overrides'}{$status}{$item}) {
                                       my $addr = $domconfig{'contacts'}{'overrides'}{$status};
                                       if (!grep(/^\Q$addr\E$/,@recipients)) {
                                           push(@recipients,$addr);
                                       }
                                   }
                               }
                               $otheremails = $domconfig{'contacts'}{'overrides'}{$status}{'others'};
                               if ($domconfig{'contacts'}{'overrides'}{$status}{'bcc'}) {
                                   my @bccs = split(/,/,$domconfig{'contacts'}{'overrides'}{$status}{'bcc'});
                                   my @ok_bccs;
                                   foreach my $bcc (@bccs) {
                                       $bcc =~ s/^\s+//g;
                                       $bcc =~ s/\s+$//g;
                                       if ($bcc =~ m/^[^\@]+\@[^\@]+$/) {
                                           if (!(grep(/^\Q$bcc\E$/,@ok_bccs))) {
                                               push(@ok_bccs,$bcc);
                                           }
                                       }
                                   }
                                   if (@ok_bccs > 0) {
                                       $allbcc = join(', ',@ok_bccs);
                                   }
                               }
                               $addtext = $domconfig{'contacts'}{'overrides'}{$status}{'include'};
                               last;
                           }
                       }
                   }
               }
           }
     } elsif ($origmail ne '') {      } elsif ($origmail ne '') {
         $lastresort = $origmail;          $lastresort = $origmail;
     }      }
       if (($mailing eq 'helpdeskmail') && ($lastresort ne '')) {
     if (($mailing eq 'helpdesk') && ($lastresort ne '')) {  
         unless (grep(/^\Q$defdom\E$/,&Apache::lonnet::current_machine_domains())) {          unless (grep(/^\Q$defdom\E$/,&Apache::lonnet::current_machine_domains())) {
             my $lonhost = $Apache::lonnet::perlvar{'lonHostID'};              my $lonhost = $Apache::lonnet::perlvar{'lonHostID'};
             my $machinedom = $Apache::lonnet::perlvar{'lonDefDomain'};              my $machinedom = $Apache::lonnet::perlvar{'lonDefDomain'};
Line 14150  sub build_recipient_list { Line 14550  sub build_recipient_list {
             }              }
         }          }
     }      }
     if ($mailing eq 'helpdesk') {      if ($mailing eq 'helpdeskmail') {
         if ((!@recipients) && ($lastresort ne '')) {          if ((!@recipients) && ($lastresort ne '')) {
             push(@recipients,$lastresort);              push(@recipients,$lastresort);
         }          }
Line 14255  jsarray (reference to array of categorie Line 14655  jsarray (reference to array of categorie
 subcats (reference to hash of arrays containing all subcategories within each   subcats (reference to hash of arrays containing all subcategories within each 
          category, -recursive)           category, -recursive)
   
   maxd (reference to hash used to hold max depth for all top-level categories).
   
 Returns: nothing  Returns: nothing
   
 Side effects: populates trails and allitems hash references.  Side effects: populates trails and allitems hash references.
Line 14262  Side effects: populates trails and allit Line 14664  Side effects: populates trails and allit
 =cut  =cut
   
 sub extract_categories {  sub extract_categories {
     my ($categories,$cats,$trails,$allitems,$idx,$jsarray,$subcats) = @_;      my ($categories,$cats,$trails,$allitems,$idx,$jsarray,$subcats,$maxd) = @_;
     if (ref($categories) eq 'HASH') {      if (ref($categories) eq 'HASH') {
         &gather_categories($categories,$cats,$idx,$jsarray);          &gather_categories($categories,$cats,$idx,$jsarray);
         if (ref($cats->[0]) eq 'ARRAY') {          if (ref($cats->[0]) eq 'ARRAY') {
Line 14288  sub extract_categories { Line 14690  sub extract_categories {
                         if (ref($subcats) eq 'HASH') {                          if (ref($subcats) eq 'HASH') {
                             push(@{$subcats->{$item}},&escape($category).':'.&escape($name).':1');                              push(@{$subcats->{$item}},&escape($category).':'.&escape($name).':1');
                         }                          }
                         &recurse_categories($cats,2,$category,$trails,$allitems,\@parents,$subcats);                          &recurse_categories($cats,2,$category,$trails,$allitems,\@parents,$subcats,$maxd);
                     }                      }
                 } else {                  } else {
                     if (ref($subcats) eq 'HASH') {                      if (ref($subcats) eq 'HASH') {
                         $subcats->{$item} = [];                          $subcats->{$item} = [];
                     }                      }
                       if (ref($maxd) eq 'HASH') {
                           $maxd->{$name} = 1;
                       }
                 }                  }
             }              }
         }          }
Line 14331  Side effects: populates trails and allit Line 14736  Side effects: populates trails and allit
 =cut  =cut
   
 sub recurse_categories {  sub recurse_categories {
     my ($cats,$depth,$category,$trails,$allitems,$parents,$subcats) = @_;      my ($cats,$depth,$category,$trails,$allitems,$parents,$subcats,$maxd) = @_;
     my $shallower = $depth - 1;      my $shallower = $depth - 1;
     if (ref($cats->[$depth]{$category}) eq 'ARRAY') {      if (ref($cats->[$depth]{$category}) eq 'ARRAY') {
         for (my $k=0; $k<@{$cats->[$depth]{$category}}; $k++) {          for (my $k=0; $k<@{$cats->[$depth]{$category}}; $k++) {
Line 14358  sub recurse_categories { Line 14763  sub recurse_categories {
                 }                  }
             }              }
             &recurse_categories($cats,$deeper,$name,$trails,$allitems,$parents,              &recurse_categories($cats,$deeper,$name,$trails,$allitems,$parents,
                                 $subcats);                                  $subcats,$maxd);
             pop(@{$parents});              pop(@{$parents});
         }          }
     } else {      } else {
         my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower;          my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower;
         my $trailstr = join(' -&gt; ',(@{$parents},$category));          my $trailstr = join(' &raquo; ',(@{$parents},$category));
         if ($allitems->{$item} eq '') {          if ($allitems->{$item} eq '') {
             push(@{$trails},$trailstr);              push(@{$trails},$trailstr);
             $allitems->{$item} = scalar(@{$trails})-1;              $allitems->{$item} = scalar(@{$trails})-1;
         }          }
           if (ref($maxd) eq 'HASH') {
               if ($depth > $maxd->{$parents->[0]}) {
                   $maxd->{$parents->[0]} = $depth;
               }
           }
     }      }
     return;      return;
 }  }
Line 14399  sub assign_categories_table { Line 14809  sub assign_categories_table {
     my ($cathash,$currcat,$type,$disabled) = @_;      my ($cathash,$currcat,$type,$disabled) = @_;
     my $output;      my $output;
     if (ref($cathash) eq 'HASH') {      if (ref($cathash) eq 'HASH') {
         my (@cats,@trails,%allitems,%idx,@jsarray,@path,$maxdepth);          my (@cats,@trails,%allitems,%idx,@jsarray,%maxd,@path,$maxdepth);
         &extract_categories($cathash,\@cats,\@trails,\%allitems,\%idx,\@jsarray);          &extract_categories($cathash,\@cats,\@trails,\%allitems,\%idx,\@jsarray,\%maxd);
         $maxdepth = scalar(@cats);          $maxdepth = scalar(@cats);
         if (@cats > 0) {          if (@cats > 0) {
             my $itemcount = 0;              my $itemcount = 0;
Line 15179  sub construct_course { Line 15589  sub construct_course {
 # Open all assignments  # Open all assignments
 #  #
     if ($args->{'openall'}) {      if ($args->{'openall'}) {
          my $opendate = time;
          if ($args->{'openallfrom'} =~ /^\d+$/) {
              $opendate = $args->{'openallfrom'};
          }
        my $storeunder=$$crsudom.'_'.$$crsunum.'.0.opendate';         my $storeunder=$$crsudom.'_'.$$crsunum.'.0.opendate';
        my %storecontent = ($storeunder         => time,         my %storecontent = ($storeunder         => $opendate,
                            $storeunder.'.type' => 'date_start');                             $storeunder.'.type' => 'date_start');
                 $outcome .= &mt('All assignments open starting [_1]',
        $outcome .= &mt('Opening all assignments').': '.&Apache::lonnet::cput                         &Apache::lonlocal::locallocaltime($opendate)).': '.
                  ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed;                     &Apache::lonnet::cput
                          ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed;
    }     }
 #  #
 # Set first page  # Set first page
Line 15418  sub init_user_environment { Line 15833  sub init_user_environment {
     opendir(DIR,$lonids);      opendir(DIR,$lonids);
     while ($filename=readdir(DIR)) {      while ($filename=readdir(DIR)) {
  if ($filename=~/^$username\_\d+\_$domain\_$authhost\.id$/) {   if ($filename=~/^$username\_\d+\_$domain\_$authhost\.id$/) {
     unlink($lonids.'/'.$filename);                      if (tie(my %oldenv,'GDBM_File',"$lonids/$filename",
                               &GDBM_READER(),0640)) {
                           my $linkedfile;
                           if (exists($oldenv{'user.linkedenv'})) {
                               $linkedfile = $oldenv{'user.linkedenv'};
                           }
                           untie(%oldenv);
                           if (unlink("$lonids/$filename")) {
                               if ($linkedfile =~ /^[a-f0-9]+_linked$/) {
                                   if (-l "$lonids/$linkedfile.id") {
                                       unlink("$lonids/$linkedfile.id");
                                   }
                               }
                           }
                       } else {
                           unlink($lonids.'/'.$filename);
                       }
  }   }
     }      }
     closedir(DIR);      closedir(DIR);
Line 15469  sub init_user_environment { Line 15900  sub init_user_environment {
 # --------------------------------------------------------- Write first profile  # --------------------------------------------------------- Write first profile
   
     {      {
           my $ip = &Apache::lonnet::get_requestor_ip();
  my %initial_env =    my %initial_env = 
     ("user.name"          => $username,      ("user.name"          => $username,
      "user.domain"        => $domain,       "user.domain"        => $domain,
Line 15487  sub init_user_environment { Line 15919  sub init_user_environment {
      "request.course.sec" => '',       "request.course.sec" => '',
      "request.role"       => 'cm',       "request.role"       => 'cm',
      "request.role.adv"   => $env{'user.adv'},       "request.role.adv"   => $env{'user.adv'},
      "request.host"       => $ENV{'REMOTE_ADDR'},);       "request.host"       => $ip,);
   
         if ($form->{'localpath'}) {          if ($form->{'localpath'}) {
     $initial_env{"browser.localpath"}  = $form->{'localpath'};      $initial_env{"browser.localpath"}  = $form->{'localpath'};
Line 16551  sub symb_to_docspath { Line 16983  sub symb_to_docspath {
 }  }
   
 sub captcha_display {  sub captcha_display {
     my ($context,$lonhost) = @_;      my ($context,$lonhost,$defdom) = @_;
     my ($output,$error);      my ($output,$error);
     my ($captcha,$pubkey,$privkey,$version) =      my ($captcha,$pubkey,$privkey,$version) =
         &get_captcha_config($context,$lonhost);          &get_captcha_config($context,$lonhost,$defdom);
     if ($captcha eq 'original') {      if ($captcha eq 'original') {
         $output = &create_captcha();          $output = &create_captcha();
         unless ($output) {          unless ($output) {
Line 16570  sub captcha_display { Line 17002  sub captcha_display {
 }  }
   
 sub captcha_response {  sub captcha_response {
     my ($context,$lonhost) = @_;      my ($context,$lonhost,$defdom) = @_;
     my ($captcha_chk,$captcha_error);      my ($captcha_chk,$captcha_error);
     my ($captcha,$pubkey,$privkey,$version) = &get_captcha_config($context,$lonhost);      my ($captcha,$pubkey,$privkey,$version) = &get_captcha_config($context,$lonhost,$defdom);
     if ($captcha eq 'original') {      if ($captcha eq 'original') {
         ($captcha_chk,$captcha_error) = &check_captcha();          ($captcha_chk,$captcha_error) = &check_captcha();
     } elsif ($captcha eq 'recaptcha') {      } elsif ($captcha eq 'recaptcha') {
Line 16584  sub captcha_response { Line 17016  sub captcha_response {
 }  }
   
 sub get_captcha_config {  sub get_captcha_config {
     my ($context,$lonhost) = @_;      my ($context,$lonhost,$dom_in_effect) = @_;
     my ($captcha,$pubkey,$privkey,$version,$hashtocheck);      my ($captcha,$pubkey,$privkey,$version,$hashtocheck);
     my $hostname = &Apache::lonnet::hostname($lonhost);      my $hostname = &Apache::lonnet::hostname($lonhost);
     my $serverhomeID = &Apache::lonnet::get_server_homeID($hostname);      my $serverhomeID = &Apache::lonnet::get_server_homeID($hostname);
Line 16632  sub get_captcha_config { Line 17064  sub get_captcha_config {
         } elsif ($domconfhash{$serverhomedom.'.login.captcha'} eq 'original') {          } elsif ($domconfhash{$serverhomedom.'.login.captcha'} eq 'original') {
             $captcha = 'original';              $captcha = 'original';
         }          }
       } elsif ($context eq 'passwords') {
           if ($dom_in_effect) {
               my %passwdconf = &Apache::lonnet::get_passwdconf($dom_in_effect);
               if ($passwdconf{'captcha'} eq 'recaptcha') {
                   if (ref($passwdconf{'recaptchakeys'}) eq 'HASH') {
                       $pubkey = $passwdconf{'recaptchakeys'}{'public'};
                       $privkey = $passwdconf{'recaptchakeys'}{'private'};
                   }
                   if ($privkey && $pubkey) {
                       $captcha = 'recaptcha';
                       $version = $passwdconf{'recaptchaversion'};
                       if ($version ne '2') {
                           $version = 1;
                       }
                   } else {
                       $captcha = 'original';
                   }
               } elsif ($passwdconf{'captcha'} ne 'notused') {
                   $captcha = 'original';
               }
           }
     }      }
     return ($captcha,$pubkey,$privkey,$version);      return ($captcha,$pubkey,$privkey,$version);
 }  }
Line 16712  sub create_recaptcha { Line 17165  sub create_recaptcha {
 sub check_recaptcha {  sub check_recaptcha {
     my ($privkey,$version) = @_;      my ($privkey,$version) = @_;
     my $captcha_chk;      my $captcha_chk;
       my $ip = &Apache::lonnet::get_requestor_ip(); 
     if ($version >= 2) {      if ($version >= 2) {
         my $ua = LWP::UserAgent->new;          my $ua = LWP::UserAgent->new;
         $ua->timeout(10);          $ua->timeout(10);
         my %info = (          my %info = (
                      secret   => $privkey,                       secret   => $privkey,
                      response => $env{'form.g-recaptcha-response'},                       response => $env{'form.g-recaptcha-response'},
                      remoteip => $ENV{'REMOTE_ADDR'},                       remoteip => $ip,
                    );                     );
         my $response = $ua->post('https://www.google.com/recaptcha/api/siteverify',\%info);          my $response = $ua->post('https://www.google.com/recaptcha/api/siteverify',\%info);
         if ($response->is_success)  {          if ($response->is_success)  {
Line 16734  sub check_recaptcha { Line 17188  sub check_recaptcha {
         my $captcha_result =          my $captcha_result =
             $captcha->check_answer(              $captcha->check_answer(
                                     $privkey,                                      $privkey,
                                     $ENV{'REMOTE_ADDR'},                                      $ip,
                                     $env{'form.recaptcha_challenge_field'},                                      $env{'form.recaptcha_challenge_field'},
                                     $env{'form.recaptcha_response_field'},                                      $env{'form.recaptcha_response_field'},
                                   );                                    );
Line 16851  sub des_decrypt { Line 17305  sub des_decrypt {
     return $plaintext;      return $plaintext;
 }  }
   
   sub is_nonframeable {
       my ($url,$absolute,$hostname,$ip,$nocache) = @_;
       my ($remprotocol,$remhost) = ($url =~ m{^(https?)\://(([a-z0-9]+(-[a-z0-9]+)*\.)+[a-z]{2,})}i);
       return if (($remprotocol eq '') || ($remhost eq ''));
   
       $remprotocol = lc($remprotocol);
       $remhost = lc($remhost);
       my $remport = 80;
       if ($remprotocol eq 'https') {
           $remport = 443;
       }
       my ($result,$cached) = &Apache::lonnet::is_cached_new('noiframe',$remhost.':'.$remport);
       if ($cached) {
           unless ($nocache) {
               if ($result) {
                   return 1;
               } else {
                   return 0;
               }
           }
       }
       my $uselink;
       my $request = new HTTP::Request('HEAD',$url);
       my $ua = LWP::UserAgent->new;
       $ua->timeout(5);
       my $response=$ua->request($request);
       if ($response->is_success()) {
           my $secpolicy = lc($response->header('content-security-policy'));
           my $xframeop = lc($response->header('x-frame-options'));
           $secpolicy =~ s/^\s+|\s+$//g;
           $xframeop =~ s/^\s+|\s+$//g;
           if (($secpolicy ne '') || ($xframeop ne '')) {
               my $remotehost = $remprotocol.'://'.$remhost;
               my ($origin,$protocol,$port);
               if ($ENV{'SERVER_PORT'} =~/^\d+$/) {
                   $port = $ENV{'SERVER_PORT'};
               } else {
                   $port = 80;
               }
               if ($absolute eq '') {
                   $protocol = 'http:';
                   if ($port == 443) {
                       $protocol = 'https:';
                   }
                   $origin = $protocol.'//'.lc($hostname);
               } else {
                   $origin = lc($absolute);
                   ($protocol,$hostname) = ($absolute =~ m{^(https?:)//([^/]+)$});
               }
               if (($secpolicy) && ($secpolicy =~ /\Qframe-ancestors\E([^;]*)(;|$)/)) {
                   my $framepolicy = $1;
                   $framepolicy =~ s/^\s+|\s+$//g;
                   my @policies = split(/\s+/,$framepolicy);
                   if (@policies) {
                       if (grep(/^\Q'none'\E$/,@policies)) {
                           $uselink = 1;
                       } else {
                           $uselink = 1;
                           if ((grep(/^\Q*\E$/,@policies)) || (grep(/^\Q$protocol\E$/,@policies)) ||
                                   (($origin ne '') && (grep(/^\Q$origin\E$/,@policies))) ||
                                   (($ip ne '') && (grep(/^\Q$ip\E$/,@policies)))) {
                               undef($uselink);
                           }
                           if ($uselink) {
                               if (grep(/^\Q'self'\E$/,@policies)) {
                                   if (($origin ne '') && ($remotehost eq $origin)) {
                                       undef($uselink);
                                   }
                               }
                           }
                           if ($uselink) {
                               my @possok;
                               if ($ip ne '') {
                                   push(@possok,$ip);
                               }
                               my $hoststr = '';
                               foreach my $part (reverse(split(/\./,$hostname))) {
                                   if ($hoststr eq '') {
                                       $hoststr = $part;
                                   } else {
                                       $hoststr = "$part.$hoststr";
                                   }
                                   if ($hoststr eq $hostname) {
                                       push(@possok,$hostname);
                                   } else {
                                       push(@possok,"*.$hoststr");
                                   }
                               }
                               if (@possok) {
                                   foreach my $poss (@possok) {
                                       last if (!$uselink);
                                       foreach my $policy (@policies) {
                                           if ($policy =~ m{^(\Q$protocol\E//|)\Q$poss\E(\Q:$port\E|)$}) {
                                               undef($uselink);
                                               last;
                                           }
                                       }
                                   }
                               }
                           }
                       }
                   }
               } elsif ($xframeop ne '') {
                   $uselink = 1;
                   my @policies = split(/\s*,\s*/,$xframeop);
                   if (@policies) {
                       unless (grep(/^deny$/,@policies)) {
                           if ($origin ne '') {
                               if (grep(/^sameorigin$/,@policies)) {
                                   if ($remotehost eq $origin) {
                                       undef($uselink);
                                   }
                               }
                               if ($uselink) {
                                   foreach my $policy (@policies) {
                                       if ($policy =~ /^allow-from\s*(.+)$/) {
                                           my $allowfrom = $1;
                                           if (($allowfrom ne '') && ($allowfrom eq $origin)) {
                                               undef($uselink);
                                               last;
                                           }
                                       }
                                   }
                               }
                           }
                       }
                   }
               }
           }
       }
       if ($nocache) {
           if ($cached) {
               my $devalidate;
               if ($uselink && !$result) {
                   $devalidate = 1;
               } elsif (!$uselink && $result) {
                   $devalidate = 1;
               }
               if ($devalidate) {
                   &Apache::lonnet::devalidate_cache_new('noiframe',$remhost.':'.$remport);
               }
           }
       } else {
           if ($uselink) {
               $result = 1;
           } else {
               $result = 0;
           }
           &Apache::lonnet::do_cache_new('noiframe',$remhost.':'.$remport,$result,3600);
       }
       return $uselink;
   }
   
 1;  1;
 __END__;  __END__;
   
Removed from v.1.1075.2.127.6.1  
changed lines
  Added in v.1.1075.2.151

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