[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.149 and 1.1075.2.161.2.1

version 1.1075.2.149, 2020/11/12 01:18:26 version 1.1075.2.161.2.1, 2021/12/30 21:11:56
Line 83  use Crypt::DES; Line 83  use Crypt::DES;
 use DynaLoader; # for Crypt::DES version  use DynaLoader; # for Crypt::DES version
 use File::Copy();  use File::Copy();
 use File::Path();  use File::Path();
   use String::CRC32();
   use Short::URL();
   
 # ---------------------------------------------- Designs  # ---------------------------------------------- Designs
 use vars qw(%defaultdesign);  use vars qw(%defaultdesign);
Line 1378  sub help_open_menu { Line 1380  sub help_open_menu {
 }  }
   
 sub top_nav_help {  sub top_nav_help {
     my ($text) = @_;      my ($text,$linkattr) = @_;
     $text = &mt($text);      $text = &mt($text);
     my $stay_on_page;      my $stay_on_page;
     unless ($env{'environment.remote'} eq 'on') {      unless ($env{'environment.remote'} eq 'on') {
Line 1394  sub top_nav_help { Line 1396  sub top_nav_help {
     if ($link) {      if ($link) {
         return <<"END";          return <<"END";
 $banner_link  $banner_link
 <a href="$link" title="$title">$text</a>  <a href="$link" title="$title" $linkattr>$text</a>
 END  END
     } else {      } else {
         return '&nbsp;'.$text.'&nbsp;';          return '&nbsp;'.$text.'&nbsp;';
Line 3127  sub authform_filesystem { Line 3129  sub authform_filesystem {
                     $fsyscheck.' onchange="'.$jscall.'" onclick="'.                      $fsyscheck.' onchange="'.$jscall.'" onclick="'.
                     $jscall.'"'.$disabled.' />';                      $jscall.'"'.$disabled.' />';
     }      }
     $autharg = '<input type="text" size="10" name="fsysarg" value=""'.      $autharg = '<input type="password" size="10" name="fsysarg" value=""'.
                ' onchange="'.$jscall.'"'.$disabled.' />';                 ' onchange="'.$jscall.'"'.$disabled.' />';
     $result = &mt      $result = &mt
         ('[_1] Filesystem Authenticated (with initial password [_2])',          ('[_1] Filesystem Authenticated (with initial password [_2])',
          '<label><input type="radio" name="login" value="fsys" '.           '<label>'.$authtype,'</label>'.$autharg);
          $fsyscheck.'onchange="'.$jscall.'" onclick="'.$jscall.'"'.$disabled.' />',  
          '</label><input type="password" size="10" name="fsysarg" value="" '.  
                   'onchange="'.$jscall.'"'.$disabled.' />');  
     return $result;      return $result;
 }  }
   
Line 4731  sub findallcourses { Line 4730  sub findallcourses {
 ###############################################  ###############################################
   
 sub blockcheck {  sub blockcheck {
     my ($setters,$activity,$uname,$udom,$url,$is_course,$symb,$caller) = @_;      my ($setters,$activity,$clientip,$uname,$udom,$url,$is_course,$symb,$caller) = @_;
   
       unless ($activity eq 'docs') {
           my ($has_evb,$check_ipaccess);
           my $dom = $env{'user.domain'};
           if ($env{'request.course.id'}) {
               my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
               my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
               my $checkrole = "cm./$cdom/$cnum";
               my $sec = $env{'request.course.sec'};
               if ($sec ne '') {
                   $checkrole .= "/$sec";
               }
               if ((&Apache::lonnet::allowed('evb',undef,undef,$checkrole)) &&
                   ($env{'request.role'} !~ /^st/)) {
                   $has_evb = 1;
               }
               unless ($has_evb) {
                   if (($activity eq 'printout') || ($activity eq 'grades') || ($activity eq 'search') ||
                       ($activity eq 'boards') || ($activity eq 'groups') || ($activity eq 'chat')) {
                       if ($udom eq $cdom) {
                           $check_ipaccess = 1;
                       }
                   }
               }
           }
           unless ($has_evb || $check_ipaccess) {
               my @machinedoms = &Apache::lonnet::current_machine_domains();
               if (($dom eq 'public') && ($activity eq 'port')) {
                   $dom = $udom;
               }
               if (($dom ne '') && (grep(/^\Q$dom\E$/,@machinedoms))) {
                   $check_ipaccess = 1;
               } else {
                   my $lonhost = $Apache::lonnet::perlvar{'lonHostID'};
                   my $internet_names = &Apache::lonnet::get_internet_names($lonhost);
                   my $prim = &Apache::lonnet::domain($dom,'primary');
                   my $intdom = &Apache::lonnet::internet_dom($prim);
                   if (($intdom ne '') && (ref($internet_names) eq 'ARRAY')) {
                       if (grep(/^\Q$intdom\E$/,@{$internet_names})) {
                           $check_ipaccess = 1;
                       }
                   }
               }
           }
           if ($check_ipaccess) {
               my ($ipaccessref,$cached)=&Apache::lonnet::is_cached_new('ipaccess',$dom);
               unless (defined($cached)) {
                   my %domconfig =
                       &Apache::lonnet::get_dom('configuration',['ipaccess'],$dom);
                   $ipaccessref = &Apache::lonnet::do_cache_new('ipaccess',$dom,$domconfig{'ipaccess'},1800);
               }
               if ((ref($ipaccessref) eq 'HASH') && ($clientip)) {
                   foreach my $id (keys(%{$ipaccessref})) {
                       if (ref($ipaccessref->{$id}) eq 'HASH') {
                           my $range = $ipaccessref->{$id}->{'ip'};
                           if ($range) {
                               if (&Apache::lonnet::ip_match($clientip,$range)) {
                                   if (ref($ipaccessref->{$id}->{'commblocks'}) eq 'HASH') {
                                       if ($ipaccessref->{$id}->{'commblocks'}->{$activity} eq 'on') {
                                           return ('','','',$id,$dom);
                                           last;
                                       }
                                   }
                               }
                           }
                       }
                   }
               }
           }
       }
     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))) {
Line 4748  sub blockcheck { Line 4816  sub blockcheck {
     my $startblock = 0;      my $startblock = 0;
     my $endblock = 0;      my $endblock = 0;
     my $triggerblock = '';      my $triggerblock = '';
     my %live_courses = &findallcourses(undef,$uname,$udom);      my %live_courses;
       unless (($activity eq 'wishlist') || ($activity eq 'annotate')) {
           %live_courses = &findallcourses(undef,$uname,$udom);
       }
   
     # If uname is for a user, and activity is course-specific, i.e.,      # If uname is for a user, and activity is course-specific, i.e.,
     # boards, chat or groups, check for blocking in current course only.      # boards, chat or groups, check for blocking in current course only.
   
     if (($activity eq 'boards' || $activity eq 'chat' ||      if (($activity eq 'boards' || $activity eq 'chat' ||
          $activity eq 'groups' || $activity eq 'printout') &&           $activity eq 'groups' || $activity eq 'printout' ||
         ($env{'request.course.id'})) {           $activity eq 'search' || $activity eq 'reinit' ||
            $activity eq 'alert') && ($env{'request.course.id'})) {
         foreach my $key (keys(%live_courses)) {          foreach my $key (keys(%live_courses)) {
             if ($key ne $env{'request.course.id'}) {              if ($key ne $env{'request.course.id'}) {
                 delete($live_courses{$key});                  delete($live_courses{$key});
Line 4955  sub get_blocks { Line 5027  sub get_blocks {
                 my $end = $start + $env{'course.'.$cdom.'_'.$cnum.'.timerinterval.'.$timersymb};                   my $end = $start + $env{'course.'.$cdom.'_'.$cnum.'.timerinterval.'.$timersymb}; 
                 if ($start && $end) {                  if ($start && $end) {
                     if (($start <= time) && ($end >= time)) {                      if (($start <= time) && ($end >= time)) {
                         unless (grep(/^\Q$block\E$/,@blockers)) {                          if (ref($commblocks{$block}) eq 'HASH') {
                             push(@blockers,$block);                              if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
                             $triggered{$block} = {                                  if ($commblocks{$block}{'blocks'}{$activity} eq 'on') {
                                                    start => $start,                                      unless(grep(/^\Q$block\E$/,@blockers)) {
                                                    end   => $end,                                          push(@blockers,$block);
                                                    type  => $type,                                          $triggered{$block} = {
                                                  };                                                                 start => $start,
                                                                  end   => $end,
                                                                  type  => $type,
                                                                };
                                       }
                                   }
                               }
                         }                          }
                     }                      }
                 }                  }
Line 5025  sub parse_block_record { Line 5103  sub parse_block_record {
 }  }
   
 sub blocking_status {  sub blocking_status {
     my ($activity,$uname,$udom,$url,$is_course,$symb,$caller) = @_;      my ($activity,$clientip,$uname,$udom,$url,$is_course,$symb,$caller) = @_;
     my %setters;      my %setters;
   
 # check for active blocking  # check for active blocking
     my ($startblock,$endblock,$triggerblock) =       if ($clientip eq '') {
         &blockcheck(\%setters,$activity,$uname,$udom,$url,$is_course,$symb,$caller);          $clientip = &Apache::lonnet::get_requestor_ip();
       }
       my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) = 
           &blockcheck(\%setters,$activity,$clientip,$uname,$udom,$url,$is_course,$symb,$caller);
     my $blocked = 0;      my $blocked = 0;
     if ($startblock && $endblock) {      if (($startblock && $endblock) || ($by_ip)) {
         $blocked = 1;          $blocked = 1;
     }      }
   
Line 5041  sub blocking_status { Line 5122  sub blocking_status {
   
 # build a link to a popup window containing the details  # build a link to a popup window containing the details
     my $querystring  = "?activity=$activity";      my $querystring  = "?activity=$activity";
 # $uname and $udom decide whose portfolio the user is trying to look at  # $uname and $udom decide whose portfolio (or information page) the user is trying to look at
     if (($activity eq 'port') || ($activity eq 'passwd')) {      if (($activity eq 'port') || ($activity eq 'about') || ($activity eq 'passwd')) {
         $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') {
Line 5076  END_MYBLOCK Line 5157  END_MYBLOCK
         $text = &mt('Printing Blocked');          $text = &mt('Printing Blocked');
     } elsif ($activity eq 'passwd') {      } elsif ($activity eq 'passwd') {
         $text = &mt('Password Changing Blocked');          $text = &mt('Password Changing Blocked');
       } elsif ($activity eq 'grades') {
           $text = &mt('Gradebook Blocked');
       } elsif ($activity eq 'search') {
           $text = &mt('Search Blocked');
       } elsif ($activity eq 'alert') {
           $text = &mt('Checking Critical Messages Blocked');
       } elsif ($activity eq 'reinit') {
           $text = &mt('Checking Course Update Blocked');
       } elsif ($activity eq 'about') {
           $text = &mt('Access to User Information Pages Blocked');
       } elsif ($activity eq 'wishlist') {
           $text = &mt('Access to Stored Links Blocked');
       } elsif ($activity eq 'annotate') {
           $text = &mt('Access to Annotations Blocked');
     }      }
     $output .= <<"END_BLOCK";      $output .= <<"END_BLOCK";
 <div class='$class'>  <div class='$class'>
Line 5105  sub check_ip_acc { Line 5200  sub check_ip_acc {
         ($ENV{'REMOTE_ADDR'} eq &Apache::lonnet::get_host_ip($Apache::lonnet::perlvar{'lonHostID'}))) {          ($ENV{'REMOTE_ADDR'} eq &Apache::lonnet::get_host_ip($Apache::lonnet::perlvar{'lonHostID'}))) {
         $ip = $env{'request.host'} || $ENV{'REMOTE_ADDR'} || $clientip;          $ip = $env{'request.host'} || $ENV{'REMOTE_ADDR'} || $clientip;
     } else {      } else {
         $ip = $ENV{'REMOTE_ADDR'} || $env{'request.host'} || $clientip;          my $remote_ip = &Apache::lonnet::get_requestor_ip();
           $ip = $remote_ip || $env{'request.host'} || $clientip;
     }      }
   
     my $name;      my $name;
     foreach my $pattern (split(',',$acc)) {      my %access = (
         $pattern =~ s/^\s*//;                       allowfrom => 1,
         $pattern =~ s/\s*$//;                       denyfrom  => 0,
                    );
       my @allows;
       my @denies;
       foreach my $item (split(',',$acc)) {
           $item =~ s/^\s*//;
           $item =~ s/\s*$//;
           if ($item =~ /^\!(.+)$/) {
               push(@denies,$1);
           } else {
               push(@allows,$item);
           }
       }
       my $numdenies = scalar(@denies);
       my $numallows = scalar(@allows);
       my $count = 0;
       foreach my $pattern (@denies,@allows) {
           $count ++;
           my $acctype = 'allowfrom';
           if ($count <= $numdenies) {
               $acctype = 'denyfrom';
           }
         if ($pattern =~ /\*$/) {          if ($pattern =~ /\*$/) {
             #35.8.*              #35.8.*
             $pattern=~s/\*//;              $pattern=~s/\*//;
             if ($ip =~ /^\Q$pattern\E/) { $allowed=1; }              if ($ip =~ /^\Q$pattern\E/) { $allowed=$access{$acctype}; }
         } elsif ($pattern =~ /(\d+\.\d+\.\d+)\.\[(\d+)-(\d+)\]$/) {          } elsif ($pattern =~ /(\d+\.\d+\.\d+)\.\[(\d+)-(\d+)\]$/) {
             #35.8.3.[34-56]              #35.8.3.[34-56]
             my $low=$2;              my $low=$2;
Line 5123  sub check_ip_acc { Line 5240  sub check_ip_acc {
             $pattern=$1;              $pattern=$1;
             if ($ip =~ /^\Q$pattern\E/) {              if ($ip =~ /^\Q$pattern\E/) {
                 my $last=(split(/\./,$ip))[3];                  my $last=(split(/\./,$ip))[3];
                 if ($last <=$high && $last >=$low) { $allowed=1; }                  if ($last <=$high && $last >=$low) { $allowed=$access{$acctype}; }
             }              }
         } elsif ($pattern =~ /^\*/) {          } elsif ($pattern =~ /^\*/) {
             #*.msu.edu              #*.msu.edu
Line 5133  sub check_ip_acc { Line 5250  sub check_ip_acc {
                 my $netaddr=inet_aton($ip);                  my $netaddr=inet_aton($ip);
                 ($name)=gethostbyaddr($netaddr,AF_INET);                  ($name)=gethostbyaddr($netaddr,AF_INET);
             }              }
             if ($name =~ /\Q$pattern\E$/i) { $allowed=1; }              if ($name =~ /\Q$pattern\E$/i) { $allowed=$access{$acctype}; }
         } elsif ($pattern =~ /\d+\.\d+\.\d+\.\d+/) {          } elsif ($pattern =~ /\d+\.\d+\.\d+\.\d+/) {
             #127.0.0.1              #127.0.0.1
             if ($ip =~ /^\Q$pattern\E/) { $allowed=1; }              if ($ip =~ /^\Q$pattern\E/) { $allowed=$access{$acctype}; }
         } else {          } else {
             #some.name.com              #some.name.com
             if (!defined($name)) {              if (!defined($name)) {
Line 5144  sub check_ip_acc { Line 5261  sub check_ip_acc {
                 my $netaddr=inet_aton($ip);                  my $netaddr=inet_aton($ip);
                 ($name)=gethostbyaddr($netaddr,AF_INET);                  ($name)=gethostbyaddr($netaddr,AF_INET);
             }              }
             if ($name =~ /\Q$pattern\E$/i) { $allowed=1; }              if ($name =~ /\Q$pattern\E$/i) { $allowed=$access{$acctype}; }
           }
           if ($allowed =~ /^(0|1)$/) { last; }
       }
       if ($allowed eq '') {
           if ($numdenies && !$numallows) {
               $allowed = 1;
           } else {
               $allowed = 0;
         }          }
         if ($allowed) { last; }  
     }      }
     return $allowed;      return $allowed;
 }  }
Line 5227  sub get_domainconf { Line 5351  sub get_domainconf {
                                     }                                      }
                                 }                                  }
                             }                              }
                           } elsif ($key eq 'saml') {
                               if (ref($domconfig{'login'}{$key}) eq 'HASH') {
                                   foreach my $host (keys(%{$domconfig{'login'}{$key}})) {
                                       if (ref($domconfig{'login'}{$key}{$host}) eq 'HASH') {
                                           $designhash{$udom.'.login.'.$key.'_'.$host} = 1;
                                           foreach my $item ('text','img','alt','url','title','notsso') {
                                               $designhash{$udom.'.login.'.$key.'_'.$item.'_'.$host} = $domconfig{'login'}{$key}{$host}{$item};
                                           }
                                       }
                                   }
                               }
                         } else {                          } else {
                             foreach my $img (keys(%{$domconfig{'login'}{$key}})) {                              foreach my $img (keys(%{$domconfig{'login'}{$key}})) {
                                 $designhash{$udom.'.login.'.$key.'_'.$img} =                                   $designhash{$udom.'.login.'.$key.'_'.$img} = 
Line 5556  Inputs: Line 5691  Inputs:
             inlineremote items to be added in "Functions" menu below              inlineremote items to be added in "Functions" menu below
             breadcrumbs.              breadcrumbs.
   
   =item * $ltiscope, optional argument, will be one of: resource, map or
               course, if LON-CAPA is in LTI Provider context. Value is
               the scope of use, i.e., launch was for access to a single, a map
               or the entire course.
   
   =item * $ltiuri, optional argument, if LON-CAPA is in LTI Provider
               context, this will contain the URL for the landing item in
               the course, after launch from an LTI Consumer
   
   =item * $ltimenu, optional argument, if LON-CAPA is in LTI Provider
               context, this will contain a reference to hash of items
               to be included in the page header and/or inline menu.
   
 =back  =back
   
 Returns: A uniform header for LON-CAPA web pages.    Returns: A uniform header for LON-CAPA web pages.  
Line 5567  other decorations will be returned. Line 5715  other decorations will be returned.
   
 sub bodytag {  sub bodytag {
     my ($title,$function,$addentries,$bodyonly,$domain,$forcereg,      my ($title,$function,$addentries,$bodyonly,$domain,$forcereg,
         $no_nav_bar,$bgcolor,$no_inline_link,$args,$advtoolsref)=@_;          $no_nav_bar,$bgcolor,$no_inline_link,$args,$advtoolsref,
           $ltiscope,$ltiuri,$ltimenu,$menucoll,$menuref)=@_;
   
     my $public;      my $public;
     if ((($env{'user.name'} eq 'public') && ($env{'user.domain'} eq 'public'))      if ((($env{'user.name'} eq 'public') && ($env{'user.domain'} eq 'public'))
Line 5596  sub bodytag { Line 5745  sub bodytag {
     if ($realm) {      if ($realm) {
         $realm = '/'.$realm;          $realm = '/'.$realm;
     }      }
     if ($role  eq 'ca') {      if ($role eq 'ca') {
         my ($rdom,$rname) = ($realm =~ m{^/($match_domain)/($match_username)$});          my ($rdom,$rname) = ($realm =~ m{^/($match_domain)/($match_username)$});
         $realm = &plainname($rname,$rdom);          $realm = &plainname($rname,$rdom);
     }       } 
 # realm  # realm
       my ($cid,$sec);
     if ($env{'request.course.id'}) {      if ($env{'request.course.id'}) {
           $cid = $env{'request.course.id'};
           if ($env{'request.course.sec'}) {
               $sec = $env{'request.course.sec'};
           }
       } elsif ($realm =~ m{^/($match_domain)/($match_courseid)(?:|/(\w+))$}) {
           if (&Apache::lonnet::is_course($1,$2)) {
               $cid = $1.'_'.$2;
               $sec = $3;
           }
       }
       if ($cid) {
         if ($env{'request.role'} !~ /^cr/) {          if ($env{'request.role'} !~ /^cr/) {
             $role = &Apache::lonnet::plaintext($role,&course_type());              $role = &Apache::lonnet::plaintext($role,&course_type());
         } elsif ($role =~ m{^cr/($match_domain)/\1-domainconfig/(\w+)$}) {          } elsif ($role =~ m{^cr/($match_domain)/\1-domainconfig/(\w+)$}) {
Line 5613  sub bodytag { Line 5774  sub bodytag {
         } else {          } else {
             $role = (split(/\//,$role,4))[-1];              $role = (split(/\//,$role,4))[-1];
         }          }
         if ($env{'request.course.sec'}) {          if ($sec) {
             $role .= ('&nbsp;'x2).'-&nbsp;'.&mt('section:').'&nbsp;'.$env{'request.course.sec'};              $role .= ('&nbsp;'x2).'-&nbsp;'.&mt('section:').'&nbsp;'.$sec;
         }             }   
  $realm = $env{'course.'.$env{'request.course.id'}.'.description'};   $realm = $env{'course.'.$cid.'.description'};
     } else {      } else {
         $role = &Apache::lonnet::plaintext($role);          $role = &Apache::lonnet::plaintext($role);
     }      }
Line 5638  sub bodytag { Line 5799  sub bodytag {
     if ($public) {      if ($public) {
  undef($role);   undef($role);
     }      }
       
       my $showcrstitle = 1;
       if (($cid) && ($env{'request.lti.login'})) {
           if (ref($ltimenu) eq 'HASH') {
               unless ($ltimenu->{'role'}) {
                   undef($role);
               }
               unless ($ltimenu->{'coursetitle'}) {
                   $realm='&nbsp;';
                   $showcrstitle = 0;
               }
           }
       } elsif (($cid) && ($menucoll)) {
           if (ref($menuref) eq 'HASH') {
               unless ($menuref->{'role'}) {
                   undef($role);
               }
               unless ($menuref->{'crs'}) {
                   $realm='&nbsp;';
                   $showcrstitle = 0;
               }
           }
       }
   
     my $titleinfo = '<h1>'.$title.'</h1>';      my $titleinfo = '<h1>'.$title.'</h1>';
     #      #
     # Extra info if you are the DC      # Extra info if you are the DC
     my $dc_info = '';      my $dc_info = '';
     if ($env{'user.adv'} && exists($env{'user.role.dc./'.      if (($env{'user.adv'}) && ($env{'request.course.id'}) && $showcrstitle &&
                         $env{'course.'.$env{'request.course.id'}.          (exists($env{'user.role.dc./'.$env{'course.'.$cid.'.domain'}.'/'}))) {
                                  '.domain'}.'/'})) {  
         my $cid = $env{'request.course.id'};  
         $dc_info = $cid.' '.$env{'course.'.$cid.'.internal.coursecode'};          $dc_info = $cid.' '.$env{'course.'.$cid.'.internal.coursecode'};
         $dc_info =~ s/\s+$//;          $dc_info =~ s/\s+$//;
     }      }
   
       my $crstype;
       if ($cid) {
           $crstype = $env{'course.'.$cid.'.type'};
       } elsif ($args->{'crstype'}) {
           $crstype = $args->{'crstype'};
       }
   
     $role = '<span class="LC_nobreak">('.$role.')</span>' if ($role && !$env{'browser.mobile'});      $role = '<span class="LC_nobreak">('.$role.')</span>' if ($role && !$env{'browser.mobile'});
   
     if ($env{'request.state'} eq 'construct') { $forcereg=1; }      if ($env{'request.state'} eq 'construct') { $forcereg=1; }
Line 5678  sub bodytag { Line 5867  sub bodytag {
         $bodytag .= Apache::lonhtmlcommon::scripttag(          $bodytag .= Apache::lonhtmlcommon::scripttag(
             Apache::lonmenu::utilityfunctions($httphost), 'start');              Apache::lonmenu::utilityfunctions($httphost), 'start');
   
         my ($left,$right) = Apache::lonmenu::primary_menu();          unless ($args->{'no_primary_menu'}) {
               my ($left,$right) = Apache::lonmenu::primary_menu($args->{'links_disabled'});
   
         if ($env{'request.noversionuri'} =~ m{^/res/adm/pages/}) {              if ($env{'request.noversionuri'} =~ m{^/res/adm/pages/}) {
             if ($dc_info) {                  if ($dc_info) {
                  $dc_info = qq|<span class="LC_cusr_subheading">$dc_info</span>|;                      $dc_info = qq|<span class="LC_cusr_subheading">$dc_info</span>|;
                   }
                   $bodytag .= qq|<div id="LC_nav_bar">$left $role<br />
                                  <em>$realm</em> $dc_info</div>|;
                   return $bodytag;
             }              }
             $bodytag .= qq|<div id="LC_nav_bar">$left $role<br />  
                            <em>$realm</em> $dc_info</div>|;  
             return $bodytag;  
         }  
   
         unless ($env{'request.symb'} =~ m/\.page___\d+___/) {              unless ($env{'request.symb'} =~ m/\.page___\d+___/) {
             $bodytag .= qq|<div id="LC_nav_bar">$left $role</div>|;                  $bodytag .= qq|<div id="LC_nav_bar">$left $role</div>|;
         }              }
   
         $bodytag .= $right;              $bodytag .= $right;
   
         if ($dc_info) {              if ($dc_info) {
             $dc_info = &dc_courseid_toggle($dc_info);                  $dc_info = &dc_courseid_toggle($dc_info);
               }
               $bodytag .= qq|<div id="LC_realm">$realm $dc_info</div>|;
         }          }
         $bodytag .= qq|<div id="LC_realm">$realm $dc_info</div>|;  
   
         #if directed to not display the secondary menu, don't.          #if directed to not display the secondary menu, don't.
         if ($args->{'no_secondary_menu'}) {          if ($args->{'no_secondary_menu'}) {
Line 5706  sub bodytag { Line 5897  sub bodytag {
         }          }
         #don't show menus for public users          #don't show menus for public users
         if (!$public){          if (!$public){
             $bodytag .= Apache::lonmenu::secondary_menu($httphost);              unless ($args->{'no_inline_menu'}) {
                   $bodytag .= Apache::lonmenu::secondary_menu($httphost,$ltiscope,$ltimenu,
                                                               $args->{'no_primary_menu'},
                                                               $menucoll,$menuref,
                                                               $args->{'links_disabled'});
               }
             $bodytag .= Apache::lonmenu::serverform();              $bodytag .= Apache::lonmenu::serverform();
             $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'},'','',$hostname);                                  $args->{'bread_crumbs'},'','',$hostname,$ltiscope,$ltiuri);
             } 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});                                                              $hostname,$ltiscope,$ltiuri);
             } else {              } else {
                 my $forbodytag;                  my $forbodytag;
                 &Apache::lonmenu::prepare_functions($env{'request.noversionuri'},                  &Apache::lonmenu::prepare_functions($env{'request.noversionuri'},
Line 7824  ul.LC_funclist li { Line 8020  ul.LC_funclist li {
  cursor:pointer;   cursor:pointer;
 }  }
   
   .LCisDisabled {
     cursor: not-allowed;
     opacity: 0.5;
   }
   
   a[aria-disabled="true"] {
     color: currentColor;
     display: inline-block;  /* For IE11/ MS Edge bug */
     pointer-events: none;
     text-decoration: none;
   }
   
 pre.LC_wordwrap {  pre.LC_wordwrap {
   white-space: pre-wrap;    white-space: pre-wrap;
   white-space: -moz-pre-wrap;    white-space: -moz-pre-wrap;
Line 7992  ADDMETA Line 8200  ADDMETA
                 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 $lonhost = $Apache::lonnet::perlvar{'lonHostID'};
                     my $offload;                      my ($offload,$offloadoth);
                     if (ref($domdefs{'offloadnow'}) eq 'HASH') {                      if (ref($domdefs{'offloadnow'}) eq 'HASH') {
                         if ($domdefs{'offloadnow'}{$lonhost}) {                          if ($domdefs{'offloadnow'}{$lonhost}) {
                             $offload = 1;                              $offload = 1;
                               if (($env{'user.domain'} ne '') && ($env{'user.domain'} ne $dom_in_use) &&
                                   (!(($env{'user.name'} eq 'public') && ($env{'user.domain'} eq 'public')))) {
                                   unless (&Apache::lonnet::shared_institution($env{'user.domain'})) {
                                       $offloadoth = 1;
                                       $dom_in_use = $env{'user.domain'};
                                   }
                               }
                         }                          }
                     }                      }
                     unless ($offload) {                      unless ($offload) {
Line 8005  ADDMETA Line 8220  ADDMETA
                                     (!(($env{'user.name'} eq 'public') && ($env{'user.domain'} eq 'public')))) {                                      (!(($env{'user.name'} eq 'public') && ($env{'user.domain'} eq 'public')))) {
                                     unless (&Apache::lonnet::shared_institution($env{'user.domain'})) {                                      unless (&Apache::lonnet::shared_institution($env{'user.domain'})) {
                                         $offload = 1;                                          $offload = 1;
                                           $offloadoth = 1;
                                         $dom_in_use = $env{'user.domain'};                                          $dom_in_use = $env{'user.domain'};
                                     }                                      }
                                 }                                  }
Line 8012  ADDMETA Line 8228  ADDMETA
                         }                          }
                     }                      }
                     if ($offload) {                      if ($offload) {
                         my $newserver = &Apache::lonnet::spareserver(30000,undef,1,$dom_in_use);                          my $newserver = &Apache::lonnet::spareserver(undef,30000,undef,1,$dom_in_use);
                           if (($newserver eq '') && ($offloadoth)) {
                               my @domains = &Apache::lonnet::current_machine_domains();
                               if (($dom_in_use ne '') && (!grep(/^\Q$dom_in_use\E$/,@domains))) {
                                   ($newserver) = &Apache::lonnet::choose_server($dom_in_use);
                               }
                           }
                         if (($newserver) && ($newserver ne $lonhost)) {                          if (($newserver) && ($newserver ne $lonhost)) {
                             my $numsec = 5;                              my $numsec = 5;
                             my $timeout = $numsec * 1000;                              my $timeout = $numsec * 1000;
Line 8026  ADDMETA Line 8248  ADDMETA
                             }                              }
                             if ($locknum) {                              if ($locknum) {
                                 my @lockinfo = sort(values(%locks));                                  my @lockinfo = sort(values(%locks));
                                 $msg = &mt('Once the following tasks are complete: ')."\n".                                  $msg = &mt('Once the following tasks are complete:')." \n".
                                        join(", ",sort(values(%locks)))."\n";                                         join(", ",sort(values(%locks)))."\n";
                                 if (&show_course()) {                                  if (&show_course()) {
                                     $msg .= &mt('your session will be transferred to a different server, after you click "Courses".');                                      $msg .= &mt('your session will be transferred to a different server, after you click "Courses".');
Line 8188  sub print_suppression { Line 8410  sub print_suppression {
         }          }
         my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};          my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
         my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};          my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
         my $blocked = &blocking_status('printout',$cnum,$cdom,undef,1);          my $clientip = &Apache::lonnet::get_requestor_ip();
           my $blocked = &blocking_status('printout',$clientip,$cnum,$cdom,undef,1);
         if ($blocked) {          if ($blocked) {
             my $checkrole = "cm./$cdom/$cnum";              my $checkrole = "cm./$cdom/$cnum";
             if ($env{'request.course.sec'} ne '') {              if ($env{'request.course.sec'} ne '') {
Line 8309  $args - additional optional args support Line 8532  $args - additional optional args support
                                will contain https://<hostname> if server uses                                 will contain https://<hostname> if server uses
                                https (as per hosts.tab), but request is for http                                 https (as per hosts.tab), but request is for http
              hostname       -> hostname, originally from $r->hostname(), (optional).               hostname       -> hostname, originally from $r->hostname(), (optional).
                links_disabled -> Links in primary and secondary menus are disabled
                                  (Can enable them once page has loaded - see lonroles.pm
                                  for an example).
   
 =back  =back
   
Line 8321  sub start_page { Line 8547  sub start_page {
     #&Apache::lonnet::logthis("start_page ".join(':',caller(0)));      #&Apache::lonnet::logthis("start_page ".join(':',caller(0)));
   
     $env{'internal.start_page'}++;      $env{'internal.start_page'}++;
     my ($result,@advtools);      my ($result,@advtools,$ltiscope,$ltiuri,%ltimenu,$menucoll,%menu);
   
     if (! exists($args->{'skip_phases'}{'head'}) ) {      if (! exists($args->{'skip_phases'}{'head'}) ) {
         $result .= &xml_begin($args->{'frameset'}) . &headtag($title, $head_extra, $args);          $result .= &xml_begin($args->{'frameset'}) . &headtag($title, $head_extra, $args);
     }      }
   
       if (($env{'request.course.id'}) && ($env{'request.lti.login'})) {
           if ($env{'course.'.$env{'request.course.id'}.'.lti.override'}) {
               unless ($env{'course.'.$env{'request.course.id'}.'.lti.topmenu'}) {
                   $args->{'no_primary_menu'} = 1;
               }
               unless ($env{'course.'.$env{'request.course.id'}.'.lti.inlinemenu'}) {
                   $args->{'no_inline_menu'} = 1;
               }
               if ($env{'course.'.$env{'request.course.id'}.'.lti.lcmenu'}) {
                   map { $ltimenu{$_} = 1; } split(/,/,$env{'course.'.$env{'request.course.id'}.'.lti.lcmenu'});
               }
           } else {
               my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
               my %lti = &Apache::lonnet::get_domain_lti($cdom,'provider');
               if (ref($lti{$env{'request.lti.login'}}) eq 'HASH') {
                   unless ($lti{$env{'request.lti.login'}}{'topmenu'}) {
                       $args->{'no_primary_menu'} = 1;
                   }
                   unless ($lti{$env{'request.lti.login'}}{'inlinemenu'}) {
                       $args->{'no_inline_menu'} = 1;
                   }
                   if (ref($lti{$env{'request.lti.login'}}{'lcmenu'}) eq 'ARRAY') {
                       map { $ltimenu{$_} = 1; } @{$lti{$env{'request.lti.login'}}{'lcmenu'}};
                   }
               }
           }
           ($ltiscope,$ltiuri) = &LONCAPA::ltiutils::lti_provider_scope($env{'request.lti.uri'},
                                     $env{'course.'.$env{'request.course.id'}.'.domain'},
                                     $env{'course.'.$env{'request.course.id'}.'.num'});
       } elsif ($env{'request.course.id'}) {
           my $expiretime=600;
           if ((time-$env{'course.'.$env{'request.course.id'}.'.last_cache'}) > $expiretime) {
               &Apache::lonnet::coursedescription($env{'request.course.id'},{'freshen_cache' => 1});
           }
           my ($deeplinkmenu,$menuref);
           ($menucoll,$deeplinkmenu,$menuref) = &menucoll_in_effect();
           if ($menucoll) {
               if (ref($menuref) eq 'HASH') {
                   %menu = %{$menuref};
               }
               if ($menu{'top'} eq 'n') {
                   $args->{'no_primary_menu'} = 1;
               }
               if ($menu{'inline'} eq 'n') {
                   unless (&Apache::lonnet::allowed('opa')) {
                       my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
                       my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
                       my $crstype = &course_type();
                       my $now = time;
                       my $ccrole;
                       if ($crstype eq 'Community') {
                           $ccrole = 'co';
                       } else {
                           $ccrole = 'cc';
                       }
                       if ($env{'user.role.'.$ccrole.'./'.$cdom.'/'.$cnum}) {
                           my ($start,$end) = split(/\./,$env{'user.role.'.$ccrole.'./'.$cdom.'/'.$cnum});
                           if ((($start) && ($start<0)) ||
                               (($end) && ($end<$now))  ||
                               (($start) && ($now<$start))) {
                               $args->{'no_inline_menu'} = 1;
                           }
                       } else {
                           $args->{'no_inline_menu'} = 1;
                       }
                   }
               }
           }
       }
           
     if (! exists($args->{'skip_phases'}{'body'}) ) {      if (! exists($args->{'skip_phases'}{'body'}) ) {
  if ($args->{'frameset'}) {   if ($args->{'frameset'}) {
Line 8339  sub start_page { Line 8635  sub start_page {
                          $args->{'only_body'},      $args->{'domain'},                           $args->{'only_body'},      $args->{'domain'},
                          $args->{'force_register'}, $args->{'no_nav_bar'},                           $args->{'force_register'}, $args->{'no_nav_bar'},
                          $args->{'bgcolor'},        $args->{'no_inline_link'},                           $args->{'bgcolor'},        $args->{'no_inline_link'},
                          $args,                     \@advtools);                           $args,                     \@advtools,
                            $ltiscope,$ltiuri,\%ltimenu,$menucoll,\%menu);
         }          }
     }      }
   
Line 8374  sub start_page { Line 8671  sub start_page {
                 }                  }
                 my $menulink;                  my $menulink;
                 # if arg: bread_crumbs_nomenu is true pass 0 as $menulink item.                  # if arg: bread_crumbs_nomenu is true pass 0 as $menulink item.
                 if (exists($args->{'bread_crumbs_nomenu'})) {                  if ((exists($args->{'bread_crumbs_nomenu'})) ||
                       ($ltiscope eq 'map') || ($ltiscope eq 'resource')) {
                     $menulink = 0;                      $menulink = 0;
                 } else {                  } else {
                     undef($menulink);                      undef($menulink);
Line 8382  sub start_page { Line 8680  sub start_page {
  #if bread_crumbs_component exists show it as headline else show only the breadcrumbs   #if bread_crumbs_component exists show it as headline else show only the breadcrumbs
  if(exists($args->{'bread_crumbs_component'})){   if(exists($args->{'bread_crumbs_component'})){
  $result .= &Apache::lonhtmlcommon::breadcrumbs($args->{'bread_crumbs_component'},'',$menulink);   $result .= &Apache::lonhtmlcommon::breadcrumbs($args->{'bread_crumbs_component'},'',$menulink);
  }else{   } else {
  $result .= &Apache::lonhtmlcommon::breadcrumbs('','',$menulink);   $result .= &Apache::lonhtmlcommon::breadcrumbs('','',$menulink);
  }   }
     } elsif (($env{'environment.remote'} eq 'on') &&      } elsif (($env{'environment.remote'} eq 'on') &&
Line 8426  sub end_page { Line 8724  sub end_page {
     return $result;      return $result;
 }  }
   
   sub menucoll_in_effect {
       my ($menucoll,$deeplinkmenu,%menu);
       if ($env{'request.course.id'}) {
           $menucoll = $env{'course.'.$env{'request.course.id'}.'.menudefault'};
           if ($env{'request.deeplink.login'}) {
               my ($deeplink_symb,$deeplink,$check_login_symb);
               my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
               my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
               if ($env{'request.noversionuri'} =~ m{^/(res|uploaded)/}) {
                   if ($env{'request.noversionuri'} =~ /\.(page|sequence)$/) {
                       my $navmap = Apache::lonnavmaps::navmap->new();
                       if (ref($navmap)) {
                           $deeplink = $navmap->get_mapparam(undef,
                                                             &Apache::lonnet::declutter($env{'request.noversionuri'}),
                                                             '0.deeplink');
                       } else {
                           $check_login_symb = 1;
                       }
                   } else {
                       my $symb=&Apache::lonnet::symbread();
                       if ($symb) {
                           $deeplink = &Apache::lonnet::EXT('resource.0.deeplink',$symb);
                       } else {
                           $check_login_symb = 1;
                       }
                   }
               } else {
                   $check_login_symb = 1;
               }
               if ($check_login_symb) {
                   $deeplink_symb = &deeplink_login_symb($cnum,$cdom);
                   if ($deeplink_symb =~ /\.(page|sequence)$/) {
                       my $mapname = &Apache::lonnet::deversion((&Apache::lonnet::decode_symb($deeplink_symb))[2]);
                       my $navmap = Apache::lonnavmaps::navmap->new();
                       if (ref($navmap)) {
                           $deeplink = $navmap->get_mapparam(undef,$mapname,'0.deeplink');
                       }
                   } else {
                       $deeplink = &Apache::lonnet::EXT('resource.0.deeplink',$deeplink_symb);
                   }
               }
               if ($deeplink ne '') {
                   my ($state,$others,$listed,$scope,$protect,$display) = split(/,/,$deeplink);
                   if ($display =~ /^\d+$/) {
                       $deeplinkmenu = 1;
                       $menucoll = $display;
                   }
               }
           }
           if ($menucoll) {
               %menu = &page_menu($env{'course.'.$env{'request.course.id'}.'.menucollections'},$menucoll);
           }
       }
       return ($menucoll,$deeplinkmenu,\%menu);
   }
   
   sub deeplink_login_symb {
       my ($cnum,$cdom) = @_;
       my $login_symb;
       if ($env{'request.deeplink.login'}) {
           $login_symb = &symb_from_tinyurl($env{'request.deeplink.login'},$cnum,$cdom);
       }
       return $login_symb;
   }
   
   sub symb_from_tinyurl {
       my ($url,$cnum,$cdom) = @_;
       if ($url =~ m{^\Q/tiny/$cdom/\E(\w+)$}) {
           my $key = $1;
           my ($tinyurl,$login);
           my ($result,$cached)=&Apache::lonnet::is_cached_new('tiny',$cdom."\0".$key);
           if (defined($cached)) {
               $tinyurl = $result;
           } else {
               my $configuname = &Apache::lonnet::get_domainconfiguser($cdom);
               my %currtiny = &Apache::lonnet::get('tiny',[$key],$cdom,$configuname);
               if ($currtiny{$key} ne '') {
                   $tinyurl = $currtiny{$key};
                   &Apache::lonnet::do_cache_new('tiny',$cdom."\0".$key,$currtiny{$key},600);
               }
           }
           if ($tinyurl ne '') {
               my ($cnumreq,$symb) = split(/\&/,$tinyurl);
               if (wantarray) {
                   return ($cnumreq,$symb);
               } elsif ($cnumreq eq $cnum) {
                   return $symb;
               }
           }
       }
       if (wantarray) {
           return ();
       } else {
           return;
       }
   }
   
 sub wishlist_window {  sub wishlist_window {
     return(<<'ENDWISHLIST');      return(<<'ENDWISHLIST');
 <script type="text/javascript">  <script type="text/javascript">
Line 8515  ENDLINK Line 8910  ENDLINK
 }  }
   
 sub modal_adhoc_script {  sub modal_adhoc_script {
     my ($funcname,$width,$height,$content)=@_;      my ($funcname,$width,$height,$content,$possmathjax)=@_;
       my $mathjax;
       if ($possmathjax) {
           $mathjax = <<'ENDJAX';
                  if (typeof MathJax == 'object') {
                      MathJax.Hub.Queue(["Typeset",MathJax.Hub]);
                  }
   ENDJAX
       }
     return (<<ENDADHOC);      return (<<ENDADHOC);
 <script type="text/javascript">  <script type="text/javascript">
 // <![CDATA[  // <![CDATA[
Line 8526  sub modal_adhoc_script { Line 8929  sub modal_adhoc_script {
                 modalWindow.height = $height;                  modalWindow.height = $height;
                 modalWindow.content = '$content';                  modalWindow.content = '$content';
                 modalWindow.open();                  modalWindow.open();
                   $mathjax
         };            };  
 // ]]>  // ]]>
 </script>  </script>
Line 8533  ENDADHOC Line 8937  ENDADHOC
 }  }
   
 sub modal_adhoc_inner {  sub modal_adhoc_inner {
     my ($funcname,$width,$height,$content)=@_;      my ($funcname,$width,$height,$content,$possmathjax)=@_;
     my $innerwidth=$width-20;      my $innerwidth=$width-20;
     $content=&js_ready(      $content=&js_ready(
                &start_page('Dialog',undef,{'only_body'=>1,'bgcolor'=>'#FFFFFF'}).                 &start_page('Dialog',undef,{'only_body'=>1,'bgcolor'=>'#FFFFFF'}).
Line 8542  sub modal_adhoc_inner { Line 8946  sub modal_adhoc_inner {
                  &end_scrollbox().                   &end_scrollbox().
                  &end_page()                   &end_page()
              );               );
     return &modal_adhoc_script($funcname,$width,$height,$content);      return &modal_adhoc_script($funcname,$width,$height,$content,$possmathjax);
 }  }
   
 sub modal_adhoc_window {  sub modal_adhoc_window {
     my ($funcname,$width,$height,$content,$linktext)=@_;      my ($funcname,$width,$height,$content,$linktext,$possmathjax)=@_;
     return &modal_adhoc_inner($funcname,$width,$height,$content).      return &modal_adhoc_inner($funcname,$width,$height,$content,$possmathjax).
            "<a href=\"javascript:$funcname();void(0);\">".$linktext."</a>";             "<a href=\"javascript:$funcname();void(0);\">".$linktext."</a>";
 }  }
   
Line 10403  sub sorted_inst_types { Line 10807  sub sorted_inst_types {
 }  }
   
 sub get_institutional_codes {  sub get_institutional_codes {
     my ($settings,$allcourses,$LC_code) = @_;      my ($cdom,$crs,$settings,$allcourses,$LC_code) = @_;
 # Get complete list of course sections to update  # Get complete list of course sections to update
     my @currsections = ();      my @currsections = ();
     my @currxlists = ();      my @currxlists = ();
       my (%unclutteredsec,%unclutteredlcsec);
     my $coursecode = $$settings{'internal.coursecode'};      my $coursecode = $$settings{'internal.coursecode'};
       my $crskey = $crs.':'.$coursecode;
       @{$unclutteredsec{$crskey}} = ();
       @{$unclutteredlcsec{$crskey}} = ();
   
     if ($$settings{'internal.sectionnums'} ne '') {      if ($$settings{'internal.sectionnums'} ne '') {
         @currsections = split(/,/,$$settings{'internal.sectionnums'});          @currsections = split(/,/,$$settings{'internal.sectionnums'});
Line 10418  sub get_institutional_codes { Line 10826  sub get_institutional_codes {
     }      }
   
     if (@currxlists > 0) {      if (@currxlists > 0) {
         foreach (@currxlists) {          foreach my $xl (@currxlists) {
             if (m/^([^:]+):(\w*)$/) {              if ($xl =~ /^([^:]+):(\w*)$/) {
                 unless (grep/^$1$/,@{$allcourses}) {                  unless (grep/^$1$/,@{$allcourses}) {
                     push(@{$allcourses},$1);                      push(@{$allcourses},$1);
                     $$LC_code{$1} = $2;                      $$LC_code{$1} = $2;
Line 10427  sub get_institutional_codes { Line 10835  sub get_institutional_codes {
             }              }
         }          }
     }      }
    
     if (@currsections > 0) {      if (@currsections > 0) {
         foreach (@currsections) {          foreach my $sec (@currsections) {
             if (m/^(\w+):(\w*)$/) {              if ($sec =~ m/^(\w+):(\w*)$/ ) {
                 my $sec = $coursecode.$1;                  my $instsec = $1;
                 my $lc_sec = $2;                  my $lc_sec = $2;
                 unless (grep/^$sec$/,@{$allcourses}) {                  unless (grep/^\Q$instsec\E$/,@{$unclutteredsec{$crskey}}) {
                       push(@{$unclutteredsec{$crskey}},$instsec);
                       push(@{$unclutteredlcsec{$crskey}},$lc_sec);
                   }
               }
           }
       }
   
       if (@{$unclutteredsec{$crskey}} > 0) {
           my %formattedsec = &Apache::lonnet::auto_instsec_reformat($cdom,'clutter',\%unclutteredsec);
           if ((ref($formattedsec{$crskey}) eq 'ARRAY') && (ref($unclutteredlcsec{$crskey}) eq 'ARRAY')) {
               for (my $i=0; $i<@{$formattedsec{$crskey}}; $i++) {
                   my $sec = $coursecode.$formattedsec{$crskey}[$i];
                   unless (grep/^\Q$sec\E$/,@{$allcourses}) {
                     push(@{$allcourses},$sec);                      push(@{$allcourses},$sec);
                     $$LC_code{$sec} = $lc_sec;                      $$LC_code{$sec} = $unclutteredlcsec{$crskey}[$i];
                 }                  }
             }              }
         }          }
Line 15117  sub check_clone { Line 15538  sub check_clone {
     my $cloneid='/'.$args->{'clonedomain'}.'/'.$args->{'clonecourse'};      my $cloneid='/'.$args->{'clonedomain'}.'/'.$args->{'clonecourse'};
     my ($clonecrsudom,$clonecrsunum)= &LONCAPA::split_courseid($cloneid);      my ($clonecrsudom,$clonecrsunum)= &LONCAPA::split_courseid($cloneid);
     my $clonehome=&Apache::lonnet::homeserver($clonecrsunum,$clonecrsudom);      my $clonehome=&Apache::lonnet::homeserver($clonecrsunum,$clonecrsudom);
     my $clonemsg;      my $clonetitle;
       my @clonemsg;
     my $can_clone = 0;      my $can_clone = 0;
     my $lctype = lc($args->{'crstype'});      my $lctype = lc($args->{'crstype'});
     if ($lctype ne 'community') {      if ($lctype ne 'community') {
Line 15125  sub check_clone { Line 15547  sub check_clone {
     }      }
     if ($clonehome eq 'no_host') {      if ($clonehome eq 'no_host') {
         if ($args->{'crstype'} eq 'Community') {          if ($args->{'crstype'} eq 'Community') {
             $clonemsg = &mt('No new community created.').$linefeed.&mt('A new community could not be cloned from the specified original - [_1] - because it is a non-existent community.',$args->{'clonecourse'}.':'.$args->{'clonedomain'});              push(@clonemsg,({
                                 mt => 'No new community created.',
                                 args => [],
                               },
                               {
                                 mt => 'A new community could not be cloned from the specified original - [_1] - because it is a non-existent community.',
                                 args => [$args->{'clonedomain'}.':'.$args->{'clonedomain'}],
                               }));
         } else {          } else {
             $clonemsg = &mt('No new course created.').$linefeed.&mt('A new course could not be cloned from the specified original - [_1] - because it is a non-existent course.',$args->{'clonecourse'}.':'.$args->{'clonedomain'});              push(@clonemsg,({
         }                                     mt => 'No new course created.',
                                 args => [],
                               },
                               {
                                 mt => 'A new course could not be cloned from the specified original - [_1] - because it is a non-existent course.',
                                 args => [$args->{'clonecourse'}.':'.$args->{'clonedomain'}],
                               }));
           }
     } else {      } else {
  my %clonedesc = &Apache::lonnet::coursedescription($cloneid,{'one_time' => 1});   my %clonedesc = &Apache::lonnet::coursedescription($cloneid,{'one_time' => 1});
           $clonetitle = $clonedesc{'description'};
         if ($args->{'crstype'} eq 'Community') {          if ($args->{'crstype'} eq 'Community') {
             if ($clonedesc{'type'} ne 'Community') {              if ($clonedesc{'type'} ne 'Community') {
                  $clonemsg = &mt('No new community created.').$linefeed.&mt('A new community could not be cloned from the specified original - [_1] - because it is a course not a community.',$args->{'clonecourse'}.':'.$args->{'clonedomain'});                  push(@clonemsg,({
                 return ($can_clone, $clonemsg, $cloneid, $clonehome);                                    mt => 'No new community created.',
                                     args => [],
                                   },
                                   {
                                     mt => 'A new community could not be cloned from the specified original - [_1] - because it is a course not a community.',
                                     args => [$args->{'clonecourse'}.':'.$args->{'clonedomain'}],
                                   }));
                   return ($can_clone,\@clonemsg,$cloneid,$clonehome);
             }              }
         }          }
  if (($env{'request.role.domain'} eq $args->{'clonedomain'}) &&   if (($env{'request.role.domain'} eq $args->{'clonedomain'}) &&
Line 15223  sub check_clone { Line 15667  sub check_clone {
             }              }
             unless ($can_clone) {              unless ($can_clone) {
                 if ($args->{'crstype'} eq 'Community') {                  if ($args->{'crstype'} eq 'Community') {
                     $clonemsg = &mt('No new community created.').$linefeed.&mt('The new community could not be cloned from the existing community because the new community owner ([_1]) does not have cloning rights in the existing community ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'});                      push(@clonemsg,({
                                         mt => 'No new community created.',
                                         args => [],
                                       },
                                       {
                                         mt => 'The new community could not be cloned from the existing community because the new community owner ([_1]) does not have cloning rights in the existing community ([_2]).',
                                         args => [$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}],
                                       }));
                 } else {                  } else {
                     $clonemsg = &mt('No new course created.').$linefeed.&mt('The new course could not be cloned from the existing course because the new course owner ([_1]) does not have cloning rights in the existing course ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'});                      push(@clonemsg,({
                                         mt => 'No new course created.',
                                         args => [],
                                       },
                                       {
                                         mt => 'The new course could not be cloned from the existing course because the new course owner ([_1]) does not have cloning rights in the existing course ([_2]).',
                                         args => [$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}],
                                       }));
         }          }
     }      }
         }          }
     }      }
     return ($can_clone, $clonemsg, $cloneid, $clonehome);      return ($can_clone,\@clonemsg,$cloneid,$clonehome,$clonetitle);
 }  }
   
 sub construct_course {  sub construct_course {
     my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context,      my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context,
         $cnum,$category,$coderef) = @_;          $cnum,$category,$coderef,$callercontext,$user_lh) = @_;
     my $outcome;      my ($outcome,$msgref,$clonemsgref);
     my $linefeed =  '<br />'."\n";      my $linefeed =  '<br />'."\n";
     if ($context eq 'auto') {      if ($context eq 'auto') {
         $linefeed = "\n";          $linefeed = "\n";
Line 15245  sub construct_course { Line 15703  sub construct_course {
 #  #
 # Are we cloning?  # Are we cloning?
 #  #
     my ($can_clone, $clonemsg, $cloneid, $clonehome);      my ($can_clone,$cloneid,$clonehome,$clonetitle);
     if (($args->{'clonecourse'}) && ($args->{'clonedomain'})) {      if (($args->{'clonecourse'}) && ($args->{'clonedomain'})) {
  ($can_clone, $clonemsg, $cloneid, $clonehome) = &check_clone($args,$linefeed);   ($can_clone,$clonemsgref,$cloneid,$clonehome,$clonetitle) = &check_clone($args,$linefeed);
  if ($context ne 'auto') {  
             if ($clonemsg ne '') {  
         $clonemsg = '<span class="LC_error">'.$clonemsg.'</span>';  
             }  
  }  
  $outcome .= $clonemsg.$linefeed;  
   
         if (!$can_clone) {          if (!$can_clone) {
     return (0,$outcome);      return (0,$outcome,$clonemsgref);
  }   }
     }      }
   
Line 15274  sub construct_course { Line 15725  sub construct_course {
                                              $args->{'ccuname'}.':'.                                               $args->{'ccuname'}.':'.
                                              $args->{'ccdomain'},                                               $args->{'ccdomain'},
                                              $args->{'crstype'},                                               $args->{'crstype'},
                                              $cnum,$context,$category);                                               $cnum,$context,$category,
                                                $callercontext);
   
     # Note: The testing routines depend on this being output; see       # Note: The testing routines depend on this being output; see 
     # Utils::Course. This needs to at least be output as a comment      # Utils::Course. This needs to at least be output as a comment
     # if anyone ever decides to not show this, and Utils::Course::new      # if anyone ever decides to not show this, and Utils::Course::new
     # will need to be suitably modified.      # will need to be suitably modified.
     $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed;      if (($callercontext eq 'auto') && ($user_lh ne '')) {
           $outcome .= &mt_user($user_lh,'New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed;
       } else {
           $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed;
       }
     if ($$courseid =~ /^error:/) {      if ($$courseid =~ /^error:/) {
         return (0,$outcome);          return (0,$outcome,$clonemsgref);
     }      }
   
 #  #
Line 15291  sub construct_course { Line 15747  sub construct_course {
     ($$crsudom,$$crsunum)= &LONCAPA::split_courseid($$courseid);      ($$crsudom,$$crsunum)= &LONCAPA::split_courseid($$courseid);
     my $crsuhome=&Apache::lonnet::homeserver($$crsunum,$$crsudom);      my $crsuhome=&Apache::lonnet::homeserver($$crsunum,$$crsudom);
     if ($crsuhome eq 'no_host') {      if ($crsuhome eq 'no_host') {
         $outcome .= &mt('Course creation failed, unrecognized course home server.').$linefeed;          if (($callercontext eq 'auto') && ($user_lh ne '')) {
         return (0,$outcome);              $outcome .= &mt_user($user_lh,
                               'Course creation failed, unrecognized course home server.');
           } else {
               $outcome .= &mt('Course creation failed, unrecognized course home server.');
           }
           $outcome .= $linefeed;
           return (0,$outcome,$clonemsgref);
     }      }
     $outcome .= &mt('Created on').': '.$crsuhome.$linefeed;      $outcome .= &mt('Created on').': '.$crsuhome.$linefeed;
   
 #  #
 # Do the cloning  # Do the cloning
 #     #
       my @clonemsg;
     if ($can_clone && $cloneid) {      if ($can_clone && $cloneid) {
  $clonemsg = &mt('Cloning [_1] from [_2]',$crstype,$clonehome);          push(@clonemsg,
  if ($context ne 'auto') {                        {
     $clonemsg = '<span class="LC_success">'.$clonemsg.'</span>';                            mt => 'Created [_1] by cloning from [_2]',
  }                            args => [$crstype,$clonetitle],
  $outcome .= $clonemsg.$linefeed;                        });
  my %oldcenv=&Apache::lonnet::dump('environment',$$crsudom,$$crsunum);   my %oldcenv=&Apache::lonnet::dump('environment',$$crsudom,$$crsunum);
 # Copy all files  # Copy all files
  &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'},$args->{'dateshift'});          my @info =
               &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'},
                                                        $args->{'dateshift'},$args->{'crscode'},
                                                        $args->{'ccuname'}.':'.$args->{'ccdomain'},
                                                        $args->{'tinyurls'});
           if (@info) {
               push(@clonemsg,@info);
           }
 # Restore URL  # Restore URL
  $cenv{'url'}=$oldcenv{'url'};   $cenv{'url'}=$oldcenv{'url'};
 # Restore title  # Restore title
Line 15332  sub construct_course { Line 15802  sub construct_course {
                    'plc.users.denied',                     'plc.users.denied',
                    'hidefromcat',                     'hidefromcat',
                    'checkforpriv',                     'checkforpriv',
                    'categories',                     'categories'],
                    'internal.uniquecode'],  
                    $$crsudom,$$crsunum);                     $$crsudom,$$crsunum);
         if ($args->{'textbook'}) {          if ($args->{'textbook'}) {
             $cenv{'internal.textbook'} = $args->{'textbook'};              $cenv{'internal.textbook'} = $args->{'textbook'};
Line 15614  sub construct_course { Line 16083  sub construct_course {
         $outcome .= ($fatal?$errtext:'write ok').$linefeed;          $outcome .= ($fatal?$errtext:'write ok').$linefeed;
     }      }
   
     return (1,$outcome);      return (1,$outcome,\@clonemsg);
 }  }
   
 sub make_unique_code {  sub make_unique_code {
Line 15783  sub compare_arrays { Line 16252  sub compare_arrays {
     return @difference;      return @difference;
 }  }
   
   sub lon_status_items {
       my %defaults = (
                        E         => 100,
                        W         => 4,
                        N         => 1,
                        U         => 5,
                        threshold => 200,
                        sysmail   => 2500,
                      );
       my %names = (
                      E => 'Errors',
                      W => 'Warnings',
                      N => 'Notices',
                      U => 'Unsent',
                   );
       return (\%defaults,\%names);
   }
   
 # -------------------------------------------------------- Initialize user login  # -------------------------------------------------------- Initialize user login
 sub init_user_environment {  sub init_user_environment {
     my ($r, $username, $domain, $authhost, $form, $args) = @_;      my ($r, $username, $domain, $authhost, $form, $args) = @_;
Line 15885  sub init_user_environment { Line 16372  sub init_user_environment {
 # --------------------------------------------------------- Write first profile  # --------------------------------------------------------- Write first profile
   
     {      {
           my $ip = &Apache::lonnet::get_requestor_ip();
  my %initial_env =    my %initial_env = 
     ("user.name"          => $username,      ("user.name"          => $username,
      "user.domain"        => $domain,       "user.domain"        => $domain,
Line 15903  sub init_user_environment { Line 16391  sub init_user_environment {
      "request.course.sec" => '',       "request.course.sec" => '',
      "request.role"       => 'cm',       "request.role"       => 'cm',
      "request.role.adv"   => $env{'user.adv'},       "request.role.adv"   => $env{'user.adv'},
      "request.host"       => $ENV{'REMOTE_ADDR'},);       "request.host"       => $ip,);
   
         if ($form->{'localpath'}) {          if ($form->{'localpath'}) {
     $initial_env{"browser.localpath"}  = $form->{'localpath'};      $initial_env{"browser.localpath"}  = $form->{'localpath'};
Line 16763  sub needs_coursereinit { Line 17251  sub needs_coursereinit {
         $interval = 600;          $interval = 600;
     }      }
     if (($now-$env{'request.course.timechecked'})>$interval) {      if (($now-$env{'request.course.timechecked'})>$interval) {
         my $lastchange = &Apache::lonnet::get_coursechange($cdom,$cnum);  
         &Apache::lonnet::appenv({'request.course.timechecked'=>$now});          &Apache::lonnet::appenv({'request.course.timechecked'=>$now});
           my $blocked = &blocking_status('reinit',$cnum,$cdom,undef,1);
           if ($blocked) {
               return ();
           }
           my $lastchange = &Apache::lonnet::get_coursechange($cdom,$cnum);
         if ($lastchange > $env{'request.course.tied'}) {          if ($lastchange > $env{'request.course.tied'}) {
             my %curr_reqd_hash = &Apache::lonnet::userenvironment($cdom,$cnum,'internal.releaserequired');              my %curr_reqd_hash = &Apache::lonnet::userenvironment($cdom,$cnum,'internal.releaserequired');
             if ($curr_reqd_hash{'internal.releaserequired'} ne '') {              if ($curr_reqd_hash{'internal.releaserequired'} ne '') {
Line 17086  sub create_captcha { Line 17578  sub create_captcha {
   
         if (-e $Apache::lonnet::perlvar{'lonCaptchaDir'}.'/'.$md5sum.'.png') {          if (-e $Apache::lonnet::perlvar{'lonCaptchaDir'}.'/'.$md5sum.'.png') {
             $output = '<input type="hidden" name="crypt" value="'.$md5sum.'" />'."\n".              $output = '<input type="hidden" name="crypt" value="'.$md5sum.'" />'."\n".
                         '<span class="LC_nobreak">'.
                       &mt('Type in the letters/numbers shown below').'&nbsp;'.                        &mt('Type in the letters/numbers shown below').'&nbsp;'.
                       '<input type="text" size="5" name="code" value="" autocomplete="off" />'.                        '<input type="text" size="5" name="code" value="" autocomplete="off" />'.
                       '<br />'.                        '</span><br />'.
                       '<img src="'.$captcha_params{'www_output_dir'}.'/'.$md5sum.'.png" alt="captcha" />';                        '<img src="'.$captcha_params{'www_output_dir'}.'/'.$md5sum.'.png" alt="captcha" />';
             last;              last;
         }          }
     }      }
       if ($output eq '') {
           &Apache::lonnet::logthis("Failed to create Captcha code after $tries attempts.");
       }
     return $output;      return $output;
 }  }
   
Line 17131  sub check_captcha { Line 17627  sub check_captcha {
 sub create_recaptcha {  sub create_recaptcha {
     my ($pubkey,$version) = @_;      my ($pubkey,$version) = @_;
     if ($version >= 2) {      if ($version >= 2) {
         return '<div class="g-recaptcha" data-sitekey="'.$pubkey.'"></div>';          return '<div class="g-recaptcha" data-sitekey="'.$pubkey.'"></div>'.
                  '<div style="padding:0;clear:both;margin:0;border:0"></div>';
     } else {      } else {
         my $use_ssl;          my $use_ssl;
         if ($ENV{'SERVER_PORT'} == 443) {          if ($ENV{'SERVER_PORT'} == 443) {
Line 17149  sub create_recaptcha { Line 17646  sub create_recaptcha {
 sub check_recaptcha {  sub check_recaptcha {
     my ($privkey,$version) = @_;      my ($privkey,$version) = @_;
     my $captcha_chk;      my $captcha_chk;
       my $ip = &Apache::lonnet::get_requestor_ip(); 
     if ($version >= 2) {      if ($version >= 2) {
         my $ua = LWP::UserAgent->new;          my $ua = LWP::UserAgent->new;
         $ua->timeout(10);          $ua->timeout(10);
         my %info = (          my %info = (
                      secret   => $privkey,                       secret   => $privkey,
                      response => $env{'form.g-recaptcha-response'},                       response => $env{'form.g-recaptcha-response'},
                      remoteip => $ENV{'REMOTE_ADDR'},                       remoteip => $ip,
                    );                     );
         my $response = $ua->post('https://www.google.com/recaptcha/api/siteverify',\%info);          my $response = $ua->post('https://www.google.com/recaptcha/api/siteverify',\%info);
         if ($response->is_success)  {          if ($response->is_success)  {
Line 17171  sub check_recaptcha { Line 17669  sub check_recaptcha {
         my $captcha_result =          my $captcha_result =
             $captcha->check_answer(              $captcha->check_answer(
                                     $privkey,                                      $privkey,
                                     $ENV{'REMOTE_ADDR'},                                      $ip,
                                     $env{'form.recaptcha_challenge_field'},                                      $env{'form.recaptcha_challenge_field'},
                                     $env{'form.recaptcha_response_field'},                                      $env{'form.recaptcha_response_field'},
                                   );                                    );
Line 17220  sub cleanup_html { Line 17718  sub cleanup_html {
   
 # Checks for critical messages and returns a redirect url if one exists.  # Checks for critical messages and returns a redirect url if one exists.
 # $interval indicates how often to check for messages.  # $interval indicates how often to check for messages.
   # $context is the calling context -- roles, grades, contents, menu or flip.
 sub critical_redirect {  sub critical_redirect {
     my ($interval) = @_;      my ($interval,$context) = @_;
       unless (($env{'user.domain'} ne '') && ($env{'user.name'} ne '')) {
           return ();
       }
     if ((time-$env{'user.criticalcheck.time'})>$interval) {      if ((time-$env{'user.criticalcheck.time'})>$interval) {
           if (($env{'request.course.id'}) && (($context eq 'flip') || ($context eq 'contents'))) {
               my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
               my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
               my $blocked = &blocking_status('alert',$cnum,$cdom,undef,1);
               if ($blocked) {
                   my $checkrole = "cm./$cdom/$cnum";
                   if ($env{'request.course.sec'} ne '') {
                       $checkrole .= "/$env{'request.course.sec'}";
                   }
                   unless ((&Apache::lonnet::allowed('evb',undef,undef,$checkrole)) &&
                           ($env{'request.role'} !~ m{^st\./$cdom/$cnum})) {
                       return;
                   }
               }
           }
         my @what=&Apache::lonnet::dump('critical', $env{'user.domain'},          my @what=&Apache::lonnet::dump('critical', $env{'user.domain'},
                                         $env{'user.name'});                                          $env{'user.name'});
         &Apache::lonnet::appenv({'user.criticalcheck.time'=>time});          &Apache::lonnet::appenv({'user.criticalcheck.time'=>time});
         my $redirecturl;          my $redirecturl;
         if ($what[0]) {          if ($what[0]) {
             if (($what[0] ne 'con_lost') && ($what[0]!~/^error\:/)) {              if (($what[0] ne 'con_lost') && ($what[0] ne 'no_such_host') && ($what[0]!~/^error\:/)) {
                 $redirecturl='/adm/email?critical=display';                  $redirecturl='/adm/email?critical=display';
                 my $url=&Apache::lonnet::absolute_url().$redirecturl;                  my $url=&Apache::lonnet::absolute_url().$redirecturl;
                 return (1, $url);                  return (1, $url);
Line 17288  sub des_decrypt { Line 17805  sub des_decrypt {
     return $plaintext;      return $plaintext;
 }  }
   
   sub get_requested_shorturls {
       my ($cdom,$cnum,$navmap) = @_;
       return unless (ref($navmap));
       my ($numnew,$errors);
       my @toshorten = &Apache::loncommon::get_env_multiple('form.addtiny');
       if (@toshorten) {
           my (%maps,%resources,%titles);
           &Apache::loncourserespicker::enumerate_course_contents($navmap,\%maps,\%resources,\%titles,
                                                                  'shorturls',$cdom,$cnum);
           if (keys(%resources)) {
               my %tocreate;
               foreach my $item (sort {$a <=> $b} (@toshorten)) {
                   my $symb = $resources{$item};
                   if ($symb) {
                       $tocreate{$cnum.'&'.$symb} = 1;
                   }
               }
               if (keys(%tocreate)) {
                   ($numnew,$errors) = &make_short_symbs($cdom,$cnum,
                                                         \%tocreate);
               }
           }
       }
       return ($numnew,$errors);
   }
   
   sub make_short_symbs {
       my ($cdom,$cnum,$tocreateref,$lockuser) = @_;
       my ($numnew,@errors);
       if (ref($tocreateref) eq 'HASH') {
           my %tocreate = %{$tocreateref};
           if (keys(%tocreate)) {
               my %coursetiny = &Apache::lonnet::dump('tiny',$cdom,$cnum);
               my $su = Short::URL->new(no_vowels => 1);
               my $init = '';
               my (%newunique,%addcourse,%courseonly,%failed);
               # get lock on tiny db
               my $now = time;
               if ($lockuser eq '') {
                   $lockuser = $env{'user.name'}.':'.$env{'user.domain'};
               }
               my $lockhash = {
                                   "lock\0$now" => $lockuser,
                               };
               my $tries = 0;
               my $gotlock = &Apache::lonnet::newput_dom('tiny',$lockhash,$cdom);
               my ($code,$error);
               while (($gotlock ne 'ok') && ($tries<3)) {
                   $tries ++;
                   sleep 1;
                   $gotlock = &Apache::lonnet::newput_dom('tiny',$lockhash,$cdom);
               }
               if ($gotlock eq 'ok') {
                   $init = &shorten_symbs($cdom,$init,$su,\%coursetiny,\%tocreate,\%newunique,
                                          \%addcourse,\%courseonly,\%failed);
                   if (keys(%failed)) {
                       my $numfailed = scalar(keys(%failed));
                       push(@errors,&mt('error: could not obtain unique six character URL for [quant,_1,resource]',$numfailed));
                   }
                   if (keys(%newunique)) {
                       my $putres = &Apache::lonnet::newput_dom('tiny',\%newunique,$cdom);
                       if ($putres eq 'ok') {
                           $numnew = scalar(keys(%newunique));
                           my $newputres = &Apache::lonnet::newput('tiny',\%addcourse,$cdom,$cnum);
                           unless ($newputres eq 'ok') {
                               push(@errors,&mt('error: could not store course look-up of short URLs'));
                           }
                       } else {
                           push(@errors,&mt('error: could not store unique six character URLs'));
                       }
                   }
                   my $dellockres = &Apache::lonnet::del_dom('tiny',["lock\0$now"],$cdom);
                   unless ($dellockres eq 'ok') {
                       push(@errors,&mt('error: could not release lockfile'));
                   }
               } else {
                   push(@errors,&mt('error: could not obtain lockfile'));
               }
               if (keys(%courseonly)) {
                   my $result = &Apache::lonnet::newput('tiny',\%courseonly,$cdom,$cnum);
                   if ($result ne 'ok') {
                       push(@errors,&mt('error: could not update course look-up of short URLs'));
                   }
               }
           }
       }
       return ($numnew,\@errors);
   }
   
   sub shorten_symbs {
       my ($cdom,$init,$su,$coursetiny,$tocreate,$newunique,$addcourse,$courseonly,$failed) = @_;
       return unless ((ref($su)) && (ref($coursetiny) eq 'HASH') && (ref($tocreate) eq 'HASH') &&
                      (ref($newunique) eq 'HASH') && (ref($addcourse) eq 'HASH') &&
                      (ref($courseonly) eq 'HASH') && (ref($failed) eq 'HASH'));
       my (%possibles,%collisions);
       foreach my $key (keys(%{$tocreate})) {
           my $num = String::CRC32::crc32($key);
           my $tiny = $su->encode($num,$init);
           if ($tiny) {
               $possibles{$tiny} = $key;
           }
       }
       if (!$init) {
           $init = 1;
       } else {
           $init ++;
       }
       if (keys(%possibles)) {
           my @posstiny = keys(%possibles);
           my $configuname = &Apache::lonnet::get_domainconfiguser($cdom);
           my %currtiny = &Apache::lonnet::get('tiny',\@posstiny,$cdom,$configuname);
           if (keys(%currtiny)) {
               foreach my $key (keys(%currtiny)) {
                   next if ($currtiny{$key} eq '');
                   if ($currtiny{$key} eq $possibles{$key}) {
                       my ($tcnum,$tsymb) = split(/\&/,$currtiny{$key});
                       unless (($coursetiny->{$tsymb} eq $key) || ($addcourse->{$tsymb} eq $key) || ($courseonly->{$tsymb} eq $key)) {
                           $courseonly->{$tsymb} = $key;
                       }
                   } else {
                       $collisions{$possibles{$key}} = 1;
                   }
                   delete($possibles{$key});
               }
           }
           foreach my $key (keys(%possibles)) {
               $newunique->{$key} = $possibles{$key};
               my ($tcnum,$tsymb) = split(/\&/,$possibles{$key});
               unless (($coursetiny->{$tsymb} eq $key) || ($addcourse->{$tsymb} eq $key) || ($courseonly->{$tsymb} eq $key)) {
                   $addcourse->{$tsymb} = $key;
               }
           }
       }
       if (keys(%collisions)) {
           if ($init <5) {
               if (!$init) {
                   $init = 1;
               } else {
                   $init ++;
               }
               $init = &shorten_symbs($cdom,$init,$su,$coursetiny,\%collisions,
                                      $newunique,$addcourse,$courseonly,$failed);
           } else {
               foreach my $key (keys(%collisions)) {
                   $failed->{$key} = 1;
                   $failed->{$key} = 1;
               }
           }
       }
       return $init;
   }
   
 sub is_nonframeable {  sub is_nonframeable {
     my ($url,$absolute,$hostname,$ip,$nocache) = @_;      my ($url,$absolute,$hostname,$ip,$nocache) = @_;
     my ($remprotocol,$remhost) = ($url =~ m{^(https?)\://(([a-z0-9]+(-[a-z0-9]+)*\.)+[a-z]{2,})}i);      my ($remprotocol,$remhost) = ($url =~ m{^(https?)\://(([a-z0-9]+(-[a-z0-9]+)*\.)+[a-z]{2,})}i);
Line 17441  sub is_nonframeable { Line 18110  sub is_nonframeable {
     return $uselink;      return $uselink;
 }  }
   
   sub page_menu {
       my ($menucolls,$menunum) = @_;
       my %menu;
       foreach my $item (split(/;/,$menucolls)) {
           my ($num,$value) = split(/\%/,$item);
           if ($num eq $menunum) {
               my @entries = split(/\&/,$value);
               foreach my $entry (@entries) {
                   my ($name,$fields) = split(/=/,$entry);
                   if (($name eq 'top') || ($name eq 'inline') || ($name eq 'foot') || ($name eq 'main')) {
                       $menu{$name} = $fields;
                   } else {
                       my @shown;
                       if ($fields =~ /,/) {
                           @shown = split(/,/,$fields);
                       } else {
                           @shown = ($fields);
                       }
                       if (@shown) {
                           foreach my $field (@shown) {
                               next if ($field eq '');
                               $menu{$field} = 1;
                           }
                       }
                   }
               }
           }
       }
       return %menu;
   }
   
 1;  1;
 __END__;  __END__;
   
Removed from v.1.1075.2.149  
changed lines
  Added in v.1.1075.2.161.2.1

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