--- loncom/interface/loncommon.pm 2017/11/01 02:54:35 1.1075.2.127.2.3 +++ loncom/interface/loncommon.pm 2018/09/09 21:30:40 1.1075.2.130 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # a pile of common routines # -# $Id: loncommon.pm,v 1.1075.2.127.2.3 2017/11/01 02:54:35 raeburn Exp $ +# $Id: loncommon.pm,v 1.1075.2.130 2018/09/09 21:30:40 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -81,7 +81,7 @@ use LWP::UserAgent; use Crypt::DES; use DynaLoader; # for Crypt::DES version use File::Copy(); -use File::Path::Tiny(); +use File::Path(); # ---------------------------------------------- Designs use vars qw(%defaultdesign); @@ -196,7 +196,7 @@ BEGIN { { my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}. '/language.tab'; - if ( open(my $fh,"<$langtabfile") ) { + if ( open(my $fh,'<',$langtabfile) ) { while (my $line = <$fh>) { next if ($line=~/^\#/); chomp($line); @@ -217,7 +217,7 @@ BEGIN { { my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. '/copyright.tab'; - if ( open (my $fh,"<$copyrightfile") ) { + if ( open (my $fh,'<',$copyrightfile) ) { while (my $line = <$fh>) { next if ($line=~/^\#/); chomp($line); @@ -231,7 +231,7 @@ BEGIN { { my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. '/source_copyright.tab'; - if ( open (my $fh,"<$sourcecopyrightfile") ) { + if ( open (my $fh,'<',$sourcecopyrightfile) ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); @@ -245,7 +245,7 @@ BEGIN { # -------------------------------------------------------------- default domain designs my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors'; my $designfile = $designdir.'/default.tab'; - if ( open (my $fh,"<$designfile") ) { + if ( open (my $fh,'<',$designfile) ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); @@ -259,7 +259,7 @@ BEGIN { { my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}. '/filecategories.tab'; - if ( open (my $fh,"<$categoryfile") ) { + if ( open (my $fh,'<',$categoryfile) ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); @@ -274,7 +274,7 @@ BEGIN { { my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}. '/filetypes.tab'; - if ( open (my $fh,"<$typesfile") ) { + if ( open (my $fh,'<',$typesfile) ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); @@ -2262,7 +2262,11 @@ sub select_form { if ($onchange) { $onchange = ' onchange="'.$onchange.'"'; } - my $selectform = "\n"; my @keys; if (exists($hashref->{'select_form_order'})) { @keys=@{$hashref->{'select_form_order'}}; @@ -4720,7 +4724,7 @@ sub blockcheck { ($env{'request.role'} !~ m{^st\./\Q$cdom\E/\Q$cnum\E})); next if ($no_userblock); - # Retrieve blocking times and identity of locker for course + # Retrieve blocking times and identity of blocker for course # of specified user, unless user has 'evb' privilege. my ($start,$end,$trigger) = @@ -4994,87 +4998,6 @@ sub check_ip_acc { 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 $ip=$ENV{'REMOTE_ADDR'} || $clientip || $env{'request.host'}; - - my $name; - my %access = ( - allowfrom => 1, - denyfrom => 0, - ); - my @allows; - my @denies; - 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) { - $count ++; - my $acctype = 'allowfrom'; - if ($count <= $numdenies) { - $acctype = 'denyfrom'; - } - if ($pattern =~ /\*$/) { - #35.8.* - $pattern=~s/\*//; - if ($ip =~ /^\Q$pattern\E/) { $allowed=$access{$acctype}; } - } 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=$access{$acctype}; } - } - } 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=$access{$acctype}; } - } elsif ($pattern =~ /\d+\.\d+\.\d+\.\d+/) { - #127.0.0.1 - if ($ip =~ /^\Q$pattern\E/) { $allowed=$access{$acctype}; } - } 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=$access{$acctype}; } - } - if ($allowed =~ /^(0|1)$/) { last; } - } - if ($allowed eq '') { - if ($numdenies && !$numallows) { - $allowed = 1; - } else { - $allowed = 0; - } - } - return $allowed; -} - ############################################### =pod @@ -5215,7 +5138,7 @@ sub get_legacy_domconf { my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors'; my $designfile = $designdir.'/'.$udom.'.tab'; if (-e $designfile) { - if ( open (my $fh,"<$designfile") ) { + if ( open (my $fh,'<',$designfile) ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); @@ -8471,8 +8394,9 @@ sub end_togglebox { } sub LCprogressbar_script { - my ($id)=@_; - return(< // ENDPROGRESS + } else { + return(< +// + +ENDPROGRESS + } } sub LCprogressbarUpdate_script { return(< .ui-progressbar { position:relative; } +.progress-label {position: absolute; width: 100%; text-align: center; top: 1px; font-weight: bold; text-shadow: 1px 1px 0 #fff;margin: 0; line-height: 200%; } .pblabel { position: absolute; width: 100%; text-align: center; line-height: 1.9em; } @@ -8511,37 +8457,54 @@ my $LCidcnt; my $LCcurrentid; sub LCprogressbar { - my ($r)=(@_); + my ($r,$number_to_do,$preamble)=@_; $LClastpercent=0; $LCidcnt++; $LCcurrentid=$$.'_'.$LCidcnt; - my $starting=&mt('Starting'); - my $content=(< $starting ENDPROGBAR - &r_print($r,$content.&LCprogressbar_script($LCcurrentid)); + } else { + $starting=&mt('Loading...'); + $LClastpercent='false'; + $content=(< +
$starting
+ +ENDPROGBAR + } + &r_print($r,$content.&LCprogressbar_script($LCcurrentid,$number_to_do)); } sub LCprogressbarUpdate { - my ($r,$val,$text)=@_; - unless ($val) { - if ($LClastpercent) { - $val=$LClastpercent; - } else { - $val=0; - } + my ($r,$val,$text,$number_to_do)=@_; + if ($number_to_do) { + unless ($val) { + if ($LClastpercent) { + $val=$LClastpercent; + } else { + $val=0; + } + } + if ($val<0) { $val=0; } + if ($val>100) { $val=0; } + $LClastpercent=$val; + unless ($text) { $text=$val.'%'; } + } else { + $val = 'false'; } - if ($val<0) { $val=0; } - if ($val>100) { $val=0; } - $LClastpercent=$val; - unless ($text) { $text=$val.'%'; } $text=&js_ready($text); &r_print($r,< // ENDUPDATE @@ -11503,7 +11466,7 @@ sub modify_html_refs { return; } } - if (open(my $fh,"<$container")) { + if (open(my $fh,'<',$container)) { $content = join('', <$fh>); close($fh); } else { @@ -11568,7 +11531,7 @@ sub modify_html_refs { } } } else { - if (open(my $fh,">$container")) { + if (open(my $fh,'>',$container)) { print $fh $content; close($fh); $output = '

'.&mt('Updated [quant,_1,reference] in [_2].', @@ -12149,7 +12112,7 @@ sub process_decompression { if (-f "$dir/$tempdir/$item") { unlink("$dir/$tempdir/$item"); } elsif (-d "$dir/$tempdir/$item") { - &File::Path::Tiny::rm("$dir/$tempdir/$item"); + &File::Path::remove_tree("$dir/$tempdir/$item",{ safe => 1 }); } } } @@ -12159,14 +12122,14 @@ sub process_decompression { if (-f "$dir/$item") { unlink("$dir/$item"); } elsif (-d "$dir/$item") { - &File::Path::Tiny::rm("$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::Tiny::rm("$dir/$tempdir"); + &File::Path::remove_tree("$dir/$tempdir",{ safe => 1 }); } } } else { @@ -12186,8 +12149,7 @@ sub process_decompression { if (ref($newdirlistref) eq 'ARRAY') { foreach my $dir_line (@{$newdirlistref}) { my ($item,undef,undef,$testdir)=split(/\&/,$dir_line,5); - unless (($item =~ /^\.+$/) || ($item eq $file) || - ((@to_skip > 0) && (grep(/^\Q$item\E$/,@to_skip)))) { + unless (($item =~ /^\.+$/) || ($item eq $file)) { push(@newitems,$item); if ($dirptr&$testdir) { $is_dir{$item} = 1; @@ -12775,7 +12737,7 @@ sub process_extracted_files { $newseqid{$i} = $newidx; unless ($errtext) { $result .= '

  • '.&mt('Folder: [_1] added to course', - &HTML::Entities::encode($docstitle,'<>&"')). + &HTML::Entities::encode($docstitle,'<>&"')).. '
    • '."\n"; } } @@ -12800,7 +12762,7 @@ sub process_extracted_files { $fetch =~ s/^\Q$prefix$dir\E//; $prompttofetch{$fetch} = 1; } - } + } } $LONCAPA::map::resources[$newidx]= $docstitle.':'.$url.':false:normal:res'; @@ -12811,7 +12773,9 @@ sub process_extracted_files { '.'.$containers{$outer},1,1); unless ($errtext) { if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title") { - $result .= '
  • '.&mt('File: [_1] added to course',$docstitle).'
    • '."\n"; + $result .= '
  • '.&mt('File: [_1] added to course', + &HTML::Entities::encode($docstitle,'<>&"')). + '
    • '."\n"; } } } else { @@ -12884,7 +12848,9 @@ sub process_extracted_files { } if ($fullpath ne '') { if (-e "$prefix$path") { - system("mv $prefix$path $fullpath/$title"); + unless (rename("$prefix$path","$fullpath/$title")) { + $warning .= &mt('Failed to rename dependency').'
    '; + } } if (-e "$fullpath/$title") { my $showpath; @@ -12896,11 +12862,11 @@ sub process_extracted_files { $result .= '
  • '.&mt('[_1] included as a dependency', &HTML::Entities::encode($showpath,'<>&"')). '
    • '."\n"; - } - unless ($ishome) { - my $fetch = "$fullpath/$title"; - $fetch =~ s/^\Q$prefix$dir\E//; - $prompttofetch{$fetch} = 1; + unless ($ishome) { + my $fetch = "$fullpath/$title"; + $fetch =~ s/^\Q$prefix$dir\E//; + $prompttofetch{$fetch} = 1; + } } } } @@ -13186,12 +13152,15 @@ sub upfile_store { $env{'form.upfile'}=~s/\n+/\n/gs; $env{'form.upfile'}=~s/\n+$//gs; - my $datatoken=$env{'user.name'}.'_'.$env{'user.domain'}. - '_enroll_'.$env{'request.course.id'}.'_'.time.'_'.$$; + my $datatoken = &valid_datatoken($env{'user.name'}.'_'.$env{'user.domain'}. + '_enroll_'.$env{'request.course.id'}.'_'. + time.'_'.$$); + return if ($datatoken eq ''); + { my $datafile = $r->dir_config('lonDaemons'). '/tmp/'.$datatoken.'.tmp'; - if ( open(my $fh,">$datafile") ) { + if ( open(my $fh,'>',$datafile) ) { print $fh $env{'form.upfile'}; close($fh); } @@ -13216,7 +13185,7 @@ sub load_tmp_file { { my $studentfile = $r->dir_config('lonDaemons'). '/tmp/'.$datatoken.'.tmp'; - if ( open(my $fh,"<$studentfile") ) { + if ( open(my $fh,'<',$studentfile) ) { @studentdata=<$fh>; close($fh); } @@ -14120,13 +14089,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 @@ -14136,7 +14098,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 = @@ -14177,94 +14139,6 @@ 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; }