[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.141.2.14 and 1.1075.2.157

version 1.1075.2.141.2.14, 2021/01/30 23:26:03 version 1.1075.2.157, 2021/09/11 16:00:23
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 4756  sub blockcheck { Line 4754  sub blockcheck {
     # 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') &&
          $activity eq 'search' || $activity eq 'reinit' ||  
          $activity eq 'alert') &&  
         ($env{'request.course.id'})) {          ($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'}) {
Line 5045  sub blocking_status { Line 5041  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 (or information page) the user is trying to look at  # $uname and $udom decide whose portfolio the user is trying to look at
     if (($activity eq 'port') ||  ($activity eq 'about') || ($activity eq 'passwd')) {      if (($activity eq 'port') || ($activity eq 'passwd')) {
         $querystring .= "&udom=$udom"      if ($udom =~ /^$match_domain$/);          $querystring .= "&udom=$udom"      if ($udom =~ /^$match_domain$/);
         $querystring .= "&uname=$uname"    if ($uname =~ /^$match_username$/);          $querystring .= "&uname=$uname"    if ($uname =~ /^$match_username$/);
     } elsif ($activity eq 'docs') {      } elsif ($activity eq 'docs') {
Line 5080  END_MYBLOCK Line 5076  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');  
     }      }
     $output .= <<"END_BLOCK";      $output .= <<"END_BLOCK";
 <div class='$class'>  <div class='$class'>
Line 5113  sub check_ip_acc { Line 5099  sub check_ip_acc {
     if (!defined($acc) || $acc =~ /^\s*$/ || $acc =~/^\s*no\s*$/i) {      if (!defined($acc) || $acc =~ /^\s*$/ || $acc =~/^\s*no\s*$/i) {
         return 1;          return 1;
     }      }
     my ($ip,$allowed);      my $allowed=0;
       my $ip;
     if (($ENV{'REMOTE_ADDR'} eq '127.0.0.1') ||      if (($ENV{'REMOTE_ADDR'} eq '127.0.0.1') ||
         ($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 {
         my $remote_ip = &Apache::lonnet::get_requestor_ip();           my $remote_ip = &Apache::lonnet::get_requestor_ip();
         $ip = $remote_ip || $env{'request.host'} || $clientip;          $ip = $remote_ip || $env{'request.host'} || $clientip;
     }      }
   
     my $name;      my $name;
     my %access = (      foreach my $pattern (split(',',$acc)) {
                      allowfrom => 1,          $pattern =~ s/^\s*//;
                      denyfrom  => 0,          $pattern =~ s/\s*$//;
                  );  
     my @allows;  
     my @denies;  
     foreach my $item (split(',',$acc)) {  
         $item =~ s/^\s*//;  
         $item =~ s/\s*$//;  
         if ($item =~ /^\!(.+)$/) {  
             push(@denies,$1);  
         } else {  
             push(@allows,$item);  
         }  
     }  
     my $numdenies = scalar(@denies);  
     my $numallows = scalar(@allows);  
     my $count = 0;  
     foreach my $pattern (@denies,@allows) {  
         $count ++;  
         my $acctype = 'allowfrom';  
         if ($count <= $numdenies) {  
             $acctype = 'denyfrom';  
         }  
         if ($pattern =~ /\*$/) {          if ($pattern =~ /\*$/) {
             #35.8.*              #35.8.*
             $pattern=~s/\*//;              $pattern=~s/\*//;
             if ($ip =~ /^\Q$pattern\E/) { $allowed=$access{$acctype}; }              if ($ip =~ /^\Q$pattern\E/) { $allowed=1; }
         } elsif ($pattern =~ /(\d+\.\d+\.\d+)\.\[(\d+)-(\d+)\]$/) {          } elsif ($pattern =~ /(\d+\.\d+\.\d+)\.\[(\d+)-(\d+)\]$/) {
             #35.8.3.[34-56]              #35.8.3.[34-56]
             my $low=$2;              my $low=$2;
Line 5158  sub check_ip_acc { Line 5124  sub check_ip_acc {
             $pattern=$1;              $pattern=$1;
             if ($ip =~ /^\Q$pattern\E/) {              if ($ip =~ /^\Q$pattern\E/) {
                 my $last=(split(/\./,$ip))[3];                  my $last=(split(/\./,$ip))[3];
                 if ($last <=$high && $last >=$low) { $allowed=$access{$acctype}; }                  if ($last <=$high && $last >=$low) { $allowed=1; }
             }              }
         } elsif ($pattern =~ /^\*/) {          } elsif ($pattern =~ /^\*/) {
             #*.msu.edu              #*.msu.edu
Line 5168  sub check_ip_acc { Line 5134  sub check_ip_acc {
                 my $netaddr=inet_aton($ip);                  my $netaddr=inet_aton($ip);
                 ($name)=gethostbyaddr($netaddr,AF_INET);                  ($name)=gethostbyaddr($netaddr,AF_INET);
             }              }
             if ($name =~ /\Q$pattern\E$/i) { $allowed=$access{$acctype}; }              if ($name =~ /\Q$pattern\E$/i) { $allowed=1; }
         } elsif ($pattern =~ /\d+\.\d+\.\d+\.\d+/) {          } elsif ($pattern =~ /\d+\.\d+\.\d+\.\d+/) {
             #127.0.0.1              #127.0.0.1
             if ($ip =~ /^\Q$pattern\E/) { $allowed=$access{$acctype}; }              if ($ip =~ /^\Q$pattern\E/) { $allowed=1; }
         } else {          } else {
             #some.name.com              #some.name.com
             if (!defined($name)) {              if (!defined($name)) {
Line 5179  sub check_ip_acc { Line 5145  sub check_ip_acc {
                 my $netaddr=inet_aton($ip);                  my $netaddr=inet_aton($ip);
                 ($name)=gethostbyaddr($netaddr,AF_INET);                  ($name)=gethostbyaddr($netaddr,AF_INET);
             }              }
             if ($name =~ /\Q$pattern\E$/i) { $allowed=$access{$acctype}; }              if ($name =~ /\Q$pattern\E$/i) { $allowed=1; }
         }  
         if ($allowed =~ /^(0|1)$/) { last; }  
     }  
     if ($allowed eq '') {  
         if ($numdenies && !$numallows) {  
             $allowed = 1;  
         } else {  
             $allowed = 0;  
         }          }
           if ($allowed) { last; }
     }      }
     return $allowed;      return $allowed;
 }  }
Line 8065  ADDMETA Line 8024  ADDMETA
                         my $newserver = &Apache::lonnet::spareserver(30000,undef,1,$dom_in_use);                          my $newserver = &Apache::lonnet::spareserver(30000,undef,1,$dom_in_use);
                         if (($newserver eq '') && ($offloadoth)) {                          if (($newserver eq '') && ($offloadoth)) {
                             my @domains = &Apache::lonnet::current_machine_domains();                              my @domains = &Apache::lonnet::current_machine_domains();
                             if (($dom_in_use ne '') && (!grep(/^\Q$dom_in_use\E$/,@domains))) {                              if (($dom_in_use ne '') && (!grep(/^\Q$dom_in_use\E$/,@domains))) { 
                                 ($newserver) = &Apache::lonnet::choose_server($dom_in_use);                                  ($newserver) = &Apache::lonnet::choose_server($dom_in_use);
                             }                              }
                         }                          }
Line 8082  ADDMETA Line 8041  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 8571  ENDLINK Line 8530  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 8582  sub modal_adhoc_script { Line 8549  sub modal_adhoc_script {
                 modalWindow.height = $height;                  modalWindow.height = $height;
                 modalWindow.content = '$content';                  modalWindow.content = '$content';
                 modalWindow.open();                  modalWindow.open();
                   $mathjax
         };            };  
 // ]]>  // ]]>
 </script>  </script>
Line 8589  ENDADHOC Line 8557  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 8598  sub modal_adhoc_inner { Line 8566  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 10459  sub sorted_inst_types { Line 10427  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 10474  sub get_institutional_codes { Line 10446  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 10483  sub get_institutional_codes { Line 10455  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 15173  sub check_clone { Line 15158  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 $clonetitle;      my $clonemsg;
     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 15182  sub check_clone { Line 15166  sub check_clone {
     }      }
     if ($clonehome eq 'no_host') {      if ($clonehome eq 'no_host') {
         if ($args->{'crstype'} eq 'Community') {          if ($args->{'crstype'} eq 'Community') {
             push(@clonemsg,({              $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'});
                               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 {
             push(@clonemsg,({              $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'});
                               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') {
                 push(@clonemsg,({                   $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'});
                                   mt => 'No new community created.',                  return ($can_clone, $clonemsg, $cloneid, $clonehome);
                                   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 15302  sub check_clone { Line 15264  sub check_clone {
             }              }
             unless ($can_clone) {              unless ($can_clone) {
                 if ($args->{'crstype'} eq 'Community') {                  if ($args->{'crstype'} eq 'Community') {
                     push(@clonemsg,({                      $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'});
                                       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 {
                     push(@clonemsg,({                      $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'});
                                       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,$clonetitle);      return ($can_clone, $clonemsg, $cloneid, $clonehome);
 }  }
   
 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,$callercontext,$user_lh) = @_;          $cnum,$category,$coderef) = @_;
     my ($outcome,$msgref,$clonemsgref);      my $outcome;
     my $linefeed =  '<br />'."\n";      my $linefeed =  '<br />'."\n";
     if ($context eq 'auto') {      if ($context eq 'auto') {
         $linefeed = "\n";          $linefeed = "\n";
Line 15338  sub construct_course { Line 15286  sub construct_course {
 #  #
 # Are we cloning?  # Are we cloning?
 #  #
     my ($can_clone,$cloneid,$clonehome,$clonetitle);      my ($can_clone, $clonemsg, $cloneid, $clonehome);
     if (($args->{'clonecourse'}) && ($args->{'clonedomain'})) {      if (($args->{'clonecourse'}) && ($args->{'clonedomain'})) {
  ($can_clone,$clonemsgref,$cloneid,$clonehome,$clonetitle) = &check_clone($args,$linefeed);   ($can_clone, $clonemsg, $cloneid, $clonehome) = &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,$clonemsgref);      return (0,$outcome);
  }   }
     }      }
   
Line 15360  sub construct_course { Line 15315  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.
     if (($callercontext eq 'auto') && ($user_lh ne '')) {      $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed;
         $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,$clonemsgref);          return (0,$outcome);
     }      }
   
 #  #
Line 15382  sub construct_course { Line 15332  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') {
         if (($callercontext eq 'auto') && ($user_lh ne '')) {          $outcome .= &mt('Course creation failed, unrecognized course home server.').$linefeed;
             $outcome .= &mt_user($user_lh,          return (0,$outcome);
                             '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) {
         push(@clonemsg,   $clonemsg = &mt('Cloning [_1] from [_2]',$crstype,$clonehome);
                       {   if ($context ne 'auto') {
                           mt => 'Created [_1] by cloning from [_2]',      $clonemsg = '<span class="LC_success">'.$clonemsg.'</span>';
                           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
         my @info =   &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'},$args->{'dateshift'});
     &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 15719  sub construct_course { Line 15655  sub construct_course {
         $outcome .= ($fatal?$errtext:'write ok').$linefeed;          $outcome .= ($fatal?$errtext:'write ok').$linefeed;
     }      }
   
     return (1,$outcome,\@clonemsg);      return (1,$outcome);
 }  }
   
 sub make_unique_code {  sub make_unique_code {
Line 16887  sub needs_coursereinit { Line 16823  sub needs_coursereinit {
         $interval = 600;          $interval = 600;
     }      }
     if (($now-$env{'request.course.timechecked'})>$interval) {      if (($now-$env{'request.course.timechecked'})>$interval) {
         &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);          my $lastchange = &Apache::lonnet::get_coursechange($cdom,$cnum);
           &Apache::lonnet::appenv({'request.course.timechecked'=>$now});
         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 17277  sub create_recaptcha { Line 17209  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();      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);
Line 17349  sub cleanup_html { Line 17281  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,$context) = @_;      my ($interval) = @_;
     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});
Line 17433  sub des_decrypt { Line 17349  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'));  
                     }  
                 }  
             }  
         }  
     }  
     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);
Removed from v.1.1075.2.141.2.14  
changed lines
  Added in v.1.1075.2.157

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