--- loncom/interface/loncommon.pm 2017/11/16 15:06:35 1.1075.2.127.2.4 +++ loncom/interface/loncommon.pm 2020/02/19 23:36:09 1.1075.2.127.6.2 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # a pile of common routines # -# $Id: loncommon.pm,v 1.1075.2.127.2.4 2017/11/16 15:06:35 raeburn Exp $ +# $Id: loncommon.pm,v 1.1075.2.127.6.2 2020/02/19 23:36:09 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -80,8 +80,6 @@ use JSON::DWIW; use LWP::UserAgent; use Crypt::DES; use DynaLoader; # for Crypt::DES version -use File::Copy(); -use File::Path(); # ---------------------------------------------- Designs use vars qw(%defaultdesign); @@ -4948,60 +4946,13 @@ sub check_ip_acc { if (!defined($acc) || $acc =~ /^\s*$/ || $acc =~/^\s*no\s*$/i) { 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 ($ip,$allowed); + if (($ENV{'REMOTE_ADDR'} eq '127.0.0.1') || + ($ENV{'REMOTE_ADDR'} eq &Apache::lonnet::get_host_ip($Apache::lonnet::perlvar{'lonHostID'}))) { + $ip = $env{'request.host'} || $ENV{'REMOTE_ADDR'} || $clientip; + } else { + $ip = $ENV{'REMOTE_ADDR'} || $env{'request.host'} || $clientip; } - my $allowed; - my $ip=$ENV{'REMOTE_ADDR'} || $clientip || $env{'request.host'}; my $name; my %access = ( @@ -5013,17 +4964,16 @@ sub check_slotip_acc { foreach my $item (split(',',$acc)) { $item =~ s/^\s*//; $item =~ s/\s*$//; - my $pattern; 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) { + } + my $numdenies = scalar(@denies); + my $numallows = scalar(@allows); + my $count = 0; + foreach my $pattern (@denies,@allows) { $count ++; my $acctype = 'allowfrom'; if ($count <= $numdenies) { @@ -12085,18 +12035,6 @@ sub decompress_uploaded_file { sub process_decompression { my ($docudom,$docuname,$file,$destination,$dir_root,$hiddenelem) = @_; - unless (($dir_root eq '/userfiles') && ($destination =~ m{^(docs|supplemental)/(default|\d+)/\d+$})) { - return '

'.&mt('Not extracted.').'
'. - &mt('Unexpected file path.').'

'."\n"; - } - unless (($docudom =~ /^$match_domain$/) && ($docuname =~ /^$match_courseid$/)) { - return '

'.&mt('Not extracted.').'
'. - &mt('Unexpected course context.').'

'."\n"; - } - unless ($file eq &Apache::lonnet::clean_filename($file)) { - return '

'.&mt('Not extracted.').'
'. - &mt('Filename contained unexpected characters.').'

'."\n"; - } my ($dir,$error,$warning,$output); if ($file !~ /\.(zip|tar|bz2|gz|tar.gz|tar.bz2|tgz)$/i) { $error = &mt('Filename not a supported archive file type.'). @@ -12131,44 +12069,30 @@ sub process_decompression { } } my $numskip = scalar(@to_skip); - my $numoverwrite = scalar(@to_overwrite); - if (($numskip) && (!$numoverwrite)) { + if (($numskip > 0) && + ($numskip == $env{'form.archive_itemcount'})) { $warning = &mt('All items in the archive file already exist, and no overwriting of existing files has been requested.'); } elsif ($dir eq '') { $error = &mt('Directory containing archive file unavailable.'); } elsif (!$error) { my ($decompressed,$display); - if (($numskip) || ($numoverwrite)) { + if ($numskip > 0) { my $tempdir = time.'_'.$$.int(rand(10000)); mkdir("$dir/$tempdir",0755); - if (&File::Copy::move("$dir/$file","$dir/$tempdir/$file")) { - ($decompressed,$display) = - &decompress_uploaded_file($file,"$dir/$tempdir"); - foreach my $item (@to_skip) { - if (($item ne '') && ($item !~ /\.\./)) { - if (-f "$dir/$tempdir/$item") { - unlink("$dir/$tempdir/$item"); - } elsif (-d "$dir/$tempdir/$item") { - &File::Path::remove_tree("$dir/$tempdir/$item",{ safe => 1 }); - } - } - } - 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"); - } + system("mv $dir/$file $dir/$tempdir/$file"); + ($decompressed,$display) = + &decompress_uploaded_file($file,"$dir/$tempdir"); + foreach my $item (@to_skip) { + if (($item ne '') && ($item !~ /\.\./)) { + if (-f "$dir/$tempdir/$item") { + unlink("$dir/$tempdir/$item"); + } elsif (-d "$dir/$tempdir/$item") { + system("rm -rf $dir/$tempdir/$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 { ($decompressed,$display) = &decompress_uploaded_file($file,$dir); @@ -12672,7 +12596,7 @@ END sub process_extracted_files { my ($context,$docudom,$docuname,$destination,$dir_root,$hiddenelem) = @_; my $numitems = $env{'form.archive_count'}; - return if ((!$numitems) || ($numitems =~ /\D/)); + return unless ($numitems); my @ids=&Apache::lonnet::current_machine_ids(); my ($prefix,$pathtocheck,$dir,$ishome,$error,$warning,%toplevelitems,%is_dir, %folders,%containers,%mapinner,%prompttofetch); @@ -12685,7 +12609,7 @@ sub process_extracted_files { } else { $prefix = $Apache::lonnet::perlvar{'lonDocRoot'}; $pathtocheck = "$dir_root/$docudom/$docuname/$destination"; - $dir = "$dir_root/$docudom/$docuname"; + $dir = "$dir_root/$docudom/$docuname"; } my $currdir = "$dir_root/$destination"; (my $docstype,$mapinner{'0'}) = ($destination =~ m{^(docs|supplemental)/(\w+)/}); @@ -12774,9 +12698,7 @@ sub process_extracted_files { '.'.$containers{$outer},1,1); $newseqid{$i} = $newidx; unless ($errtext) { - $result .= '
  • '.&mt('Folder: [_1] added to course', - &HTML::Entities::encode($docstitle,'<>&"')). - '
    • '."\n"; + $result .= '
  • '.&mt('Folder: [_1] added to course',$docstitle).'
    • '."\n"; } } } else { @@ -12785,47 +12707,38 @@ sub process_extracted_files { my $url = '/uploaded/'.$docudom.'/'.$docuname.'/'. $docstype.'/'.$mapinner{$outer}.'/'.$newidx.'/'. $title; - if (($outer !~ /\D/) && ($mapinner{$outer} !~ /\D/) && ($newidx !~ /\D/)) { - if (!-e "$prefix$dir/$docstype/$mapinner{$outer}") { - mkdir("$prefix$dir/$docstype/$mapinner{$outer}",0755); - } - if (!-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") { - mkdir("$prefix$dir/$docstype/$mapinner{$outer}/$newidx"); - } - if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") { - if (rename("$prefix$path","$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title")) { - $newdest{$i} = "$prefix$dir/$docstype/$mapinner{$outer}/$newidx"; - unless ($ishome) { - my $fetch = "$newdest{$i}/$title"; - $fetch =~ s/^\Q$prefix$dir\E//; - $prompttofetch{$fetch} = 1; - } - } + if (!-e "$prefix$dir/$docstype/$mapinner{$outer}") { + mkdir("$prefix$dir/$docstype/$mapinner{$outer}",0755); + } + if (!-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") { + mkdir("$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"); + $newdest{$i} = "$prefix$dir/$docstype/$mapinner{$outer}/$newidx"; + unless ($ishome) { + my $fetch = "$newdest{$i}/$title"; + $fetch =~ s/^\Q$prefix$dir\E//; + $prompttofetch{$fetch} = 1; } - $LONCAPA::map::resources[$newidx]= - $docstitle.':'.$url.':false:normal:res'; - push(@LONCAPA::map::order, $newidx); - my ($outtext,$errtext)= - &LONCAPA::map::storemap('/uploaded/'.$docudom.'/'. - $docuname.'/'.$folders{$outer}. - '.'.$containers{$outer},1,1); - unless ($errtext) { - if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title") { - $result .= '
  • '.&mt('File: [_1] added to course', - &HTML::Entities::encode($docstitle,'<>&"')). - '
    • '."\n"; - } + } + $LONCAPA::map::resources[$newidx]= + $docstitle.':'.$url.':false:normal:res'; + push(@LONCAPA::map::order, $newidx); + my ($outtext,$errtext)= + &LONCAPA::map::storemap('/uploaded/'.$docudom.'/'. + $docuname.'/'.$folders{$outer}. + '.'.$containers{$outer},1,1); + unless ($errtext) { + if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title") { + $result .= '
  • '.&mt('File: [_1] added to course',$docstitle).'
    • '."\n"; } - } else { - $warning .= &mt('Item extracted from archive: [_1] has unexpected path.', - &HTML::Entities::encode($path,'<>&"')).'
    '; } } } } } else { - $warning .= &mt('Item extracted from archive: [_1] has unexpected path.', - &HTML::Entities::encode($path,'<>&"')).'
    '; + $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',$path).'
    '; } } for (my $i=1; $i<=$numitems; $i++) { @@ -12886,9 +12799,7 @@ sub process_extracted_files { } if ($fullpath ne '') { if (-e "$prefix$path") { - unless (rename("$prefix$path","$fullpath/$title")) { - $warning .= &mt('Failed to rename dependency').'
    '; - } + system("mv $prefix$path $fullpath/$title"); } if (-e "$fullpath/$title") { my $showpath; @@ -12897,9 +12808,7 @@ sub process_extracted_files { } else { $showpath = "/$title"; } - $result .= '
  • '.&mt('[_1] included as a dependency', - &HTML::Entities::encode($showpath,'<>&"')). - '
    • '."\n"; + $result .= '
  • '.&mt('[_1] included as a dependency',$showpath).'
    • '."\n"; } unless ($ishome) { my $fetch = "$fullpath/$title"; @@ -12910,13 +12819,10 @@ sub process_extracted_files { } } elsif ($env{'form.archive_'.$referrer{$i}} eq 'discard') { $warning .= &mt('[_1] is a dependency of [_2], which was discarded.', - &HTML::Entities::encode($path,'<>&"'), - &HTML::Entities::encode($env{'form.archive_content_'.$referrer{$i}},'<>&"')). - '
    '; + $path,$env{'form.archive_content_'.$referrer{$i}}).'
    '; } } else { - $warning .= &mt('Item extracted from archive: [_1] has unexpected path.', - &HTML::Entities::encode($path)).'
    '; + $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',$path).'
    '; } } if (keys(%todelete)) { @@ -13190,10 +13096,8 @@ sub upfile_store { $env{'form.upfile'}=~s/\n+/\n/gs; $env{'form.upfile'}=~s/\n+$//gs; - my $datatoken = &valid_datatoken($env{'user.name'}.'_'.$env{'user.domain'}. - '_enroll_'.$env{'request.course.id'}.'_'. - time.'_'.$$); - return if ($datatoken eq ''); + my $datatoken=$env{'user.name'}.'_'.$env{'user.domain'}. + '_enroll_'.$env{'request.course.id'}.'_'.time.'_'.$$; { my $datafile = $r->dir_config('lonDaemons'). '/tmp/'.$datatoken.'.tmp'; @@ -13207,21 +13111,20 @@ sub upfile_store { =pod -=item * &load_tmp_file($r,$datatoken) +=item * &load_tmp_file($r) 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 =cut sub load_tmp_file { - my ($r,$datatoken) = @_; - return if ($datatoken eq ''); + my $r=shift; my @studentdata=(); { my $studentfile = $r->dir_config('lonDaemons'). - '/tmp/'.$datatoken.'.tmp'; + '/tmp/'.$env{'form.datatoken'}.'.tmp'; if ( open(my $fh,"<$studentfile") ) { @studentdata=<$fh>; close($fh); @@ -13230,14 +13133,6 @@ sub load_tmp_file { $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 =item * &upfile_record_sep() @@ -14126,13 +14021,6 @@ defdom (domain for which to retrieve con origmail (scalar - email address of recipient from loncapa.conf, 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. =back @@ -14142,7 +14030,7 @@ Returns: comma separated list of address ############################################################ ############################################################ sub build_recipient_list { - my ($defmail,$mailing,$defdom,$origmail,$requname,$requdom,$reqemail) = @_; + my ($defmail,$mailing,$defdom,$origmail) = @_; my @recipients; my ($otheremails,$lastresort,$allbcc,$addtext); my %domconfig = @@ -14183,99 +14071,11 @@ sub build_recipient_list { } elsif ($origmail ne '') { $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 '') { $lastresort = $origmail; } - if (($mailing eq 'helpdeskmail') && ($lastresort ne '')) { + if (($mailing eq 'helpdesk') && ($lastresort ne '')) { unless (grep(/^\Q$defdom\E$/,&Apache::lonnet::current_machine_domains())) { my $lonhost = $Apache::lonnet::perlvar{'lonHostID'}; my $machinedom = $Apache::lonnet::perlvar{'lonDefDomain'}; @@ -14355,7 +14155,7 @@ sub build_recipient_list { } } } - if ($mailing eq 'helpdeskmail') { + if ($mailing eq 'helpdesk') { if ((!@recipients) && ($lastresort ne '')) { push(@recipients,$lastresort); } @@ -15658,7 +15458,8 @@ sub init_user_environment { my %userenv = &Apache::lonnet::dump('environment',$domain,$username); 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); } if (($userenv{'interface'}) && (!$form->{'interface'})) {