[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.134 and 1.1075.2.148

version 1.1075.2.134, 2019/07/30 11:10:55 version 1.1075.2.148, 2020/10/01 10:27:14
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 427  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 442  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 474  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 485  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 1403  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 3170  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 4595  sub findallcourses { Line 4678  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 4728  sub blockcheck { Line 4811  sub blockcheck {
         # 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 4748  sub blockcheck { Line 4831  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 4761  sub get_blocks { Line 4844  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 4883  sub parse_block_record { Line 4972  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 4904  sub blocking_status { Line 4993  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 4953  sub check_ip_acc { Line 5047  sub check_ip_acc {
         return 1;          return 1;
     }      }
     my $allowed=0;      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 {
           $ip = $ENV{'REMOTE_ADDR'} || $env{'request.host'} || $clientip;
       }
   
     my $name;      my $name;
     foreach my $pattern (split(',',$acc)) {      foreach my $pattern (split(',',$acc)) {
Line 6679  table.LC_prior_tries td { Line 6779  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 7670  ul.LC_funclist li { Line 7771  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 7829  ADDMETA Line 7938  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 7886  function LC_Offload_Now() { Line 8037  function LC_Offload_Now() {
 // ]]>  // ]]>
 </script>  </script>
 OFFLOAD  OFFLOAD
                             }  
                         }                          }
                     }                      }
                 }                  }
Line 8307  sub modal_link { Line 8457  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 14106  defdom (domain for which to retrieve con Line 14255  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 14115  Returns: comma separated list of address Line 14270  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 14156  sub build_recipient_list { Line 14311  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 '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 15279  sub construct_course { Line 15521  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 15518  sub init_user_environment { Line 15765  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 16651  sub symb_to_docspath { Line 16914  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 16670  sub captcha_display { Line 16933  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 16684  sub captcha_response { Line 16947  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 16732  sub get_captcha_config { Line 16995  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 16951  sub des_decrypt { Line 17235  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.134  
changed lines
  Added in v.1.1075.2.148

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