[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.12 and 1.1075.2.149

version 1.1075.2.141.2.12, 2021/01/04 17:29:30 version 1.1075.2.149, 2020/11/12 01:18:26
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();           $ip = $ENV{'REMOTE_ADDR'} || $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 5123  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 5133  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 5144  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 15159  sub check_clone { Line 15117  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 15168  sub check_clone { Line 15125  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 15288  sub check_clone { Line 15223  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 15324  sub construct_course { Line 15245  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 15346  sub construct_course { Line 15274  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 15368  sub construct_course { Line 15291  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 15705  sub construct_course { Line 15614  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 15976  sub init_user_environment { Line 15885  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 15995  sub init_user_environment { Line 15903  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"       => $ip,);       "request.host"       => $ENV{'REMOTE_ADDR'},);
   
         if ($form->{'localpath'}) {          if ($form->{'localpath'}) {
     $initial_env{"browser.localpath"}  = $form->{'localpath'};      $initial_env{"browser.localpath"}  = $form->{'localpath'};
Line 16855  sub needs_coursereinit { Line 16763  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 17245  sub create_recaptcha { Line 17149  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 => $ip,                       remoteip => $ENV{'REMOTE_ADDR'},
                    );                     );
         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 17268  sub check_recaptcha { Line 17171  sub check_recaptcha {
         my $captcha_result =          my $captcha_result =
             $captcha->check_answer(              $captcha->check_answer(
                                     $privkey,                                      $privkey,
                                     $ip,                                      $ENV{'REMOTE_ADDR'},
                                     $env{'form.recaptcha_challenge_field'},                                      $env{'form.recaptcha_challenge_field'},
                                     $env{'form.recaptcha_response_field'},                                      $env{'form.recaptcha_response_field'},
                                   );                                    );
Line 17317  sub cleanup_html { Line 17220  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 17401  sub des_decrypt { Line 17288  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.12  
changed lines
  Added in v.1.1075.2.149

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