Browse Source

Bug 21395: Make perlcritic happy

This patch adds a .perlcriticrc (copied from qa-test-tools) and fixes
almost all perlcrictic violations according to this .perlcriticrc
The remaining violations are silenced out by appending a '## no critic'
to the offending lines. They can still be seen by using the --force
option of perlcritic
This patch also modify t/00-testcritic.t to check all Perl files using
the new .perlcriticrc.
I'm not sure if this test script is still useful as it is now equivalent
to `perlcritic --quiet .` and it looks like it is much slower
(approximatively 5 times slower on my machine)

Test plan:
1. Run `perlcritic --quiet .` from the root directory. It should output
   nothing
2. Run `perlcritic --quiet --force .`. It should output 7 errors (6
   StringyEval, 1 BarewordFileHandles)
3. Run `TEST_QA=1 prove t/00-testcritic.t`
4. Read the patch. Check that all changes make sense and do not
   introduce undesired behaviour

Signed-off-by: Bernardo Gonzalez Kriegel <bgkriegel@gmail.com>
Signed-off-by: Martin Renvoize <martin.renvoize@ptfs-europe.com>

Signed-off-by: Jonathan Druart <jonathan.druart@bugs.koha-community.org>
20.11.x
Julian Maurice 3 years ago
committed by Jonathan Druart
parent
commit
b168f4a2e9
  1. 2
      .perlcriticrc
  2. 1
      C4/Accounts.pm
  3. 1
      C4/Acquisition.pm
  4. 18
      C4/Auth_with_cas.pm
  5. 1
      C4/AuthoritiesMarc.pm
  6. 2
      C4/Barcodes/ValueBuilder.pm
  7. 8
      C4/Barcodes/annual.pm
  8. 1
      C4/Biblio.pm
  9. 4
      C4/ClassSortRoutine.pm
  10. 2
      C4/ClassSplitRoutine/RegEx.pm
  11. 2
      C4/Context.pm
  12. 2
      C4/CourseReserves.pm
  13. 2
      C4/Creators.pm
  14. 2
      C4/Creators/Lib.pm
  15. 12
      C4/ImportBatch.pm
  16. 1
      C4/InstallAuth.pm
  17. 1
      C4/Items.pm
  18. 2
      C4/Labels.pm
  19. 5
      C4/Labels/Label.pm
  20. 4
      C4/Languages.pm
  21. 1
      C4/Letters.pm
  22. 2
      C4/Matcher.pm
  23. 1
      C4/Members/Messaging.pm
  24. 2
      C4/Patroncards.pm
  25. 8
      C4/Patroncards/Patroncard.pm
  26. 8
      C4/Record.pm
  27. 1
      C4/Ris.pm
  28. 5
      C4/Search.pm
  29. 21
      C4/Serials.pm
  30. 2
      C4/Templates.pm
  31. 6
      Makefile.PL
  32. 2
      docs/CAS/CASProxy/examples/koha_webservice.pl
  33. 6
      docs/CAS/CASProxy/examples/proxy_cas_callback.pl
  34. 6
      docs/CAS/CASProxy/examples/proxy_cas_data.pl
  35. 4
      fix-perl-path.PL
  36. 2
      installer/data/mysql/labels_upgrade.pl
  37. 2
      installer/data/mysql/patroncards_upgrade.pl
  38. 16
      installer/data/mysql/update22to30.pl
  39. 10
      installer/data/mysql/updatedatabase.pl
  40. 6
      installer/externalmodules.pl
  41. 2
      installer/install.pl
  42. 1
      misc/admin/koha-preferences
  43. 1
      misc/batchRepairMissingBiblionumbers.pl
  44. 2
      misc/batchdeletebiblios.pl
  45. 1
      misc/bin/connexion_import_daemon.pl
  46. 6
      misc/check_sysprefs.pl
  47. 2
      misc/cronjobs/build_browser_and_cloud.pl
  48. 3
      misc/cronjobs/gather_print_notices.pl
  49. 3
      misc/cronjobs/holds/cancel_expired_holds.pl
  50. 6
      misc/cronjobs/longoverdue.pl
  51. 6
      misc/cronjobs/rss/rss.pl
  52. 1
      misc/cronjobs/thirdparty/TalkingTech_itiva_inbound.pl
  53. 2
      misc/cronjobs/update_totalissues.pl
  54. 6
      misc/exportauth.pl
  55. 2
      misc/link_bibs_to_authorities.pl
  56. 2
      misc/maintenance/cmp_sysprefs.pl
  57. 1
      misc/maintenance/fix_accountlines_rmdupfines_bug8253.pl
  58. 10
      misc/maintenance/touch_all_biblios.pl
  59. 10
      misc/maintenance/touch_all_items.pl
  60. 5
      misc/migration_tools/22_to_30/export_Authorities.pl
  61. 5
      misc/migration_tools/22_to_30/export_Authorities_xml.pl
  62. 3
      misc/migration_tools/22_to_30/move_marc_to_biblioitems.pl
  63. 2
      misc/migration_tools/buildCOUNTRY.pl
  64. 1
      misc/migration_tools/buildEDITORS.pl
  65. 2
      misc/migration_tools/buildLANG.pl
  66. 7
      misc/migration_tools/bulkmarcimport.pl
  67. 1
      misc/migration_tools/remove_unused_authorities.pl
  68. 2
      misc/perlmodule_rm.pl
  69. 2
      misc/translator/LangInstaller.pm
  70. 56
      misc/translator/TmplTokenizer.pm
  71. 24
      misc/translator/VerboseWarnings.pm
  72. 14
      misc/translator/po2json
  73. 81
      misc/translator/tmpl_process3.pl
  74. 28
      misc/translator/xgettext.pl
  75. 1
      opac/opac-MARCdetail.pl
  76. 1
      opac/opac-alert-subscribe.pl
  77. 1
      opac/opac-authorities-home.pl
  78. 1
      opac/opac-authoritiesdetail.pl
  79. 1
      opac/opac-basket.pl
  80. 5
      opac/opac-search.pl
  81. 2
      opac/opac-serial-issues.pl
  82. 1
      opac/opac-showreviews.pl
  83. 10
      patroncards/create-pdf.pl
  84. 2
      patroncards/image-manage.pl
  85. 12
      patroncards/print.pl
  86. 2
      plugins/plugins-upload.pl
  87. 1
      reports/acquisitions_stats.pl
  88. 26
      reports/bor_issues_top.pl
  89. 7
      reports/borrowers_out.pl
  90. 2
      reports/catalogue_out.pl
  91. 5
      reports/catalogue_stats.pl
  92. 5
      reports/issues_avg_stats.pl
  93. 5
      reports/issues_stats.pl
  94. 4
      reports/reserves_stats.pl
  95. 22
      rewrite-config.PL
  96. 1
      svc/holds
  97. 32
      t/00-testcritic.t
  98. 2
      t/Languages.t
  99. 4
      t/Prices.t
  100. 2
      t/SuggestionEngine.t

2
t/perlcriticrc → .perlcriticrc

@ -10,3 +10,5 @@ equivalent_modules = Modern::Perl
[TestingAndDebugging::RequireUseWarnings]
equivalent_modules = Modern::Perl
[-Modules::RequireBarewordIncludes]

1
C4/Accounts.pm

@ -148,7 +148,6 @@ sub manualinvoice {
my $manager_id = C4::Context->userenv ? C4::Context->userenv->{'number'} : undef;
my $dbh = C4::Context->dbh;
my $insert;
my $amountleft = $amount;
my $branchcode = C4::Context->userenv ? C4::Context->userenv->{'branch'} : undef;

1
C4/Acquisition.pm

@ -2145,7 +2145,6 @@ sub GetHistory {
my $ordernumbers = $params{ordernumbers} || [];
my $additional_fields = $params{additional_fields} // [];
my @order_loop;
my $total_qty = 0;
my $total_qtyreceived = 0;
my $total_price = 0;

18
C4/Auth_with_cas.pm

@ -257,19 +257,19 @@ sub logout_if_required {
my $params = C4::Auth::_get_session_params();
my $success = CGI::Session->find( $params->{dsn}, sub {delete_cas_session(@_, $ticket)}, $params->{dsn_args} );
sub delete_cas_session {
my $session = shift;
my $ticket = shift;
if ($session->param('cas_ticket') && $session->param('cas_ticket') eq $ticket ) {
$session->delete;
$session->flush;
}
}
print $query->header;
exit;
}
sub delete_cas_session {
my $session = shift;
my $ticket = shift;
if ($session->param('cas_ticket') && $session->param('cas_ticket') eq $ticket ) {
$session->delete;
$session->flush;
}
}
1;
__END__

1
C4/AuthoritiesMarc.pm

@ -117,7 +117,6 @@ sub SearchAuthorities {
# the marclist may contain "mainentry". In this case, search the tag_to_report, that depends on
# the authtypecode. Then, search on $a of this tag_to_report
# also store main entry MARC tag, to extract it at end of search
my $mainentrytag;
##first set the authtype search and may be multiple authorities
if ($authtypecode) {
my $n=0;

2
C4/Barcodes/ValueBuilder.pm

@ -19,6 +19,8 @@
# along with Koha; if not, see <http://www.gnu.org/licenses>.
package C4::Barcodes::ValueBuilder::incremental;
use Modern::Perl;
use C4::Context;
my $DEBUG = 0;

8
C4/Barcodes/annual.pm

@ -36,7 +36,7 @@ BEGIN {
$width = 4;
}
sub db_max ($;$) {
sub db_max {
my $self = shift;
my $query = "SELECT substring_index(barcode,'-',-1) AS chunk,barcode FROM items WHERE barcode LIKE ? ORDER BY chunk DESC LIMIT 1";
# FIXME: unreasonably expensive query on large datasets (I think removal of group by does this?)
@ -64,7 +64,7 @@ sub initial () {
return substr(output_pref({ dt => dt_from_string, dateformat => 'iso', dateonly => 1 }), 0, 4 ) .'-'. sprintf('%'."$width.$width".'d', 1);
}
sub parse ($;$) {
sub parse {
my $self = shift;
my $barcode = (@_) ? shift : $self->value;
unless ($barcode =~ /(\d{4}-)(\d+)$/) { # non-greedy match in first part
@ -74,12 +74,12 @@ sub parse ($;$) {
$debug and warn "Barcode '$barcode' parses into: '$1', '$2', ''";
return ($1,$2,''); # the third part is in anticipation of barcodes that include checkdigits
}
sub width ($;$) {
sub width {
my $self = shift;
(@_) and $width = shift; # hitting the class variable.
return $width;
}
sub process_head($$;$$) { # (self,head,whole,specific)
sub process_head {
my ($self,$head,$whole,$specific) = @_;
$specific and return $head; # if this is built off an existing barcode, just return the head unchanged.
return substr(output_pref({ dt => dt_from_string, dateformat => 'iso', dateonly => 1 }), 0, 4 ) . '-'; # else get new YYYY-

1
C4/Biblio.pm

@ -2146,7 +2146,6 @@ sub TransformHtmlToXml {
# MARC::Record->new_from_xml will fail (and Koha will die)
my $unimarc_and_100_exist = 0;
$unimarc_and_100_exist = 1 if $auth_type eq 'ITEM'; # if we rebuild an item, no need of a 100 field
my $prevvalue;
my $prevtag = -1;
my $first = 1;
my $j = -1;

4
C4/ClassSortRoutine.pm

@ -52,8 +52,8 @@ my @sort_routines = GetSortRoutineNames();
foreach my $sort_routine (@sort_routines) {
if (eval "require C4::ClassSortRoutine::$sort_routine") {
my $ref;
eval "\$ref = \\\&C4::ClassSortRoutine::${sort_routine}::get_class_sort_key";
if (eval "\$ref->(\"a\", \"b\")") {
$ref = \&{"C4::ClassSortRoutine::${sort_routine}::get_class_sort_key"};
if (eval { $ref->("a", "b") }) {
$loaded_routines{$sort_routine} = $ref;
} else {
$loaded_routines{$sort_routine} = \&_get_class_sort_key;

2
C4/ClassSplitRoutine/RegEx.pm

@ -43,7 +43,7 @@ sub split_callnumber {
my ($cn_item, $regexs) = @_;
for my $regex ( @$regexs ) {
eval "\$cn_item =~ $regex";
eval "\$cn_item =~ $regex"; ## no critic (StringyEval)
}
my @lines = split "\n", $cn_item;

2
C4/Context.pm

@ -248,7 +248,6 @@ sub new {
}
my $conf_cache = Koha::Caches->get_instance('config');
my $config_from_cache;
if ( $conf_cache->cache ) {
$self = $conf_cache->get_from_cache('koha_conf');
}
@ -695,7 +694,6 @@ sub dbh
{
my $self = shift;
my $params = shift;
my $sth;
unless ( $params->{new} ) {
return Koha::Database->schema->storage->dbh;

2
C4/CourseReserves.pm

@ -84,7 +84,7 @@ sub GetCourse {
warn whoami() . "( $course_id )" if $DEBUG;
my $course = Koha::Courses->find( $course_id );
return undef unless $course;
return unless $course;
$course = $course->unblessed;
my $dbh = C4::Context->dbh;

2
C4/Creators.pm

@ -17,6 +17,8 @@ package C4::Creators;
# You should have received a copy of the GNU General Public License
# along with Koha; if not, see <http://www.gnu.org/licenses>.
use Modern::Perl;
BEGIN {
use vars qw(@EXPORT @ISA);
@ISA = qw(Exporter);

2
C4/Creators/Lib.pm

@ -527,7 +527,7 @@ be passed off as a template parameter and used to build an html table.
sub html_table {
my $headers = shift;
my $data = shift;
return undef if scalar(@$data) == 0; # no need to generate a table if there is not data to display
return if scalar(@$data) == 0; # no need to generate a table if there is not data to display
my $table = [];
my $fields = [];
my @table_columns = ();

12
C4/ImportBatch.pm

@ -1502,10 +1502,10 @@ sub RecordsFromISO2709File {
my $marc_type = C4::Context->preference('marcflavour');
$marc_type .= 'AUTH' if ($marc_type eq 'UNIMARC' && $record_type eq 'auth');
open IN, "<$input_file" or die "$0: cannot open input file $input_file: $!\n";
open my $fh, '<', $input_file or die "$0: cannot open input file $input_file: $!\n";
my @marc_records;
$/ = "\035";
while (<IN>) {
while (<$fh>) {
s/^\s+//;
s/\s+$//;
next unless $_; # skip if record has only whitespace, as might occur
@ -1517,7 +1517,7 @@ sub RecordsFromISO2709File {
"Unexpected charset $charset_guessed, expecting $encoding";
}
}
close IN;
close $fh;
return ( \@errors, \@marc_records );
}
@ -1560,15 +1560,15 @@ sub RecordsFromMarcPlugin {
return \@return if !$input_file || !$plugin_class;
# Read input file
open IN, "<$input_file" or die "$0: cannot open input file $input_file: $!\n";
open my $fh, '<', $input_file or die "$0: cannot open input file $input_file: $!\n";
$/ = "\035";
while (<IN>) {
while (<$fh>) {
s/^\s+//;
s/\s+$//;
next unless $_;
$text .= $_;
}
close IN;
close $fh;
# Convert to large MARC blob with plugin
$text = Koha::Plugins::Handler->run({

1
C4/InstallAuth.pm

@ -270,7 +270,6 @@ sub checkauth {
$loggedin = 1;
$userid = $session->param('cardnumber');
}
my ( $ip, $lasttime );
if ($logout) {

1
C4/Items.pm

@ -224,7 +224,6 @@ Additional information appropriate to the error condition.
sub AddItemBatchFromMarc {
my ($record, $biblionumber, $biblioitemnumber, $frameworkcode) = @_;
my $error;
my @itemnumbers = ();
my @errors = ();
my $dbh = C4::Context->dbh;

2
C4/Labels.pm

@ -1,5 +1,7 @@
package C4::Labels;
use Modern::Perl;
BEGIN {
use C4::Labels::Batch;

5
C4/Labels/Label.pm

@ -163,7 +163,6 @@ sub _get_barcode_data {
}
elsif ( $f =~ /^([0-9a-z]{3})(\w)(\W?).*?/ ) {
my ($field,$subf,$ws) = ($1,$2,$3);
my $subf_data;
my ($itemtag, $itemsubfieldcode) = &GetMarcFromKohaField( "items.itemnumber" );
my @marcfield = $record->field($field);
if(@marcfield) {
@ -313,8 +312,8 @@ sub create_label {
my $label_text = '';
my ($text_llx, $text_lly, $line_spacer, $barcode_llx, $barcode_lly, $barcode_width, $barcode_y_scale_factor);
{
no strict 'refs';
($text_llx, $text_lly, $line_spacer, $barcode_llx, $barcode_lly, $barcode_width, $barcode_y_scale_factor) = &{"_$self->{'printing_type'}"}($self); # an obfuscated call to the correct printing type sub
my $sub = \&{'_' . $self->{printing_type}};
($text_llx, $text_lly, $line_spacer, $barcode_llx, $barcode_lly, $barcode_width, $barcode_y_scale_factor) = $sub->($self); # an obfuscated call to the correct printing type sub
}
if ($self->{'printing_type'} =~ /BIB/) {
$label_text = draw_label_text( $self,

4
C4/Languages.pm

@ -344,8 +344,6 @@ sub _build_languages_arrayref {
my @languages_loop; # the final reference to an array of hashrefs
my @enabled_languages = @$enabled_languages;
# how many languages are enabled, if one, take note, some contexts won't need to display it
my %seen_languages; # the language tags we've seen
my %found_languages;
my $language_groups;
my $track_language_groups;
my $current_language_regex = regex_lang_subtags($current_language);
@ -585,7 +583,7 @@ sub accept_language {
}
# No primary matches. Secondary? (ie, en-us requested and en supported)
return $secondaryMatch if $secondaryMatch;
return undef; # else, we got nothing.
return; # else, we got nothing.
}
=head2 getlanguage

1
C4/Letters.pm

@ -313,7 +313,6 @@ sub SendAlerts {
or warn( "No biblionumber for '$subscriptionid'" ),
return;
my %letter;
# find the list of subscribers to notify
my $subscription = Koha::Subscriptions->find( $subscriptionid );
my $subscribers = $subscription->subscribers;

2
C4/Matcher.pm

@ -165,7 +165,7 @@ sub fetch {
$sth->execute($id);
my $row = $sth->fetchrow_hashref;
$sth->finish();
return undef unless defined $row;
return unless defined $row;
my $self = {};
$self->{'id'} = $row->{'matcher_id'};

1
C4/Members/Messaging.pm

@ -88,7 +88,6 @@ END_SQL
my $sth = C4::Context->dbh->prepare($sql);
$sth->execute(@bind_params);
my $return;
my %transports; # helps build a list of unique message_transport_types
ROW: while ( my $row = $sth->fetchrow_hashref() ) {
next ROW unless $row->{'message_attribute_id'};
$return->{'days_in_advance'} = $row->{'days_in_advance'} if defined $row->{'days_in_advance'};

2
C4/Patroncards.pm

@ -1,5 +1,7 @@
package C4::Patroncards;
use Modern::Perl;
BEGIN {
use vars qw(@EXPORT @ISA);
@ISA = qw(Exporter);

8
C4/Patroncards/Patroncard.pm

@ -227,11 +227,13 @@ sub draw_text {
$parse_line = $2;
}
my $borrower_attributes = get_borrower_attributes($self->{'borrower_number'},@fields);
grep{ # substitute data for db fields
if ($_ =~ m/<([A-Za-z0-9_]+)>/) {
@orig_line = map { # substitute data for db fields
my $l = $_;
if ($l =~ m/<([A-Za-z0-9_]+)>/) {
my $field = $1;
$_ =~ s/$_/$borrower_attributes->{$field}/;
$l =~ s/$l/$borrower_attributes->{$field}/;
}
$l;
} @orig_line;
$line = join(' ',@orig_line);
}

8
C4/Record.pm

@ -375,7 +375,6 @@ sub marc2endnote {
Year => $marc_rec_obj->publication_date,
Abstract => $abstract,
};
my $endnote;
my $style = new Biblio::EndnoteStyle();
my $template;
$template.= "DB - DB\n" if C4::Context->preference("LibraryName");
@ -420,7 +419,7 @@ sub marc2csv {
}
# Preprocessing
eval $preprocess if ($preprocess);
eval $preprocess if ($preprocess); ## no critic (StringyEval)
my $firstpass = 1;
if ( @$itemnumbers ) {
@ -438,7 +437,7 @@ sub marc2csv {
}
# Postprocessing
eval $postprocess if ($postprocess);
eval $postprocess if ($postprocess); ## no critic (StringyEval)
return $output;
}
@ -575,7 +574,6 @@ sub marcrecord2csv {
if ( $content =~ m|\[\%.*\%\]| ) {
my $tt = Template->new();
my $template = $content;
my $vars;
# Replace 00X and 0XX with X or XX
$content =~ s|fields.00(\d)|fields.$1|g;
$content =~ s|fields.0(\d{2})|fields.$1|g;
@ -624,7 +622,7 @@ sub marcrecord2csv {
# Field processing
my $marcfield = $tag->{fieldtag}; # This line fixes a retrocompatibility concern
# The "processing" could be based on the $marcfield variable.
eval $fieldprocessing if ($fieldprocessing);
eval $fieldprocessing if ($fieldprocessing); ## no critic (StringyEval)
push @loop_values, $value;
}

1
C4/Ris.pm

@ -90,7 +90,6 @@ C<$record> - a MARC::Record object
sub marc2ris {
my ($record) = @_;
my $output;
my $marcflavour = C4::Context->preference("marcflavour");
my $intype = lc($marcflavour);

5
C4/Search.pm

@ -88,9 +88,6 @@ sub FindDuplicate {
my $result = TransformMarcToKoha( $record, '' );
my $sth;
my $query;
my $search;
my $type;
my ( $biblionumber, $title );
# search duplicate on ISBN, easy and fast..
# ... normalize first
@ -310,7 +307,6 @@ sub getRecords {
$offset = 0 if $offset < 0;
# Initialize variables for the ZOOM connection and results object
my $zconn;
my @zconns;
my @results;
my $results_hashref = ();
@ -429,7 +425,6 @@ sub getRecords {
}
for ( my $j = $offset ; $j < $times ; $j++ ) {
my $records_hash;
my $record;
## Check if it's an index scan

21
C4/Serials.pm

@ -324,10 +324,13 @@ sub GetFullSubscription {
my $sth = $dbh->prepare($query);
$sth->execute($subscriptionid);
my $subscriptions = $sth->fetchall_arrayref( {} );
my $cannotedit = not can_edit_subscription( $subscriptions->[0] ) if scalar @$subscriptions;
for my $subscription ( @$subscriptions ) {
$subscription->{cannotedit} = $cannotedit;
if (scalar @$subscriptions) {
my $cannotedit = not can_edit_subscription( $subscriptions->[0] );
for my $subscription ( @$subscriptions ) {
$subscription->{cannotedit} = $cannotedit;
}
}
return $subscriptions;
}
@ -347,9 +350,6 @@ sub PrepareSerialsData {
my $year;
my @res;
my $startdate;
my $aqbooksellername;
my $bibliotitle;
my @loopissues;
my $first;
my $previousnote = "";
@ -482,10 +482,13 @@ sub GetFullSubscriptionsFromBiblionumber {
my $sth = $dbh->prepare($query);
$sth->execute($biblionumber);
my $subscriptions = $sth->fetchall_arrayref( {} );
my $cannotedit = not can_edit_subscription( $subscriptions->[0] ) if scalar @$subscriptions;
for my $subscription ( @$subscriptions ) {
$subscription->{cannotedit} = $cannotedit;
if (scalar @$subscriptions) {
my $cannotedit = not can_edit_subscription( $subscriptions->[0] );
for my $subscription ( @$subscriptions ) {
$subscription->{cannotedit} = $cannotedit;
}
}
return $subscriptions;
}

2
C4/Templates.pm

@ -118,7 +118,7 @@ sub output {
$vars = { %$vars, %{ $self->{VARS} } };
my $data;
binmode( STDOUT, ":utf8" );
binmode( STDOUT, ":encoding(UTF-8)" );
$template->process( $self->filename, $vars, \$data )
|| die "Template process failed: ", $template->error();
return $data;

6
Makefile.PL

@ -888,8 +888,8 @@ sub get_install_log_values {
my $install_log = shift;
my $values = shift;
open LOG, "<$install_log" or die "Cannot open install log $install_log: $!\n";
while (<LOG>) {
open my $log, '<', $install_log or die "Cannot open install log $install_log: $!\n";
while (<$log>) {
chomp;
next if /^#/ or /^\s*$/;
next if /^=/;
@ -898,7 +898,7 @@ sub get_install_log_values {
my ($key, $value) = split /=/, $_, 2;
$values->{$key} = $value;
}
close LOG;
close $log;
print <<_EXPLAIN_INSTALL_LOG_;
Reading values from install log $install_log. You

2
docs/CAS/CASProxy/examples/koha_webservice.pl

@ -33,7 +33,7 @@ The Proxy Ticket, needed for check_api_auth, that will try to make the CAS Serve
use utf8;
use Modern::Perl;
binmode(STDOUT, ":utf8");
binmode(STDOUT, ":encoding(UTF-8)");
use C4::Auth qw(check_api_auth);
use C4::Output;

6
docs/CAS/CASProxy/examples/proxy_cas_callback.pl

@ -49,9 +49,9 @@ if ($cgi->param('pgtId')) {
# Now we store the pgtIou and the pgtId in the application vars (in our case a storable object in a file),
# so that the page requesting the webservice can retrieve the pgtId matching it's PgtIou
open FILE, ">", "casSession.tmp" or die "Unable to open file";
nstore_fd({$pgtIou => $pgtId}, \*FILE);
close FILE;
open my $fh, ">", "casSession.tmp" or die "Unable to open file";
nstore_fd({$pgtIou => $pgtId}, $fh);
close $fh;
} else {
warn "Failed to get a Proxy Ticket\n";

6
docs/CAS/CASProxy/examples/proxy_cas_data.pl

@ -54,10 +54,10 @@ if ($cgi->param('PGTIOU')) {
# At this point, we must retrieve the PgtId by matching the PgtIou we
# just received and the PgtIou given by the CAS Server to the callback URL
# The callback page stored it in the application vars (in our case a storable object in a file)
open FILE, "casSession.tmp" or die "Unable to open file";
my $hashref = fd_retrieve(\*FILE);
open my $fh, '<', "casSession.tmp" or die "Unable to open file";
my $hashref = fd_retrieve($fh);
my $pgtId = %{$hashref->{$cgi->param('PGTIOU')}};
close FILE;
close $fh;
# Now that we have a PgtId, we can ask the cas server for a proxy ticket...
my $rp = $cas->proxy( $pgtId, $target_service );

4
fix-perl-path.PL

@ -77,8 +77,8 @@ sub fixshebang{
# to make it writable. Note that stat and chmod
# (the Perl functions) should work on Win32
my $old_perm;
$old_perm = (stat $pathfile)[2] & 07777;
my $new_perm = $old_perm | 0200;
$old_perm = (stat $pathfile)[2] & oct(7777);
my $new_perm = $old_perm | oct(200);
chmod $new_perm, $pathfile;
# tie the file -- note that we're explicitly setting the line (record)

2
installer/data/mysql/labels_upgrade.pl

@ -17,6 +17,8 @@
# You should have received a copy of the GNU General Public License
# along with Koha; if not, see <http://www.gnu.org/licenses>.
use Modern::Perl;
use C4::Context;
my $sth = C4::Context->dbh;

2
installer/data/mysql/patroncards_upgrade.pl

@ -17,6 +17,8 @@
# You should have received a copy of the GNU General Public License
# along with Koha; if not, see <http://www.gnu.org/licenses>.
use Modern::Perl;
use C4::Context;
my $sth = C4::Context->dbh;

16
installer/data/mysql/update22to30.pl

@ -35,7 +35,6 @@ my (
$table,
$column,
$type, $null, $key, $default, $extra,
$prefitem, # preference item in systempreferences table
);
my $silent;
@ -3048,7 +3047,7 @@ my $DBversion = "3.00.00.000";
],
);
foreach $table ( keys %required_prereq_fields ) {
foreach my $table ( keys %required_prereq_fields ) {
print "Check table $table\n" if $debug and not $silent;
$sth = $dbh->prepare("show columns from $table");
$sth->execute();
@ -3157,7 +3156,7 @@ my $DBversion = "3.00.00.000";
# Now add any missing tables
foreach $table ( keys %requiretables ) {
foreach my $table ( keys %requiretables ) {
unless ( $existingtables{$table} ) {
print "Adding $table table...\n" unless $silent;
my $sth = $dbh->prepare("create table $table $requiretables{$table} ENGINE=InnoDB DEFAULT CHARSET=utf8");
@ -3172,7 +3171,7 @@ my $DBversion = "3.00.00.000";
#---------------------------------
# Columns
foreach $table ( keys %requirefields ) {
foreach my $table ( keys %requirefields ) {
print "Check table $table\n" if $debug and not $silent;
$sth = $dbh->prepare("show columns from $table");
$sth->execute();
@ -3181,7 +3180,7 @@ my $DBversion = "3.00.00.000";
{
$types{$column} = $type;
} # while
foreach $column ( keys %{ $requirefields{$table} } ) {
foreach my $column ( keys %{ $requirefields{$table} } ) {
print " Check column $column [$types{$column}]\n" if $debug and not $silent;
if ( !$types{$column} ) {
@ -3200,7 +3199,7 @@ my $DBversion = "3.00.00.000";
} # foreach column
} # foreach table
foreach $table ( sort keys %fielddefinitions ) {
foreach my $table ( sort keys %fielddefinitions ) {
print "Check table $table\n" if $debug;
$sth = $dbh->prepare("show columns from $table");
$sth->execute();
@ -3454,7 +3453,7 @@ my $DBversion = "3.00.00.000";
}
}
# now drop useless tables
foreach $table ( @TableToDelete ) {
foreach my $table ( @TableToDelete ) {
if ( $existingtables{$table} ) {
print "Dropping unused table $table\n" if $debug and not $silent;
$dbh->do("drop table $table");
@ -3499,9 +3498,8 @@ my $DBversion = "3.00.00.000";
}
# at last, remove useless fields
foreach $table ( keys %uselessfields ) {
foreach my $table ( keys %uselessfields ) {
my @fields = split (/,/,$uselessfields{$table});
my $fields;
my $exists;
foreach my $fieldtodrop (@fields) {
$fieldtodrop =~ s/\t//g;

10
installer/data/mysql/updatedatabase.pl

@ -53,14 +53,10 @@ use File::Slurp;
my $debug = 0;
my (
$sth, $sti,
$sth,
$query,
%existingtables, # tables already in database
%types,
$table,
$column,
$type, $null, $key, $default, $extra,
$prefitem, # preference item in systempreferences table
$type,
);
my $schema = Koha::Database->new()->schema();
@ -22241,7 +22237,7 @@ foreach my $file ( sort readdir $dirh ) {
my $rv = $installer->load_sql( $update_dir . $file ) ? 0 : 1;
} elsif ( $file =~ /\.perl$/ ) {
my $code = read_file( $update_dir . $file );
eval $code;
eval $code; ## no critic (StringyEval)
say "Atomic update generated errors: $@" if $@;
}
}

6
installer/externalmodules.pl

@ -12,9 +12,9 @@ qx(grep -r "^ *use" $dir | grep -v "C4\|strict\|vars" >/tmp/modulesKoha.log);
$dir=C4::Context->config('opacdir');
qx(grep -r "^ *use" $dir | grep -v "C4\|strict\|vars" >>/tmp/modulesKoha.log);
open FILE, "< /tmp/modulesKoha.log" ||die "unable to open file /tmp/modulesKoha.log";
open my $fh, '<', '/tmp/modulesKoha.log' ||die "unable to open file /tmp/modulesKoha.log";
my %modulehash;
while (my $line=<FILE>){
while (my $line=<$fh>){
if ( $line=~m#(.*)\:\s*use\s+([A-Z][^\s;]+)# ){
my ($file,$module)=($1,$2);
my @filename = split /\//, $file;
@ -23,5 +23,5 @@ while (my $line=<FILE>){
}
print "external modules used in Koha ARE :\n";
map {print "* $_ \t in files ",join (",",@{$modulehash{$_}}),"\n" } sort keys %modulehash;
close FILE;
close $fh;
unlink "/tmp/modulesKoha.log";

2
installer/install.pl

@ -403,7 +403,7 @@ elsif ( $step && $step == 3 ) {
close $fh;
if (@report) {
$template->param( update_report =>
[ map { local $_ = $_; $_ =~ s/\t/&emsp;&emsp;/g; { line => $_ } } split( /\n/, join( '', @report ) ) ]
[ map { { line => $_ =~ s/\t/&emsp;&emsp;/gr } } split( /\n/, join( '', @report ) ) ]
);
$template->param( has_update_succeeds => 1 );
}

1
misc/admin/koha-preferences

@ -18,6 +18,7 @@
# along with Koha; if not, see <http://www.gnu.org/licenses>.
#
use Modern::Perl;
use Koha::Script;
use C4::Boolean;
use C4::Context;

1
misc/batchRepairMissingBiblionumbers.pl

@ -18,7 +18,6 @@ use C4::Biblio;
my $dbh = C4::Context->dbh;
my %kohafields;
my $sth=$dbh->prepare("SELECT biblio.biblionumber, biblioitemnumber, frameworkcode FROM biblio JOIN biblioitems USING (biblionumber)");
$sth->execute();

2
misc/batchdeletebiblios.pl

@ -8,7 +8,7 @@ use IO::File;
use Koha::Script;
use C4::Biblio;
my ($help, $files);
my $help;
GetOptions(
'h|help' => \$help,
);

1
misc/bin/connexion_import_daemon.pl

@ -132,6 +132,7 @@ sub parse_config {
die "Invalid config line $line: $_" unless defined $v;
$param{$p} = $v;
}
close($conf_fh);
$self->{koha} = delete( $param{koha} )
or die "No koha base url in config file";

6
misc/check_sysprefs.pl

@ -22,8 +22,8 @@ sub check_sys_pref {
if ( !-d _ ) {
my $name = $File::Find::name;
if ( $name =~ /(\.pl|\.pm)$/ ) {
open( FILE, "$_" ) || die "can't open $name";
while ( my $inp = <FILE> ) {
open( my $fh, '<', $_ ) || die "can't open $name";
while ( my $inp = <$fh> ) {
if ( $inp =~ /C4::Context->preference\((.*?)\)/ ) {
my $variable = $1;
$variable =~ s /\'|\"//g;
@ -37,7 +37,7 @@ sub check_sys_pref {
"$name has a reference to $variable, this does not exist in the database\n";
}
}
close FILE;
close $fh;
}
}
$sth->finish();

2
misc/cronjobs/build_browser_and_cloud.pl

@ -22,7 +22,7 @@ use Getopt::Long;
use C4::Log;
my ( $input_marc_file, $number) = ('',0);
my ($version, $confirm,$test_parameter,$field,$batch,$max_digits,$cloud_tag);
my ($version, $confirm,$field,$batch,$max_digits,$cloud_tag);
GetOptions(
'c' => \$confirm,
'h' => \$version,

3
misc/cronjobs/gather_print_notices.pl

@ -25,7 +25,6 @@ use Koha::Util::OpenDocument;
use MIME::Lite;
my (
$stylesheet,
$help,
$split,
$html,
@ -231,7 +230,7 @@ sub generate_csv {
open my $OUTPUT, '>encoding(utf-8)', $filepath
or die "Could not open $filepath: $!";
my ( @csv_lines, $headers );
my $headers;
foreach my $message ( @$messages ) {
my @lines = split /\n/, $message->{content};
chomp for @lines;

3
misc/cronjobs/holds/cancel_expired_holds.pl

@ -17,8 +17,7 @@
# You should have received a copy of the GNU General Public License
# along with Koha; if not, see <http://www.gnu.org/licenses>.
#use strict;
#use warnings; FIXME - Bug 2505
use Modern::Perl;
BEGIN {
# find Koha's Perl modules

6
misc/cronjobs/longoverdue.pl

@ -275,7 +275,7 @@ cronlogaction();
# In my opinion, this line is safe SQL to have outside the API. --atz
our $bounds_sth = C4::Context->dbh->prepare("SELECT DATE_SUB(CURDATE(), INTERVAL ? DAY)");
sub bounds ($) {
sub bounds {
$bounds_sth->execute(shift);
return $bounds_sth->fetchrow;
}
@ -408,10 +408,10 @@ foreach my $startrange (sort keys %$lost) {
$endrange = $startrange;
}
sub summarize ($$) {
sub summarize {
my $arg = shift; # ref to array
my $got_items = shift || 0; # print "count" line for items
my @report = @$arg or return undef;
my @report = @$arg or return;
my $i = 0;
for my $range (@report) {
printf "\nRange %s\nDue %3s - %3s days ago (%s to %s), lost => %s\n", ++$i,

6
misc/cronjobs/rss/rss.pl

@ -74,8 +74,8 @@ sub getConf {
my %return;
my $inSection = 0;
open( FILE, $file ) or die "can't open $file";
while (<FILE>) {
open( my $fh, '<', $file ) or die "can't open $file";
while (<$fh>) {
if ($inSection) {
my @line = split( /=/, $_, 2 );
unless ( $line[1] ) {
@ -91,7 +91,7 @@ sub getConf {
if ( $_ eq "$section\n" ) { $inSection = 1 }
}
}
close FILE;
close $fh;
return %return;
}

1
misc/cronjobs/thirdparty/TalkingTech_itiva_inbound.pl

@ -77,6 +77,7 @@ if ( defined $infile ) {
$updated += $result;
$total++;
}
close($IN);
}
else {
die pod2usage( -verbose => 1 );

2
misc/cronjobs/update_totalissues.pl

@ -72,7 +72,7 @@ my $result = GetOptions(
'h|help' => \$want_help
);
binmode( STDOUT, ":utf8" );
binmode( STDOUT, ":encoding(UTF-8)" );
if ( defined $since && defined $interval ) {
print "The --since and --interval options are mutually exclusive.\n\n";

6
misc/exportauth.pl

@ -17,7 +17,7 @@ use C4::Context;
use C4::Biblio;
use C4::Auth;
my $outfile = $ARGV[0];
open(OUT,">$outfile") or die $!;
open(my $fh, '>', $outfile) or die $!;
my $dbh=C4::Context->dbh;
#$dbh->do("set character_set_client='latin5'");
$dbh->do("set character_set_connection='utf8'");
@ -25,6 +25,6 @@ $dbh->do("set character_set_connection='utf8'");
my $sth=$dbh->prepare("select marc from auth_header order by authid");
$sth->execute();
while (my ($marc) = $sth->fetchrow) {
print OUT $marc;
print $fh $marc;
}
close(OUT);
close($fh);

2
misc/link_bibs_to_authorities.pl

@ -47,7 +47,7 @@ my $result = GetOptions(
'h|help' => \$want_help
);
binmode( STDOUT, ":utf8" );
binmode( STDOUT, ":encoding(UTF-8)" );
if ( not $result or $want_help ) {
usage();

2
misc/maintenance/cmp_sysprefs.pl

@ -34,7 +34,7 @@ use Koha::Script;
use C4::Context;
my $dbh = C4::Context->dbh;
my ( $help, $cmd, $filename, $override, $compare_add, $compare_del, $compare_upd, $ignore_opt, $partial );
my ( $help, $cmd, $filename, $compare_add, $compare_del, $compare_upd, $ignore_opt, $partial );
GetOptions(
'help' => \$help,
'cmd:s' => \$cmd,

1
misc/maintenance/fix_accountlines_rmdupfines_bug8253.pl

@ -76,7 +76,6 @@ $query =
"SELECT * FROM accountlines WHERE description LIKE ? AND description NOT LIKE ?";
$sth = $dbh->prepare($query);
my @fines;
foreach my $keeper (@$results) {
warn "WORKING ON KEEPER: " . Data::Dumper::Dumper( $keeper );

10
misc/maintenance/touch_all_biblios.pl

@ -69,10 +69,11 @@ if ($whereclause) {
}
# output log or STDOUT
my $fh;
if (defined $outfile) {
open (OUT, ">$outfile") || die ("Cannot open output file");
open ($fh, '>', $outfile) || die ("Cannot open output file");
} else {
open(OUT, ">&STDOUT") || die ("Couldn't duplicate STDOUT: $!");
open($fh, '>&', \*STDOUT) || die ("Couldn't duplicate STDOUT: $!");
}
my $sth1 = $dbh->prepare("SELECT biblionumber, frameworkcode FROM biblio $whereclause");
@ -86,15 +87,16 @@ while (my ($biblionumber, $frameworkcode) = $sth1->fetchrow_array){
if ($modok) {
$goodcount++;
print OUT "Touched biblio $biblionumber\n" if (defined $verbose);
print $fh "Touched biblio $biblionumber\n" if (defined $verbose);
} else {
$badcount++;
print OUT "ERROR WITH BIBLIO $biblionumber !!!!\n";
print $fh "ERROR WITH BIBLIO $biblionumber !!!!\n";
}
$totalcount++;
}
close($fh);
# Benchmarking
my $endtime = time();

10
misc/maintenance/touch_all_items.pl

@ -70,10 +70,11 @@ if ($whereclause) {
}
# output log or STDOUT
my $fh;
if (defined $outfile) {
open (OUT, ">$outfile") || die ("Cannot open output file");
open ($fh, '>', $outfile) || die ("Cannot open output file");
} else {
open(OUT, ">&STDOUT") || die ("Couldn't duplicate STDOUT: $!");
open($fh, '>&', \*STDOUT) || die ("Couldn't duplicate STDOUT: $!");
}
# FIXME Would be better to call Koha::Items->search here
@ -88,15 +89,16 @@ while (my ($biblionumber, $itemnumber, $itemcallnumber) = $sth_fetch->fetchrow_a
if ($modok) {
$goodcount++;
print OUT "Touched item $itemnumber\n" if (defined $verbose);
print $fh "Touched item $itemnumber\n" if (defined $verbose);
} else {
$badcount++;
print OUT "ERROR WITH ITEM $itemnumber !!!!\n";
print $fh "ERROR WITH ITEM $itemnumber !!!!\n";
}
$totalcount++;
}
close($fh);
# Benchmarking
my $endtime = time();

5
misc/migration_tools/22_to_30/export_Authorities.pl

@ -1,6 +1,5 @@
#!/usr/bin/perl
#use strict;
#use warnings; FIXME - Bug 2505
use Modern::Perl;
BEGIN {
# find Koha's Perl modules
# test carefully before changing this
@ -32,7 +31,7 @@ while (my ($authid,$authtypecode)=$rq->fetchrow){
if (C4::Context->preference('marcflavour') eq "UNIMARC"){
$record->leader(' nac 22 1u 4500');
my $string=$1 if $time=~m/([0-9\-]+)/;
my $string= ($time=~m/([0-9\-]+)/) ? $1 : undef
$string=~s/\-//g;
$string = sprintf("%-*s",26, $string);
substr($string,9,6,"frey50");

5
misc/migration_tools/22_to_30/export_Authorities_xml.pl

@ -1,6 +1,5 @@
#!/usr/bin/perl
#use strict;
#use warnings; FIXME - Bug 2505
use Modern::Perl;
BEGIN {
# find Koha's Perl modules
# test carefully before changing this
@ -31,7 +30,7 @@ open my $fileoutput, '>:encoding(UTF-8)', "./$filename/$authid.xml" or die "unab
# if (C4::Context->preference('marcflavour') eq "UNIMARC"){
$record->leader(' nac 22 1u 4500');
my $string=$1 if $time=~m/([0-9\-]+)/;
my $string = ($time=~m/([0-9\-]+)/) ? $1 : undef
$string=~s/\-//g;
$string = sprintf("%-*s",26, $string);
substr($string,9,6,"frey50");

3
misc/migration_tools/22_to_30/move_marc_to_biblioitems.pl

@ -1,6 +1,5 @@
#!/usr/bin/perl
#use strict;
#use warnings; FIXME - Bug 2505
use Modern::Perl;
# script to shift marc to biblioitems
# scraped from updatedatabase for dev week by chris@katipo.co.nz
BEGIN {

2
misc/migration_tools/buildCOUNTRY.pl

@ -14,7 +14,7 @@ use Time::HiRes qw(gettimeofday);
use Getopt::Long;
my ( $fields, $number,$language) = ('',0);
my ($version, $verbose, $test_parameter, $field,$delete,$subfields);
my ($version, $verbose, $test_parameter, $delete);
GetOptions(
'h' => \$version,
'd' => \$delete,

1
misc/migration_tools/buildEDITORS.pl

@ -67,7 +67,6 @@ my $starttime = gettimeofday;
my $sth = $dbh->prepare("select bibid from marc_biblio");
$sth->execute;
my $i=1;
my %alreadydone;
my $counter;
my %hash;
while (my ($bibid) = $sth->fetchrow) {

2
misc/migration_tools/buildLANG.pl

@ -14,7 +14,7 @@ use Time::HiRes qw(gettimeofday);
use Getopt::Long;
my ( $fields, $number,$language) = ('',0);
my ($version, $verbose, $test_parameter, $field,$delete,$subfields);
my ($version, $verbose, $test_parameter, $delete);
GetOptions(
'h' => \$version,
'd' => \$delete,

7
misc/migration_tools/bulkmarcimport.pl

@ -147,8 +147,9 @@ if($marc_mod_template ne '') {
my $dbh = C4::Context->dbh;
my $heading_fields=get_heading_fields();
my $idmapfh;
if (defined $idmapfl) {
open(IDMAP,">$idmapfl") or die "cannot open $idmapfl \n";
open($idmapfh, '>', $idmapfl) or die "cannot open $idmapfl \n";
}
if ((not defined $sourcesubfield) && (not defined $sourcetag)){
@ -441,11 +442,11 @@ RECORD: while ( ) {
if ($sourcetag < "010"){
if ($record->field($sourcetag)){
my $source = $record->field($sourcetag)->data();
printf(IDMAP "%s|%s\n",$source,$biblionumber);
printf($idmapfh "%s|%s\n",$source,$biblionumber);
}
} else {
my $source=$record->subfield($sourcetag,$sourcesubfield);
printf(IDMAP "%s|%s\n",$source,$biblionumber);
printf($idmapfh "%s|%s\n",$source,$biblionumber);
}
}
# create biblio, unless we already have it ( either match or isbn )

1
misc/migration_tools/remove_unused_authorities.pl