From 92ad549936eaf61f402366160e6b3fc685a88f2c Mon Sep 17 00:00:00 2001 From: Tomas Cohen Arazi Date: Mon, 27 Mar 2023 14:17:31 +0200 Subject: [PATCH] Bug 33341: Address some perlcritic errors in 5.36 Some old-style code is making our tests fail when run in Debian Testing. This patch addresses this. To test: 1. Launch bookworm KTD: $ KOHA_IMAGE=master-bookworm ktd up -d 2. Run: $ ktd --shell k$ prove t/00-testcritic.t => FAIL: It fails! 3. Apply the patch 4. Repeat 2 => SUCCESS: Tests now pass! 5. Sign off :-D Signed-off-by: Tomas Cohen Arazi Signed-off-by: Martin Renvoize Signed-off-by: Tomas Cohen Arazi (cherry picked from commit 10d12f999f9b8bff228c9c20f1ca4f0c7144201f) Signed-off-by: Matt Blenkinsop (cherry picked from commit c1c5420afae84e86938d4a7ecaf2adb7074a2cc1) Signed-off-by: Lucas Gass (cherry picked from commit 548a3325baefe0b700d9386f9fc05e201e56ea4f) Signed-off-by: Arthur Suzuki --- C4/Installer.pm | 34 +++++++++++--------- C4/Koha.pm | 6 ++-- C4/Languages.pm | 21 +++++++----- C4/Ris.pm | 2 +- Koha/AuthUtils.pm | 7 ++-- admin/auth_subfields_structure.pl | 25 +++++++------- admin/marc_subfields_structure.pl | 9 +++--- installer/install.pl | 9 +++--- misc/maintenance/generate_MARC21Languages.pl | 2 +- misc/translator/tmpl_process3.pl | 7 ++-- misc/translator/xgettext.pl | 2 +- tools/access_files.pl | 7 ++-- tools/picture-upload.pl | 14 ++++---- 13 files changed, 82 insertions(+), 63 deletions(-) diff --git a/C4/Installer.pm b/C4/Installer.pm index 723d47227b..e133a19c10 100644 --- a/C4/Installer.pm +++ b/C4/Installer.pm @@ -123,19 +123,20 @@ sub marc_framework_sql_list { undef $/; my $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/$lang/marcflavour/".lc($marcflavour); - unless (opendir( MYDIR, $dir )) { + my $dir_h; + unless (opendir( $dir_h, $dir )) { if ($lang eq 'en') { warn "cannot open MARC frameworks directory $dir"; } else { # if no translated MARC framework is available, # default to English $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/en/marcflavour/".lc($marcflavour); - opendir(MYDIR, $dir) or warn "cannot open English MARC frameworks directory $dir"; + opendir($dir_h, $dir) or warn "cannot open English MARC frameworks directory $dir"; $defaulted_to_en = 1; } } - my @listdir = sort grep { !/^\.|marcflavour/ && -d "$dir/$_" } readdir(MYDIR); - closedir MYDIR; + my @listdir = sort grep { !/^\.|marcflavour/ && -d "$dir/$_" } readdir($dir_h); + closedir $dir_h; my @fwklist; my $request = $self->{'dbh'}->prepare("SELECT value FROM systempreferences WHERE variable='FrameworksLoaded'"); @@ -148,9 +149,10 @@ sub marc_framework_sql_list { } foreach my $requirelevel (@listdir) { - opendir( MYDIR, "$dir/$requirelevel" ); - my @listname = grep { !/^\./ && -f "$dir/$requirelevel/$_" && $_ =~ m/\.(sql|yml)$/ } readdir(MYDIR); - closedir MYDIR; + my $dir_h; + opendir( $dir_h, "$dir/$requirelevel" ); + my @listname = grep { !/^\./ && -f "$dir/$requirelevel/$_" && $_ =~ m/\.(sql|yml)$/ } readdir($dir_h); + closedir $dir_h; my %cell; my @frameworklist; map { @@ -206,19 +208,20 @@ sub sample_data_sql_list { undef $/; my $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/$lang"; - unless (opendir( MYDIR, $dir )) { + my $dir_h; + unless (opendir( $dir_h, $dir )) { if ($lang eq 'en') { warn "cannot open sample data directory $dir"; } else { # if no sample data is available, # default to English $dir = C4::Context->config('intranetdir') . "/installer/data/$self->{dbms}/en"; - opendir(MYDIR, $dir) or warn "cannot open English sample data directory $dir"; + opendir($dir_h, $dir) or warn "cannot open English sample data directory $dir"; $defaulted_to_en = 1; } } - my @listdir = sort grep { !/^\.|marcflavour/ && -d "$dir/$_" } readdir(MYDIR); - closedir MYDIR; + my @listdir = sort grep { !/^\.|marcflavour/ && -d "$dir/$_" } readdir($dir_h); + closedir $dir_h; my @levellist; my $request = $self->{'dbh'}->prepare("SELECT value FROM systempreferences WHERE variable='FrameworksLoaded'"); @@ -231,9 +234,10 @@ sub sample_data_sql_list { } foreach my $requirelevel (@listdir) { - opendir( MYDIR, "$dir/$requirelevel" ); - my @listname = grep { !/^\./ && -f "$dir/$requirelevel/$_" && $_ =~ m/\.(sql|yml)$/ } readdir(MYDIR); - closedir MYDIR; + my $dir_h; + opendir( $dir_h, "$dir/$requirelevel" ); + my @listname = grep { !/^\./ && -f "$dir/$requirelevel/$_" && $_ =~ m/\.(sql|yml)$/ } readdir($dir_h); + closedir $dir_h; my %cell; my @frameworklist; map { @@ -847,7 +851,7 @@ sub run_atomic_updates { my $code = read_file( $filepath ); my ( $out, $err ) = ('', ''); { - open my $oldout, ">&STDOUT"; + open my $oldout, qw{>}, "&STDOUT"; close STDOUT; open STDOUT,'>:encoding(utf8)', \$out; my $DBversion = Koha::version; # We need $DBversion and $dbh for the eval diff --git a/C4/Koha.pm b/C4/Koha.pm index 89376b0b4a..7132910adf 100644 --- a/C4/Koha.pm +++ b/C4/Koha.pm @@ -301,12 +301,14 @@ sub getallthemes { else { $htdocs = C4::Context->config('opachtdocs'); } - opendir D, "$htdocs"; - my @dirlist = readdir D; + my $dir_h; + opendir $dir_h, "$htdocs"; + my @dirlist = readdir $dir_h; foreach my $directory (@dirlist) { next if $directory eq 'lib'; -d "$htdocs/$directory/en" and push @themes, $directory; } + close $dir_h; return @themes; } diff --git a/C4/Languages.pm b/C4/Languages.pm index c05c31bf9e..1d45bd2d71 100644 --- a/C4/Languages.pm +++ b/C4/Languages.pm @@ -76,9 +76,10 @@ sub getFrameworkLanguages { # find the available directory names my $dir=C4::Context->config('intranetdir')."/installer/data/"; - opendir (MYDIR,$dir); - my @listdir= grep { !/^\.|CVS/ && -d "$dir/$_"} readdir(MYDIR); - closedir MYDIR; + my $dir_h; + opendir ($dir_h,$dir); + my @listdir= grep { !/^\.|CVS/ && -d "$dir/$_"} readdir($dir_h); + closedir $dir_h; # pull out all data for the dir names that exist for my $dirname (@listdir) { @@ -293,12 +294,14 @@ sub _get_themes { else { $htdocs = C4::Context->config('opachtdocs'); } - opendir D, "$htdocs"; - my @dirlist = readdir D; + my $dir_h; + opendir $dir_h, "$htdocs"; + my @dirlist = readdir $dir_h; foreach my $directory (@dirlist) { # if there's an en dir, it's a valid theme -d "$htdocs/$directory/en" and push @themes, $directory; } + close $dir_h; return @themes; } @@ -313,8 +316,9 @@ sub _get_language_dirs { $htdocs //= ''; $theme //= ''; my @lang_strings; - opendir D, "$htdocs/$theme"; - for my $lang_string ( readdir D ) { + my $dir_h; + opendir $dir_h, "$htdocs/$theme"; + for my $lang_string ( readdir $dir_h ) { next if $lang_string =~/^\./; next if $lang_string eq 'all'; next if $lang_string =~/png$/; @@ -325,7 +329,8 @@ sub _get_language_dirs { next if $lang_string =~/img|images|famfam|js|less|lib|sound|pdf/; push @lang_strings, $lang_string; } - return (@lang_strings); + close $dir_h; + return (@lang_strings); } =head2 _build_languages_arrayref diff --git a/C4/Ris.pm b/C4/Ris.pm index 9ab50d924b..56c0b9efe2 100644 --- a/C4/Ris.pm +++ b/C4/Ris.pm @@ -97,7 +97,7 @@ sub marc2ris { my $intype = lc($marcflavour); # Let's redirect stdout - open my $oldout, ">&STDOUT"; + open my $oldout, qw{>}, "&STDOUT"; my $outvar; close STDOUT; open STDOUT,'>:encoding(utf8)', \$outvar; diff --git a/Koha/AuthUtils.pm b/Koha/AuthUtils.pm index 8345f50a5f..78524999f3 100644 --- a/Koha/AuthUtils.pm +++ b/Koha/AuthUtils.pm @@ -122,7 +122,8 @@ sub generate_salt { $source = '/dev/urandom'; # non-blocking } - sysopen SOURCE, $source, O_RDONLY + my $source_fh; + sysopen $source_fh, $source, O_RDONLY or die "failed to open source '$source' in Koha::AuthUtils::generate_salt\n"; # $bytes is the bytes just read @@ -132,7 +133,7 @@ sub generate_salt { # keep reading until we have $length bytes in $strength while( length($string) < $length ){ # return the number of bytes read, 0 (EOF), or -1 (ERROR) - my $return = sysread SOURCE, $bytes, $length - length($string); + my $return = sysread $source_fh, $bytes, $length - length($string); # if no bytes were read, keep reading (if using /dev/random it is possible there was insufficient entropy so this may block) next unless $return; @@ -143,7 +144,7 @@ sub generate_salt { $string .= $bytes; } - close SOURCE; + close $source_fh; return $string; } diff --git a/admin/auth_subfields_structure.pl b/admin/auth_subfields_structure.pl index 2fbe31e22b..371511c654 100755 --- a/admin/auth_subfields_structure.pl +++ b/admin/auth_subfields_structure.pl @@ -87,19 +87,20 @@ if ($op eq 'add_form') { # 2 cases here : on CVS install, $cgidir does not need a /cgi-bin # on a standard install, /cgi-bin need to be added. # test one, then the other - my $cgidir = C4::Context->config('intranetdir') ."/cgi-bin"; - unless (opendir(DIR, "$cgidir/cataloguing/value_builder")) { + my $cgidir = C4::Context->config('intranetdir') . "/cgi-bin"; + my $dir_h; + unless ( opendir( $dir_h, "$cgidir/cataloguing/value_builder" ) ) { $cgidir = C4::Context->config('intranetdir'); - opendir(DIR, "$cgidir/cataloguing/value_builder") || die "can't opendir $cgidir/value_builder: $!"; - } - while (my $line = readdir(DIR)) { - if ( $line =~ /\.pl$/ && - $line !~ /EXAMPLE\.pl$/ ) { # documentation purposes - push (@value_builder,$line); - } - } - @value_builder= sort {$a cmp $b} @value_builder; - closedir DIR; + opendir( $dir_h, "$cgidir/cataloguing/value_builder" ) || die "can't opendir $cgidir/value_builder: $!"; + } + while ( my $line = readdir($dir_h) ) { + if ( $line =~ /\.pl$/ + && $line !~ /EXAMPLE\.pl$/ ) { # documentation purposes + push( @value_builder, $line ); + } + } + @value_builder = sort { $a cmp $b } @value_builder; + closedir $dir_h; my @loop_data; my $asses = Koha::Authority::Subfields->search({ tagfield => $tagfield, authtypecode => $authtypecode}, {order_by => 'display_order'})->unblessed; diff --git a/admin/marc_subfields_structure.pl b/admin/marc_subfields_structure.pl index 8b02c6f154..9970e47511 100755 --- a/admin/marc_subfields_structure.pl +++ b/admin/marc_subfields_structure.pl @@ -111,19 +111,20 @@ if ( $op eq 'add_form' ) { # on a standard install, /cgi-bin need to be added. # test one, then the other my $cgidir = C4::Context->config('intranetdir') . "/cgi-bin"; - unless ( opendir( DIR, "$cgidir/cataloguing/value_builder" ) ) { + my $dir_h; + unless ( opendir( $dir_h, "$cgidir/cataloguing/value_builder" ) ) { $cgidir = C4::Context->config('intranetdir'); - opendir( DIR, "$cgidir/cataloguing/value_builder" ) + opendir( $dir_h, "$cgidir/cataloguing/value_builder" ) || die "can't opendir $cgidir/value_builder: $!"; } - while ( my $line = readdir(DIR) ) { + while ( my $line = readdir($dir_h) ) { if ( $line =~ /\.pl$/ && $line !~ /EXAMPLE\.pl$/ ) { # documentation purposes push( @value_builder, $line ); } } @value_builder= sort {$a cmp $b} @value_builder; - closedir DIR; + closedir $dir_h; # build values list my $mss = Koha::MarcSubfieldStructures->search( diff --git a/installer/install.pl b/installer/install.pl index 063832569c..f8de23e332 100755 --- a/installer/install.pl +++ b/installer/install.pl @@ -327,7 +327,8 @@ elsif ( $step && $step == 3 ) { my $dir = C4::Context->config('intranetdir') . "/installer/data/$info{dbms}/$langchoice/marcflavour"; - unless ( opendir( MYDIR, $dir ) ) { + my $dir_h; + unless ( opendir( $dir_h, $dir ) ) { if ( $langchoice eq 'en' ) { warn "cannot open MARC frameworks directory $dir"; } @@ -336,12 +337,12 @@ elsif ( $step && $step == 3 ) { # default to English $dir = C4::Context->config('intranetdir') . "/installer/data/$info{dbms}/en/marcflavour"; - opendir( MYDIR, $dir ) + opendir( $dir_h, $dir ) or warn "cannot open English MARC frameworks directory $dir"; } } - my @listdir = grep { !/^\./ && -d "$dir/$_" } readdir(MYDIR); - closedir MYDIR; + my @listdir = grep { !/^\./ && -d "$dir/$_" } readdir($dir_h); + closedir $dir_h; my $marcflavour = C4::Context->preference("marcflavour"); my @flavourlist; foreach my $marc (@listdir) { diff --git a/misc/maintenance/generate_MARC21Languages.pl b/misc/maintenance/generate_MARC21Languages.pl index 8a70a4f448..37888a66eb 100755 --- a/misc/maintenance/generate_MARC21Languages.pl +++ b/misc/maintenance/generate_MARC21Languages.pl @@ -56,7 +56,7 @@ my $out_handle; if (defined $outfile) { open( $out_handle, ">", $outfile ) || croak("Cannot open output file"); } else { - open( $out_handle, ">&STDOUT" ) || croak("Couldn't duplicate STDOUT: $!"); + open( $out_handle, q{>}, "&STDOUT" ) || croak("Couldn't duplicate STDOUT: $!"); } generate_header($out_handle); generate_body($out_handle, $languages); diff --git a/misc/translator/tmpl_process3.pl b/misc/translator/tmpl_process3.pl index 8d270829f6..ddb02e7957 100755 --- a/misc/translator/tmpl_process3.pl +++ b/misc/translator/tmpl_process3.pl @@ -157,9 +157,10 @@ sub listfiles { my $match = join ('|', @match); # use only this files my $nomatch = join ('|', @nomatch); # do no use this files my @it = (); - if (opendir(DIR, $dir)) { - my @dirent = readdir DIR; # because DIR is shared when recursing - closedir DIR; + my $dir_h; + if (opendir($dir_h, $dir)) { + my @dirent = readdir $dir_h; # because $dir_h is shared when recursing + closedir $dir_h; for my $dirent (@dirent) { my $path = "$dir/$dirent"; if ($dirent =~ /^\./ || $dirent eq 'CVS' || $dirent eq 'RCS' diff --git a/misc/translator/xgettext.pl b/misc/translator/xgettext.pl index 1d7a5d7c1b..9eec03646a 100755 --- a/misc/translator/xgettext.pl +++ b/misc/translator/xgettext.pl @@ -387,7 +387,7 @@ if (defined $output && $output ne '-') { open($OUTPUT, '>:encoding(utf-8)', $output) || die "$output: $!\n"; } else { print STDERR "$0: Outputting to STDOUT...\n" if $verbose_p; - open($OUTPUT, ">&STDOUT"); + open($OUTPUT, q{>}, "&STDOUT"); } if (defined $files_from) { diff --git a/tools/access_files.pl b/tools/access_files.pl index 8a1c1adc58..85420bd602 100755 --- a/tools/access_files.pl +++ b/tools/access_files.pl @@ -61,8 +61,9 @@ else { #Get the files list my @files_list; foreach my $dir(@directories){ - opendir(DIR, $dir); - foreach my $filename (readdir(DIR)) { + my $dir_h; + opendir($dir_h, $dir); + foreach my $filename (readdir($dir_h)) { my $full_path = "$dir/$filename"; my $id = md5_hex($full_path); next if ($filename =~ /^\./ or -d $full_path); @@ -84,7 +85,7 @@ else { size => $st->size, id => $id}); } - closedir(DIR); + closedir($dir_h); } my %files_hash = map { $_->{id} => $_ } @files_list; diff --git a/tools/picture-upload.pl b/tools/picture-upload.pl index 57c55b9a12..b836f25230 100755 --- a/tools/picture-upload.pl +++ b/tools/picture-upload.pl @@ -126,12 +126,13 @@ if ( ( $op eq 'Upload' ) && $uploadfile ) { } push @directories, "$dirname"; foreach my $recursive_dir (@directories) { - opendir RECDIR, $recursive_dir; - while ( my $entry = readdir RECDIR ) { + my $recdir_h; + opendir $recdir_h, $recursive_dir; + while ( my $entry = readdir $recdir_h ) { push @directories, "$recursive_dir/$entry" if ( -d "$recursive_dir/$entry" and $entry !~ /^\./ ); } - closedir RECDIR; + closedir $recdir_h; } foreach my $dir (@directories) { $results = handle_dir( $dir, $filesuffix, $template ); @@ -206,8 +207,9 @@ sub handle_dir { my ( $file, $filename ); undef $cardnumber; $logger->debug("Passed a zip file."); - opendir DIR, $dir; - while ( my $filename = readdir DIR ) { + my $dir_h; + opendir $dir_h, $dir; + while ( my $filename = readdir $dir_h ) { $file = "$dir/$filename" if ( $filename =~ m/datalink\.txt/i || $filename =~ m/idlink\.txt/i ); @@ -242,7 +244,7 @@ sub handle_dir { %counts = handle_file( $cardnumber, $source, $template, %counts ); } close $fh; - closedir DIR; + closedir $dir_h; } else { %counts = handle_file( $cardnumber, $source, $template, %counts ); -- 2.39.5