[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.2.7 and 1.1075.2.141.2.4

version 1.1075.2.127.2.7, 2019/02/06 16:10:34 version 1.1075.2.141.2.4, 2020/07/18 19:14:03
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 429  sub studentbrowser_javascript { Line 430  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 444  sub studentbrowser_javascript { Line 445  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 476  ENDRESBRW Line 482  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 487  sub selectstudent_link { Line 493  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 1405  sub help_menu_js { Line 1415  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 2264  sub select_form { Line 2274  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 3168  sub get_assignable_auth { Line 3182  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 4722  sub blockcheck { Line 4809  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) = 
Line 4950  sub check_ip_acc { Line 5037  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=0;      my ($ip,$allowed);
     my $ip=$ENV{'REMOTE_ADDR'} || $clientip || $env{'request.host'};      if (($ENV{'REMOTE_ADDR'} eq '127.0.0.1') ||
           ($ENV{'REMOTE_ADDR'} eq &Apache::lonnet::get_host_ip($Apache::lonnet::perlvar{'lonHostID'}))) {
     my $name;          $ip = $env{'request.host'} || $ENV{'REMOTE_ADDR'} || $clientip;
     foreach my $pattern (split(',',$acc)) {      } else {
         $pattern =~ s/^\s*//;          $ip = $ENV{'REMOTE_ADDR'} || $env{'request.host'} || $clientip;
         $pattern =~ s/\s*$//;  
         if ($pattern =~ /\*$/) {  
             #35.8.*  
             $pattern=~s/\*//;  
             if ($ip =~ /^\Q$pattern\E/) { $allowed=1; }  
         } elsif ($pattern =~ /(\d+\.\d+\.\d+)\.\[(\d+)-(\d+)\]$/) {  
             #35.8.3.[34-56]  
             my $low=$2;  
             my $high=$3;  
             $pattern=$1;  
             if ($ip =~ /^\Q$pattern\E/) {  
                 my $last=(split(/\./,$ip))[3];  
                 if ($last <=$high && $last >=$low) { $allowed=1; }  
             }  
         } elsif ($pattern =~ /^\*/) {  
             #*.msu.edu  
             $pattern=~s/\*//;  
             if (!defined($name)) {  
                 use Socket;  
                 my $netaddr=inet_aton($ip);  
                 ($name)=gethostbyaddr($netaddr,AF_INET);  
             }  
             if ($name =~ /\Q$pattern\E$/i) { $allowed=1; }  
         } elsif ($pattern =~ /\d+\.\d+\.\d+\.\d+/) {  
             #127.0.0.1  
             if ($ip =~ /^\Q$pattern\E/) { $allowed=1; }  
         } else {  
             #some.name.com  
             if (!defined($name)) {  
                 use Socket;  
                 my $netaddr=inet_aton($ip);  
                 ($name)=gethostbyaddr($netaddr,AF_INET);  
             }  
             if ($name =~ /\Q$pattern\E$/i) { $allowed=1; }  
         }  
         if ($allowed) { last; }  
     }  
     return $allowed;  
 }  
   
 sub check_slotip_acc {  
     my ($acc,$clientip)=@_;  
     &Apache::lonxml::debug("acc is $acc");  
     if (!defined($acc) || $acc =~ /^\s*$/ || $acc =~/^\s*no\s*$/i) {  
         return 1;  
     }      }
     my $allowed;  
     my $ip=$ENV{'REMOTE_ADDR'} || $clientip || $env{'request.host'};  
   
     my $name;      my $name;
     my %access = (      my %access = (
Line 5015  sub check_slotip_acc { Line 5055  sub check_slotip_acc {
     foreach my $item (split(',',$acc)) {      foreach my $item (split(',',$acc)) {
         $item =~ s/^\s*//;          $item =~ s/^\s*//;
         $item =~ s/\s*$//;          $item =~ s/\s*$//;
         my $pattern;  
         if ($item =~ /^\!(.+)$/) {          if ($item =~ /^\!(.+)$/) {
             push(@denies,$1);              push(@denies,$1);
         } else {          } else {
             push(@allows,$item);              push(@allows,$item);
         }          }
    }      }
    my $numdenies = scalar(@denies);      my $numdenies = scalar(@denies);
    my $numallows = scalar(@allows);      my $numallows = scalar(@allows);
    my $count = 0;      my $count = 0;
    foreach my $pattern (@denies,@allows) {      foreach my $pattern (@denies,@allows) {
         $count ++;          $count ++;
         my $acctype = 'allowfrom';          my $acctype = 'allowfrom';
         if ($count <= $numdenies) {          if ($count <= $numdenies) {
Line 5473  Inputs: Line 5512  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 5498  sub bodytag { Line 5541  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 5586  sub bodytag { Line 5630  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 5632  sub bodytag { Line 5676  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 6156  td.LC_menubuttons_text { Line 6202  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 6746  table.LC_prior_tries td { Line 6797  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 6828  table.LC_data_table tr > td.LC_docs_entr Line 6880  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 7736  ul.LC_funclist li { Line 7789  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 7895  ADDMETA Line 7956  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;
                     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)) {                          }
                                 my $numsec = 5;                      }
                                 my $timeout = $numsec * 1000;                      unless ($offload) {
                                 my ($newurl,$locknum,%locks,$msg);                          if (ref($domdefs{'offloadoth'}) eq 'HASH') {
                                 if ($env{'request.role.adv'}) {                              if ($domdefs{'offloadoth'}{$lonhost}) {
                                     ($locknum,%locks) = &Apache::lonnet::get_locks();                                  if (($env{'user.domain'} ne '') && ($env{'user.domain'} ne $dom_in_use) &&
                                 }                                      (!(($env{'user.name'} eq 'public') && ($env{'user.domain'} eq 'public')))) {
                                 my $disable_submit = 0;                                      unless (&Apache::lonnet::shared_institution($env{'user.domain'})) {
                                 if ($requrl =~ /$LONCAPA::assess_re/) {                                          $offload = 1;
                                     $disable_submit = 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) && ($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 7952  function LC_Offload_Now() { Line 8055  function LC_Offload_Now() {
 // ]]>  // ]]>
 </script>  </script>
 OFFLOAD  OFFLOAD
                             }  
                         }                          }
                     }                      }
                 }                  }
Line 8168  $args - additional optional args support Line 8270  $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 8369  sub modal_link { Line 8475  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 8473  sub end_togglebox { Line 8578  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 8487  sub LCprogressbar_script { Line 8593  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 8513  my $LCidcnt; Line 8641  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 12188  sub process_decompression { Line 12333  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 12777  sub process_extracted_files { Line 12921  sub process_extracted_files {
                             $newseqid{$i} = $newidx;                              $newseqid{$i} = $newidx;
                             unless ($errtext) {                              unless ($errtext) {
                                 $result .=  '<li>'.&mt('Folder: [_1] added to course',                                  $result .=  '<li>'.&mt('Folder: [_1] added to course',
                                                        &HTML::Entities::encode($docstitle,'<>&"')).                                                         &HTML::Entities::encode($docstitle,'<>&"'))..
                                             '</li>'."\n";                                              '</li>'."\n";
                             }                              }
                         }                          }
Line 12802  sub process_extracted_files { Line 12946  sub process_extracted_files {
                                             $fetch =~ s/^\Q$prefix$dir\E//;                                              $fetch =~ s/^\Q$prefix$dir\E//;
                                             $prompttofetch{$fetch} = 1;                                              $prompttofetch{$fetch} = 1;
                                         }                                          }
                                     }                                     }
                                 }                                  }
                                 $LONCAPA::map::resources[$newidx]=                                  $LONCAPA::map::resources[$newidx]=
                                     $docstitle.':'.$url.':false:normal:res';                                      $docstitle.':'.$url.':false:normal:res';
Line 12902  sub process_extracted_files { Line 13046  sub process_extracted_files {
                                 $result .= '<li>'.&mt('[_1] included as a dependency',                                  $result .= '<li>'.&mt('[_1] included as a dependency',
                                                       &HTML::Entities::encode($showpath,'<>&"')).                                                        &HTML::Entities::encode($showpath,'<>&"')).
                                            '</li>'."\n";                                             '</li>'."\n";
                             }                                  unless ($ishome) {
                             unless ($ishome) {                                      my $fetch = "$fullpath/$title";
                                 my $fetch = "$fullpath/$title";                                      $fetch =~ s/^\Q$prefix$dir\E//;
                                 $fetch =~ s/^\Q$prefix$dir\E//;                                      $prompttofetch{$fetch} = 1;
                                 $prompttofetch{$fetch} = 1;                                  }
                             }                              }
                         }                          }
                     }                      }
Line 13193  sub upfile_store { Line 13337  sub upfile_store {
     $env{'form.upfile'}=~s/\n+$//gs;      $env{'form.upfile'}=~s/\n+$//gs;
   
     my $datatoken = &valid_datatoken($env{'user.name'}.'_'.$env{'user.domain'}.      my $datatoken = &valid_datatoken($env{'user.name'}.'_'.$env{'user.domain'}.
                              '_enroll_'.$env{'request.course.id'}.'_'.                                       '_enroll_'.$env{'request.course.id'}.'_'.
                                      time.'_'.$$);                                       time.'_'.$$);
     return if ($datatoken eq '');      return if ($datatoken eq '');
   
     {      {
         my $datafile = $r->dir_config('lonDaemons').          my $datafile = $r->dir_config('lonDaemons').
                            '/tmp/'.$datatoken.'.tmp';                             '/tmp/'.$datatoken.'.tmp';
Line 14134  $requdom domain of requester (if mailing Line 14279  $requdom domain of requester (if mailing
   
 $reqemail e-mail address 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 14276  sub build_recipient_list { Line 14420  sub build_recipient_list {
     } elsif ($origmail ne '') {      } elsif ($origmail ne '') {
         $lastresort = $origmail;          $lastresort = $origmail;
     }      }
   
     if (($mailing eq 'helpdeskmail') && ($lastresort ne '')) {      if (($mailing eq 'helpdeskmail') && ($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'};
Line 14462  jsarray (reference to array of categorie Line 14605  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 14469  Side effects: populates trails and allit Line 14614  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 14495  sub extract_categories { Line 14640  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 14538  Side effects: populates trails and allit Line 14686  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 14565  sub recurse_categories { Line 14713  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 14606  sub assign_categories_table { Line 14759  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 15386  sub construct_course { Line 15539  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 15625  sub init_user_environment { Line 15783  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 15660  sub init_user_environment { Line 15834  sub init_user_environment {
   
     my %userenv = &Apache::lonnet::dump('environment',$domain,$username);      my %userenv = &Apache::lonnet::dump('environment',$domain,$username);
     my ($tmp) = keys(%userenv);      my ($tmp) = keys(%userenv);
     if ($tmp =~ /^(con_lost|error|no_such_host)/i) {      if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
       } else {
  undef(%userenv);   undef(%userenv);
     }      }
     if (($userenv{'interface'}) && (!$form->{'interface'})) {      if (($userenv{'interface'}) && (!$form->{'interface'})) {
Line 16757  sub symb_to_docspath { Line 16932  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 16776  sub captcha_display { Line 16951  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 16790  sub captcha_response { Line 16965  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 16838  sub get_captcha_config { Line 17013  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 17113  sub make_short_symbs { Line 17309  sub make_short_symbs {
                         push(@errors,&mt('error: could not store unique six character URLs'));                          push(@errors,&mt('error: could not store unique six character URLs'));
                     }                      }
                 }                  }
               }
         }          }
     }      }
     return ($numnew,\@errors);      return ($numnew,\@errors);
Line 17174  sub shorten_symbs { Line 17371  sub shorten_symbs {
         } else {          } else {
             foreach my $key (keys(%collisions)) {              foreach my $key (keys(%collisions)) {
                 $failed->{$key} = 1;                  $failed->{$key} = 1;
                   $failed->{$key} = 1;
             }              }
         }          }
     }      }
     return $init;      return $init;
 }  }
   
   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.2.7  
changed lines
  Added in v.1.1075.2.141.2.4

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