[BACK]Return to loncommon.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / interface

Diff for /loncom/interface/loncommon.pm between versions 1.1075.2.127.2.9 and 1.1075.2.127.6.1

version 1.1075.2.127.2.9, 2020/05/25 16:46:58 version 1.1075.2.127.6.1, 2019/03/02 16:25:45
Line 80  use JSON::DWIW; Line 80  use JSON::DWIW;
 use LWP::UserAgent;  use LWP::UserAgent;
 use Crypt::DES;  use Crypt::DES;
 use DynaLoader; # for Crypt::DES version  use DynaLoader; # for Crypt::DES version
 use File::Copy();  
 use File::Path();  
 use String::CRC32();  
 use Short::URL();  
   
 # ---------------------------------------------- Designs  # ---------------------------------------------- Designs
 use vars qw(%defaultdesign);  use vars qw(%defaultdesign);
Line 198  BEGIN { Line 194  BEGIN {
     {      {
         my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}.          my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}.
                                    '/language.tab';                                     '/language.tab';
         if ( open(my $fh,'<',$langtabfile) ) {          if ( open(my $fh,"<$langtabfile") ) {
             while (my $line = <$fh>) {              while (my $line = <$fh>) {
                 next if ($line=~/^\#/);                  next if ($line=~/^\#/);
                 chomp($line);                  chomp($line);
Line 219  BEGIN { Line 215  BEGIN {
     {      {
         my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.          my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
                                   '/copyright.tab';                                    '/copyright.tab';
         if ( open (my $fh,'<',$copyrightfile) ) {          if ( open (my $fh,"<$copyrightfile") ) {
             while (my $line = <$fh>) {              while (my $line = <$fh>) {
                 next if ($line=~/^\#/);                  next if ($line=~/^\#/);
                 chomp($line);                  chomp($line);
Line 233  BEGIN { Line 229  BEGIN {
     {      {
         my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.          my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
                                   '/source_copyright.tab';                                    '/source_copyright.tab';
         if ( open (my $fh,'<',$sourcecopyrightfile) ) {          if ( open (my $fh,"<$sourcecopyrightfile") ) {
             while (my $line = <$fh>) {              while (my $line = <$fh>) {
                 next if ($line =~ /^\#/);                  next if ($line =~ /^\#/);
                 chomp($line);                  chomp($line);
Line 247  BEGIN { Line 243  BEGIN {
 # -------------------------------------------------------------- default domain designs  # -------------------------------------------------------------- default domain designs
     my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';      my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
     my $designfile = $designdir.'/default.tab';      my $designfile = $designdir.'/default.tab';
     if ( open (my $fh,'<',$designfile) ) {      if ( open (my $fh,"<$designfile") ) {
         while (my $line = <$fh>) {          while (my $line = <$fh>) {
             next if ($line =~ /^\#/);              next if ($line =~ /^\#/);
             chomp($line);              chomp($line);
Line 261  BEGIN { Line 257  BEGIN {
     {      {
         my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}.          my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}.
                                   '/filecategories.tab';                                    '/filecategories.tab';
         if ( open (my $fh,'<',$categoryfile) ) {          if ( open (my $fh,"<$categoryfile") ) {
     while (my $line = <$fh>) {      while (my $line = <$fh>) {
  next if ($line =~ /^\#/);   next if ($line =~ /^\#/);
  chomp($line);   chomp($line);
Line 276  BEGIN { Line 272  BEGIN {
     {      {
         my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}.          my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}.
                '/filetypes.tab';                 '/filetypes.tab';
         if ( open (my $fh,'<',$typesfile) ) {          if ( open (my $fh,"<$typesfile") ) {
             while (my $line = <$fh>) {              while (my $line = <$fh>) {
  next if ($line =~ /^\#/);   next if ($line =~ /^\#/);
  chomp($line);   chomp($line);
Line 4616  sub blockcheck { Line 4612  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 '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 4928  END_MYBLOCK Line 4923  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 'alert') {  
         $text = &mt('Checking Critical Messages Blocked');  
     } elsif ($activity eq 'reinit') {  
         $text = &mt('Checking Course Update Blocked');  
     }      }
     $output .= <<"END_BLOCK";      $output .= <<"END_BLOCK";
 <div class='$class'>  <div class='$class'>
Line 4955  sub check_ip_acc { Line 4946  sub check_ip_acc {
     if (!defined($acc) || $acc =~ /^\s*$/ || $acc =~/^\s*no\s*$/i) {      if (!defined($acc) || $acc =~ /^\s*$/ || $acc =~/^\s*no\s*$/i) {
         return 1;          return 1;
     }      }
     my $allowed=0;  
     my $ip=$ENV{'REMOTE_ADDR'} || $clientip || $env{'request.host'};  
   
     my $name;  
     foreach my $pattern (split(',',$acc)) {  
         $pattern =~ s/^\s*//;  
         $pattern =~ s/\s*$//;  
         if ($pattern =~ /\*$/) {  
             #35.8.*  
             $pattern=~s/\*//;  
             if ($ip =~ /^\Q$pattern\E/) { $allowed=1; }  
         } elsif ($pattern =~ /(\d+\.\d+\.\d+)\.\[(\d+)-(\d+)\]$/) {  
             #35.8.3.[34-56]  
             my $low=$2;  
             my $high=$3;  
             $pattern=$1;  
             if ($ip =~ /^\Q$pattern\E/) {  
                 my $last=(split(/\./,$ip))[3];  
                 if ($last <=$high && $last >=$low) { $allowed=1; }  
             }  
         } elsif ($pattern =~ /^\*/) {  
             #*.msu.edu  
             $pattern=~s/\*//;  
             if (!defined($name)) {  
                 use Socket;  
                 my $netaddr=inet_aton($ip);  
                 ($name)=gethostbyaddr($netaddr,AF_INET);  
             }  
             if ($name =~ /\Q$pattern\E$/i) { $allowed=1; }  
         } elsif ($pattern =~ /\d+\.\d+\.\d+\.\d+/) {  
             #127.0.0.1  
             if ($ip =~ /^\Q$pattern\E/) { $allowed=1; }  
         } else {  
             #some.name.com  
             if (!defined($name)) {  
                 use Socket;  
                 my $netaddr=inet_aton($ip);  
                 ($name)=gethostbyaddr($netaddr,AF_INET);  
             }  
             if ($name =~ /\Q$pattern\E$/i) { $allowed=1; }  
         }  
         if ($allowed) { last; }  
     }  
     return $allowed;  
 }  
   
 sub check_slotip_acc {  
     my ($acc,$clientip)=@_;  
     &Apache::lonxml::debug("acc is $acc");  
     if (!defined($acc) || $acc =~ /^\s*$/ || $acc =~/^\s*no\s*$/i) {  
         return 1;  
     }  
     my $allowed;      my $allowed;
     my $ip=$ENV{'REMOTE_ADDR'} || $clientip || $env{'request.host'};      my $ip=$ENV{'REMOTE_ADDR'} || $clientip || $env{'request.host'};
   
Line 5020  sub check_slotip_acc { Line 4959  sub check_slotip_acc {
     foreach my $item (split(',',$acc)) {      foreach my $item (split(',',$acc)) {
         $item =~ s/^\s*//;          $item =~ s/^\s*//;
         $item =~ s/\s*$//;          $item =~ s/\s*$//;
         my $pattern;  
         if ($item =~ /^\!(.+)$/) {          if ($item =~ /^\!(.+)$/) {
             push(@denies,$1);              push(@denies,$1);
         } else {          } else {
             push(@allows,$item);              push(@allows,$item);
         }          }
    }      }
    my $numdenies = scalar(@denies);      my $numdenies = scalar(@denies);
    my $numallows = scalar(@allows);      my $numallows = scalar(@allows);
    my $count = 0;      my $count = 0;
    foreach my $pattern (@denies,@allows) {      foreach my $pattern (@denies,@allows) {
         $count ++;          $count ++;
         my $acctype = 'allowfrom';          my $acctype = 'allowfrom';
         if ($count <= $numdenies) {          if ($count <= $numdenies) {
Line 5222  sub get_legacy_domconf { Line 5160  sub get_legacy_domconf {
     my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';      my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
     my $designfile =  $designdir.'/'.$udom.'.tab';      my $designfile =  $designdir.'/'.$udom.'.tab';
     if (-e $designfile) {      if (-e $designfile) {
         if ( open (my $fh,'<',$designfile) ) {          if ( open (my $fh,"<$designfile") ) {
             while (my $line = <$fh>) {              while (my $line = <$fh>) {
                 next if ($line =~ /^\#/);                  next if ($line =~ /^\#/);
                 chomp($line);                  chomp($line);
Line 11510  sub modify_html_refs { Line 11448  sub modify_html_refs {
                 return;                  return;
             }              }
         }           } 
         if (open(my $fh,'<',$container)) {          if (open(my $fh,"<$container")) {
             $content = join('', <$fh>);              $content = join('', <$fh>);
             close($fh);              close($fh);
         } else {          } else {
Line 11575  sub modify_html_refs { Line 11513  sub modify_html_refs {
                         }                          }
                     }                      }
                 } else {                  } else {
                     if (open(my $fh,'>',$container)) {                      if (open(my $fh,">$container")) {
                         print $fh $content;                          print $fh $content;
                         close($fh);                          close($fh);
                         $output = '<p>'.&mt('Updated [quant,_1,reference] in [_2].',                          $output = '<p>'.&mt('Updated [quant,_1,reference] in [_2].',
Line 12092  sub decompress_uploaded_file { Line 12030  sub decompress_uploaded_file {
   
 sub process_decompression {  sub process_decompression {
     my ($docudom,$docuname,$file,$destination,$dir_root,$hiddenelem) = @_;      my ($docudom,$docuname,$file,$destination,$dir_root,$hiddenelem) = @_;
     unless (($dir_root eq '/userfiles') && ($destination =~ m{^(docs|supplemental)/(default|\d+)/\d+$})) {  
         return '<p class="LC_error">'.&mt('Not extracted.').'<br />'.  
                &mt('Unexpected file path.').'</p>'."\n";  
     }  
     unless (($docudom =~ /^$match_domain$/) && ($docuname =~ /^$match_courseid$/)) {  
         return '<p class="LC_error">'.&mt('Not extracted.').'<br />'.  
                &mt('Unexpected course context.').'</p>'."\n";  
     }  
     unless ($file eq &Apache::lonnet::clean_filename($file)) {  
         return '<p class="LC_error">'.&mt('Not extracted.').'<br />'.  
                &mt('Filename contained unexpected characters.').'</p>'."\n";  
     }  
     my ($dir,$error,$warning,$output);      my ($dir,$error,$warning,$output);
     if ($file !~ /\.(zip|tar|bz2|gz|tar.gz|tar.bz2|tgz)$/i) {      if ($file !~ /\.(zip|tar|bz2|gz|tar.gz|tar.bz2|tgz)$/i) {
         $error = &mt('Filename not a supported archive file type.').          $error = &mt('Filename not a supported archive file type.').
Line 12138  sub process_decompression { Line 12064  sub process_decompression {
                 }                  }
             }              }
             my $numskip = scalar(@to_skip);              my $numskip = scalar(@to_skip);
             my $numoverwrite = scalar(@to_overwrite);              if (($numskip > 0) && 
             if (($numskip) && (!$numoverwrite)) {                  ($numskip == $env{'form.archive_itemcount'})) {
                 $warning = &mt('All items in the archive file already exist, and no overwriting of existing files has been requested.');                           $warning = &mt('All items in the archive file already exist, and no overwriting of existing files has been requested.');         
             } elsif ($dir eq '') {              } elsif ($dir eq '') {
                 $error = &mt('Directory containing archive file unavailable.');                  $error = &mt('Directory containing archive file unavailable.');
             } elsif (!$error) {              } elsif (!$error) {
                 my ($decompressed,$display);                  my ($decompressed,$display);
                 if (($numskip) || ($numoverwrite)) {                  if ($numskip > 0) {
                     my $tempdir = time.'_'.$$.int(rand(10000));                      my $tempdir = time.'_'.$$.int(rand(10000));
                     mkdir("$dir/$tempdir",0755);                      mkdir("$dir/$tempdir",0755);
                     if (&File::Copy::move("$dir/$file","$dir/$tempdir/$file")) {                      system("mv $dir/$file $dir/$tempdir/$file");
                         ($decompressed,$display) =                      ($decompressed,$display) = 
                             &decompress_uploaded_file($file,"$dir/$tempdir");                          &decompress_uploaded_file($file,"$dir/$tempdir");
                         foreach my $item (@to_skip) {                      foreach my $item (@to_skip) {
                             if (($item ne '') && ($item !~ /\.\./)) {                          if (($item ne '') && ($item !~ /\.\./)) {
                                 if (-f "$dir/$tempdir/$item") {                              if (-f "$dir/$tempdir/$item") { 
                                     unlink("$dir/$tempdir/$item");                                  unlink("$dir/$tempdir/$item");
                                 } elsif (-d "$dir/$tempdir/$item") {                              } elsif (-d "$dir/$tempdir/$item") {
                                     &File::Path::remove_tree("$dir/$tempdir/$item",{ safe => 1 });                                  system("rm -rf $dir/$tempdir/$item");
                                 }  
                             }  
                         }  
                         foreach my $item (@to_overwrite) {  
                             if ((-e "$dir/$tempdir/$item") && (-e "$dir/$item")) {  
                                 if (($item ne '') && ($item !~ /\.\./)) {  
                                     if (-f "$dir/$item") {  
                                         unlink("$dir/$item");  
                                     } elsif (-d "$dir/$item") {  
                                         &File::Path::remove_tree("$dir/$item",{ safe => 1 });  
                                     }  
                                     &File::Copy::move("$dir/$tempdir/$item","$dir/$item");  
                                 }  
                             }                              }
                         }                          }
                         if (&File::Copy::move("$dir/$tempdir/$file","$dir/$file")) {  
                             &File::Path::remove_tree("$dir/$tempdir",{ safe => 1 });  
                         }  
                     }                      }
                       system("mv $dir/$tempdir/* $dir");
                       rmdir("$dir/$tempdir");   
                 } else {                  } else {
                     ($decompressed,$display) =                       ($decompressed,$display) = 
                         &decompress_uploaded_file($file,$dir);                          &decompress_uploaded_file($file,$dir);
Line 12679  END Line 12591  END
 sub process_extracted_files {  sub process_extracted_files {
     my ($context,$docudom,$docuname,$destination,$dir_root,$hiddenelem) = @_;      my ($context,$docudom,$docuname,$destination,$dir_root,$hiddenelem) = @_;
     my $numitems = $env{'form.archive_count'};      my $numitems = $env{'form.archive_count'};
     return if ((!$numitems) || ($numitems =~ /\D/));      return unless ($numitems);
     my @ids=&Apache::lonnet::current_machine_ids();      my @ids=&Apache::lonnet::current_machine_ids();
     my ($prefix,$pathtocheck,$dir,$ishome,$error,$warning,%toplevelitems,%is_dir,      my ($prefix,$pathtocheck,$dir,$ishome,$error,$warning,%toplevelitems,%is_dir,
         %folders,%containers,%mapinner,%prompttofetch);          %folders,%containers,%mapinner,%prompttofetch);
Line 12692  sub process_extracted_files { Line 12604  sub process_extracted_files {
     } else {      } else {
         $prefix = $Apache::lonnet::perlvar{'lonDocRoot'};          $prefix = $Apache::lonnet::perlvar{'lonDocRoot'};
         $pathtocheck = "$dir_root/$docudom/$docuname/$destination";          $pathtocheck = "$dir_root/$docudom/$docuname/$destination";
         $dir = "$dir_root/$docudom/$docuname";          $dir = "$dir_root/$docudom/$docuname";    
     }      }
     my $currdir = "$dir_root/$destination";      my $currdir = "$dir_root/$destination";
     (my $docstype,$mapinner{'0'}) = ($destination =~ m{^(docs|supplemental)/(\w+)/});      (my $docstype,$mapinner{'0'}) = ($destination =~ m{^(docs|supplemental)/(\w+)/});
Line 12781  sub process_extracted_files { Line 12693  sub process_extracted_files {
                                                         '.'.$containers{$outer},1,1);                                                          '.'.$containers{$outer},1,1);
                             $newseqid{$i} = $newidx;                              $newseqid{$i} = $newidx;
                             unless ($errtext) {                              unless ($errtext) {
                                 $result .=  '<li>'.&mt('Folder: [_1] added to course',                                  $result .=  '<li>'.&mt('Folder: [_1] added to course',$docstitle).'</li>'."\n";
                                                        &HTML::Entities::encode($docstitle,'<>&"')).  
                                             '</li>'."\n";  
                             }                              }
                         }                          }
                     } else {                      } else {
Line 12792  sub process_extracted_files { Line 12702  sub process_extracted_files {
                             my $url = '/uploaded/'.$docudom.'/'.$docuname.'/'.                              my $url = '/uploaded/'.$docudom.'/'.$docuname.'/'.
                                       $docstype.'/'.$mapinner{$outer}.'/'.$newidx.'/'.                                        $docstype.'/'.$mapinner{$outer}.'/'.$newidx.'/'.
                                       $title;                                        $title;
                             if (($outer !~ /\D/) && ($mapinner{$outer} !~ /\D/) && ($newidx !~ /\D/)) {                              if (!-e "$prefix$dir/$docstype/$mapinner{$outer}") {
                                 if (!-e "$prefix$dir/$docstype/$mapinner{$outer}") {                                  mkdir("$prefix$dir/$docstype/$mapinner{$outer}",0755);
                                     mkdir("$prefix$dir/$docstype/$mapinner{$outer}",0755);                              }
                                 }                              if (!-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") {
                                 if (!-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") {                                  mkdir("$prefix$dir/$docstype/$mapinner{$outer}/$newidx");
                                     mkdir("$prefix$dir/$docstype/$mapinner{$outer}/$newidx");                              }
                                 }                              if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") {
                                 if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") {                                  system("mv $prefix$path $prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title");
                                     if (rename("$prefix$path","$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title")) {                                  $newdest{$i} = "$prefix$dir/$docstype/$mapinner{$outer}/$newidx";
                                         $newdest{$i} = "$prefix$dir/$docstype/$mapinner{$outer}/$newidx";                                  unless ($ishome) {
                                         unless ($ishome) {                                      my $fetch = "$newdest{$i}/$title";
                                             my $fetch = "$newdest{$i}/$title";                                      $fetch =~ s/^\Q$prefix$dir\E//;
                                             $fetch =~ s/^\Q$prefix$dir\E//;                                      $prompttofetch{$fetch} = 1;
                                             $prompttofetch{$fetch} = 1;  
                                         }  
                                     }  
                                 }                                  }
                                 $LONCAPA::map::resources[$newidx]=                              }
                                     $docstitle.':'.$url.':false:normal:res';                              $LONCAPA::map::resources[$newidx]=
                                 push(@LONCAPA::map::order, $newidx);                                  $docstitle.':'.$url.':false:normal:res';
                                 my ($outtext,$errtext)=                              push(@LONCAPA::map::order, $newidx);
                                     &LONCAPA::map::storemap('/uploaded/'.$docudom.'/'.                              my ($outtext,$errtext)=
                                                             $docuname.'/'.$folders{$outer}.                                  &LONCAPA::map::storemap('/uploaded/'.$docudom.'/'.
                                                             '.'.$containers{$outer},1,1);                                                          $docuname.'/'.$folders{$outer}.
                                 unless ($errtext) {                                                          '.'.$containers{$outer},1,1);
                                     if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title") {                              unless ($errtext) {
                                         $result .= '<li>'.&mt('File: [_1] added to course',                                  if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title") {
                                                               &HTML::Entities::encode($docstitle,'<>&"')).                                      $result .= '<li>'.&mt('File: [_1] added to course',$docstitle).'</li>'."\n";
                                                    '</li>'."\n";  
                                     }  
                                 }                                  }
                             } else {  
                                 $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',  
                                                 &HTML::Entities::encode($path,'<>&"')).'<br />';  
                             }                              }
                         }                          }
                     }                      }
                 }                  }
             } else {              } else {
                 $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',                  $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',$path).'<br />';
                                 &HTML::Entities::encode($path,'<>&"')).'<br />';  
             }              }
         }          }
         for (my $i=1; $i<=$numitems; $i++) {          for (my $i=1; $i<=$numitems; $i++) {
Line 12893  sub process_extracted_files { Line 12794  sub process_extracted_files {
                         }                          }
                         if ($fullpath ne '') {                          if ($fullpath ne '') {
                             if (-e "$prefix$path") {                              if (-e "$prefix$path") {
                                 unless (rename("$prefix$path","$fullpath/$title")) {                                  system("mv $prefix$path $fullpath/$title");
                                      $warning .= &mt('Failed to rename dependency').'<br />';  
                                 }  
                             }                              }
                             if (-e "$fullpath/$title") {                              if (-e "$fullpath/$title") {
                                 my $showpath;                                  my $showpath;
Line 12904  sub process_extracted_files { Line 12803  sub process_extracted_files {
                                 } else {                                  } else {
                                     $showpath = "/$title";                                      $showpath = "/$title";
                                 }                                  }
                                 $result .= '<li>'.&mt('[_1] included as a dependency',                                  $result .= '<li>'.&mt('[_1] included as a dependency',$showpath).'</li>'."\n";
                                                       &HTML::Entities::encode($showpath,'<>&"')).  
                                            '</li>'."\n";  
                             }                              }
                             unless ($ishome) {                              unless ($ishome) {
                                 my $fetch = "$fullpath/$title";                                  my $fetch = "$fullpath/$title";
Line 12917  sub process_extracted_files { Line 12814  sub process_extracted_files {
                     }                      }
                 } elsif ($env{'form.archive_'.$referrer{$i}} eq 'discard') {                  } elsif ($env{'form.archive_'.$referrer{$i}} eq 'discard') {
                     $warning .= &mt('[_1] is a dependency of [_2], which was discarded.',                      $warning .= &mt('[_1] is a dependency of [_2], which was discarded.',
                                     &HTML::Entities::encode($path,'<>&"'),                                      $path,$env{'form.archive_content_'.$referrer{$i}}).'<br />';
                                     &HTML::Entities::encode($env{'form.archive_content_'.$referrer{$i}},'<>&"')).  
                                 '<br />';  
                 }                  }
             } else {              } else {
                 $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',                  $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',$path).'<br />';
                                 &HTML::Entities::encode($path)).'<br />';  
             }              }
         }          }
         if (keys(%todelete)) {          if (keys(%todelete)) {
Line 13197  sub upfile_store { Line 13091  sub upfile_store {
     $env{'form.upfile'}=~s/\n+/\n/gs;      $env{'form.upfile'}=~s/\n+/\n/gs;
     $env{'form.upfile'}=~s/\n+$//gs;      $env{'form.upfile'}=~s/\n+$//gs;
   
     my $datatoken = &valid_datatoken($env{'user.name'}.'_'.$env{'user.domain'}.      my $datatoken=$env{'user.name'}.'_'.$env{'user.domain'}.
                              '_enroll_'.$env{'request.course.id'}.'_'.   '_enroll_'.$env{'request.course.id'}.'_'.time.'_'.$$;
                                      time.'_'.$$);  
     return if ($datatoken eq '');  
     {      {
         my $datafile = $r->dir_config('lonDaemons').          my $datafile = $r->dir_config('lonDaemons').
                            '/tmp/'.$datatoken.'.tmp';                             '/tmp/'.$datatoken.'.tmp';
         if ( open(my $fh,'>',$datafile) ) {          if ( open(my $fh,">$datafile") ) {
             print $fh $env{'form.upfile'};              print $fh $env{'form.upfile'};
             close($fh);              close($fh);
         }          }
Line 13214  sub upfile_store { Line 13106  sub upfile_store {
   
 =pod  =pod
   
 =item * &load_tmp_file($r,$datatoken)  =item * &load_tmp_file($r)
   
 Load uploaded file from tmp, $r should be the HTTP Request object,  Load uploaded file from tmp, $r should be the HTTP Request object,
 $datatoken is the name to assign to the temporary file.  needs $env{'form.datatoken'},
 sets $env{'form.upfile'} to the contents of the file  sets $env{'form.upfile'} to the contents of the file
   
 =cut  =cut
   
 sub load_tmp_file {  sub load_tmp_file {
     my ($r,$datatoken) = @_;      my $r=shift;
     return if ($datatoken eq '');  
     my @studentdata=();      my @studentdata=();
     {      {
         my $studentfile = $r->dir_config('lonDaemons').          my $studentfile = $r->dir_config('lonDaemons').
                               '/tmp/'.$datatoken.'.tmp';                                '/tmp/'.$env{'form.datatoken'}.'.tmp';
         if ( open(my $fh,'<',$studentfile) ) {          if ( open(my $fh,"<$studentfile") ) {
             @studentdata=<$fh>;              @studentdata=<$fh>;
             close($fh);              close($fh);
         }          }
Line 13237  sub load_tmp_file { Line 13128  sub load_tmp_file {
     $env{'form.upfile'}=join('',@studentdata);      $env{'form.upfile'}=join('',@studentdata);
 }  }
   
 sub valid_datatoken {  
     my ($datatoken) = @_;  
     if ($datatoken =~ /^$match_username\_$match_domain\_enroll_(|$match_domain\_$match_courseid)\_\d+_\d+$/) {  
         return $datatoken;  
     }  
     return;  
 }  
   
 =pod  =pod
   
 =item * &upfile_record_sep()  =item * &upfile_record_sep()
Line 14133  defdom (domain for which to retrieve con Line 14016  defdom (domain for which to retrieve con
 origmail (scalar - email address of recipient from loncapa.conf,  origmail (scalar - email address of recipient from loncapa.conf,
 i.e., predates configuration by DC via domainprefs.pm  i.e., predates configuration by DC via domainprefs.pm
   
 $requname username of requester (if mailing type is helpdeskmail)  
   
 $requdom domain of requester (if mailing type is helpdeskmail)  
   
 $reqemail e-mail address of requester (if mailing type is helpdeskmail)  
   
   
 Returns: comma separated list of addresses to which to send e-mail.  Returns: comma separated list of addresses to which to send e-mail.
   
 =back  =back
Line 14149  Returns: comma separated list of address Line 14025  Returns: comma separated list of address
 ############################################################  ############################################################
 ############################################################  ############################################################
 sub build_recipient_list {  sub build_recipient_list {
     my ($defmail,$mailing,$defdom,$origmail,$requname,$requdom,$reqemail) = @_;      my ($defmail,$mailing,$defdom,$origmail) = @_;
     my @recipients;      my @recipients;
     my ($otheremails,$lastresort,$allbcc,$addtext);      my ($otheremails,$lastresort,$allbcc,$addtext);
     my %domconfig =      my %domconfig =
Line 14190  sub build_recipient_list { Line 14066  sub build_recipient_list {
         } elsif ($origmail ne '') {          } elsif ($origmail ne '') {
             $lastresort = $origmail;              $lastresort = $origmail;
         }          }
         if ($mailing eq 'helpdeskmail') {  
             if ((ref($domconfig{'contacts'}{'overrides'}) eq 'HASH') &&  
                 (keys(%{$domconfig{'contacts'}{'overrides'}}))) {  
                 my ($inststatus,$inststatus_checked);  
                 if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '') &&  
                     ($env{'user.domain'} ne 'public')) {  
                     $inststatus_checked = 1;  
                     $inststatus = $env{'environment.inststatus'};  
                 }  
                 unless ($inststatus_checked) {  
                     if (($requname ne '') && ($requdom ne '')) {  
                         if (($requname =~ /^$match_username$/) &&  
                             ($requdom =~ /^$match_domain$/) &&  
                             (&Apache::lonnet::domain($requdom))) {  
                             my $requhome = &Apache::lonnet::homeserver($requname,  
                                                                       $requdom);  
                             unless ($requhome eq 'no_host') {  
                                 my %userenv = &Apache::lonnet::userenvironment($requdom,$requname,'inststatus');  
                                 $inststatus = $userenv{'inststatus'};  
                                 $inststatus_checked = 1;  
                             }  
                         }  
                     }  
                 }  
                 unless ($inststatus_checked) {  
                     if ($reqemail =~ /^[^\@]+\@[^\@]+$/) {  
                         my %srch = (srchby     => 'email',  
                                     srchdomain => $defdom,  
                                     srchterm   => $reqemail,  
                                     srchtype   => 'exact');  
                         my %srch_results = &Apache::lonnet::usersearch(\%srch);  
                         foreach my $uname (keys(%srch_results)) {  
                             if (ref($srch_results{$uname}{'inststatus'}) eq 'ARRAY') {  
                                 $inststatus = join(',',@{$srch_results{$uname}{'inststatus'}});  
                                 $inststatus_checked = 1;  
                                 last;  
                             }  
                         }  
                         unless ($inststatus_checked) {  
                             my ($dirsrchres,%srch_results) = &Apache::lonnet::inst_directory_query(\%srch);  
                             if ($dirsrchres eq 'ok') {  
                                 foreach my $uname (keys(%srch_results)) {  
                                     if (ref($srch_results{$uname}{'inststatus'}) eq 'ARRAY') {  
                                         $inststatus = join(',',@{$srch_results{$uname}{'inststatus'}});  
                                         $inststatus_checked = 1;  
                                         last;  
                                     }  
                                 }  
                             }  
                         }  
                     }  
                 }  
                 if ($inststatus ne '') {  
                     foreach my $status (split(/\:/,$inststatus)) {  
                         if (ref($domconfig{'contacts'}{'overrides'}{$status}) eq 'HASH') {  
                             my @contacts = ('adminemail','supportemail');  
                             foreach my $item (@contacts) {  
                                 if ($domconfig{'contacts'}{'overrides'}{$status}{$item}) {  
                                     my $addr = $domconfig{'contacts'}{'overrides'}{$status};  
                                     if (!grep(/^\Q$addr\E$/,@recipients)) {  
                                         push(@recipients,$addr);  
                                     }  
                                 }  
                             }  
                             $otheremails = $domconfig{'contacts'}{'overrides'}{$status}{'others'};  
                             if ($domconfig{'contacts'}{'overrides'}{$status}{'bcc'}) {  
                                 my @bccs = split(/,/,$domconfig{'contacts'}{'overrides'}{$status}{'bcc'});  
                                 my @ok_bccs;  
                                 foreach my $bcc (@bccs) {  
                                     $bcc =~ s/^\s+//g;  
                                     $bcc =~ s/\s+$//g;  
                                     if ($bcc =~ m/^[^\@]+\@[^\@]+$/) {  
                                         if (!(grep(/^\Q$bcc\E$/,@ok_bccs))) {  
                                             push(@ok_bccs,$bcc);  
                                         }  
                                     }  
                                 }  
                                 if (@ok_bccs > 0) {  
                                     $allbcc = join(', ',@ok_bccs);  
                                 }  
                             }  
                             $addtext = $domconfig{'contacts'}{'overrides'}{$status}{'include'};  
                             last;  
                         }  
                     }  
                 }  
             }  
         }  
     } elsif ($origmail ne '') {      } elsif ($origmail ne '') {
         $lastresort = $origmail;          $lastresort = $origmail;
     }      }
   
     if (($mailing eq 'helpdeskmail') && ($lastresort ne '')) {      if (($mailing eq 'helpdesk') && ($lastresort ne '')) {
         unless (grep(/^\Q$defdom\E$/,&Apache::lonnet::current_machine_domains())) {          unless (grep(/^\Q$defdom\E$/,&Apache::lonnet::current_machine_domains())) {
             my $lonhost = $Apache::lonnet::perlvar{'lonHostID'};              my $lonhost = $Apache::lonnet::perlvar{'lonHostID'};
             my $machinedom = $Apache::lonnet::perlvar{'lonDefDomain'};              my $machinedom = $Apache::lonnet::perlvar{'lonDefDomain'};
Line 14362  sub build_recipient_list { Line 14150  sub build_recipient_list {
             }              }
         }          }
     }      }
     if ($mailing eq 'helpdeskmail') {      if ($mailing eq 'helpdesk') {
         if ((!@recipients) && ($lastresort ne '')) {          if ((!@recipients) && ($lastresort ne '')) {
             push(@recipients,$lastresort);              push(@recipients,$lastresort);
         }          }
Line 15665  sub init_user_environment { Line 15453  sub init_user_environment {
   
     my %userenv = &Apache::lonnet::dump('environment',$domain,$username);      my %userenv = &Apache::lonnet::dump('environment',$domain,$username);
     my ($tmp) = keys(%userenv);      my ($tmp) = keys(%userenv);
     if ($tmp =~ /^(con_lost|error|no_such_host)/i) {      if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
       } else {
  undef(%userenv);   undef(%userenv);
     }      }
     if (($userenv{'interface'}) && (!$form->{'interface'})) {      if (($userenv{'interface'}) && (!$form->{'interface'})) {
Line 16558  sub needs_coursereinit { Line 16347  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 16998  sub cleanup_html { Line 16783  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 17082  sub des_decrypt { Line 16851  sub des_decrypt {
     return $plaintext;      return $plaintext;
 }  }
   
 sub make_short_symbs {  
     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);  
         my %tocreate;  
         if (keys(%resources)) {  
             foreach my $item (sort {$a <=> $b} (@toshorten)) {  
                 my $symb = $resources{$item};  
                 if ($symb) {  
                     $tocreate{$cnum.'&'.$symb} = 1;  
                 }  
             }  
         }  
         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;  
             my $lockhash = {  
                                 "lock\0$now" => $env{'user.name'}.  
                                                 ':'.$env{'user.domain'},  
                             };  
             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;  
             }  
         }  
     }  
     return $init;  
 }  
   
 1;  1;
 __END__;  __END__;
   
Removed from v.1.1075.2.127.2.9  
changed lines
  Added in v.1.1075.2.127.6.1

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