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

t/perlcriticrc → .perlcriticrc View File

@@ -10,3 +10,5 @@ equivalent_modules = Modern::Perl

[TestingAndDebugging::RequireUseWarnings]
equivalent_modules = Modern::Perl

[-Modules::RequireBarewordIncludes]

+ 0
- 1
C4/Accounts.pm View File

@@ -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;


+ 0
- 1
C4/Acquisition.pm View File

@@ -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;


+ 9
- 9
C4/Auth_with_cas.pm View File

@@ -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__



+ 0
- 1
C4/AuthoritiesMarc.pm View File

@@ -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
- 0
C4/Barcodes/ValueBuilder.pm View File

@@ -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;



+ 4
- 4
C4/Barcodes/annual.pm View File

@@ -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-


+ 0
- 1
C4/Biblio.pm View File

@@ -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;


+ 2
- 2
C4/ClassSortRoutine.pm View File

@@ -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;


+ 1
- 1
C4/ClassSplitRoutine/RegEx.pm View File

@@ -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;



+ 0
- 2
C4/Context.pm View File

@@ -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;


+ 1
- 1
C4/CourseReserves.pm View File

@@ -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
- 0
C4/Creators.pm View File

@@ -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);


+ 1
- 1
C4/Creators/Lib.pm View File

@@ -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 = ();


+ 6
- 6
C4/ImportBatch.pm View File

@@ -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({


+ 0
- 1
C4/InstallAuth.pm View File

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

if ($logout) {



+ 0
- 1
C4/Items.pm View File

@@ -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
- 0
C4/Labels.pm View File

@@ -1,5 +1,7 @@
package C4::Labels;

use Modern::Perl;

BEGIN {

use C4::Labels::Batch;


+ 2
- 3
C4/Labels/Label.pm View File

@@ -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,


+ 1
- 3
C4/Languages.pm View File

@@ -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


+ 0
- 1
C4/Letters.pm View File

@@ -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;


+ 1
- 1
C4/Matcher.pm View File

@@ -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'};


+ 0
- 1
C4/Members/Messaging.pm View File

@@ -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
- 0
C4/Patroncards.pm View File

@@ -1,5 +1,7 @@
package C4::Patroncards;

use Modern::Perl;

BEGIN {
use vars qw(@EXPORT @ISA);
@ISA = qw(Exporter);


+ 5
- 3
C4/Patroncards/Patroncard.pm View File

@@ -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);
}


+ 3
- 5
C4/Record.pm View File

@@ -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;
}


+ 0
- 1
C4/Ris.pm View File

@@ -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);


+ 0
- 5
C4/Search.pm View File

@@ -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


+ 12
- 9
C4/Serials.pm View File

@@ -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;
}



+ 1
- 1
C4/Templates.pm View File

@@ -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;


+ 3
- 3
Makefile.PL View File

@@ -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


+ 1
- 1
docs/CAS/CASProxy/examples/koha_webservice.pl View File

@@ -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;


+ 3
- 3
docs/CAS/CASProxy/examples/proxy_cas_callback.pl View File

@@ -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";


+ 3
- 3
docs/CAS/CASProxy/examples/proxy_cas_data.pl View File

@@ -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 );


+ 2
- 2
fix-perl-path.PL View File

@@ -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
- 0
installer/data/mysql/labels_upgrade.pl View File

@@ -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
- 0
installer/data/mysql/patroncards_upgrade.pl View File

@@ -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;


+ 7
- 9
installer/data/mysql/update22to30.pl View File

@@ -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;


+ 3
- 7
installer/data/mysql/updatedatabase.pl View File

@@ -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 $@;
}
}


+ 3
- 3
installer/externalmodules.pl View File

@@ -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";

+ 1
- 1
installer/install.pl View File

@@ -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
- 0
misc/admin/koha-preferences View File

@@ -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;


+ 0
- 1
misc/batchRepairMissingBiblionumbers.pl View File

@@ -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();


+ 1
- 1
misc/batchdeletebiblios.pl View File

@@ -8,7 +8,7 @@ use IO::File;
use Koha::Script;
use C4::Biblio;

my ($help, $files);
my $help;
GetOptions(
'h|help' => \$help,
);


+ 1
- 0
misc/bin/connexion_import_daemon.pl View File

@@ -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";


+ 3
- 3
misc/check_sysprefs.pl View File

@@ -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();


+ 1
- 1
misc/cronjobs/build_browser_and_cloud.pl View File

@@ -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,


+ 1
- 2
misc/cronjobs/gather_print_notices.pl View File

@@ -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;


+ 1
- 2
misc/cronjobs/holds/cancel_expired_holds.pl View File

@@ -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


+ 3
- 3
misc/cronjobs/longoverdue.pl View File

@@ -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,


+ 3
- 3
misc/cronjobs/rss/rss.pl View File

@@ -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
- 0
misc/cronjobs/thirdparty/TalkingTech_itiva_inbound.pl View File

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


+ 1
- 1
misc/cronjobs/update_totalissues.pl View File

@@ -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";


+ 3
- 3
misc/exportauth.pl View File

@@ -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);

+ 1
- 1
misc/link_bibs_to_authorities.pl View File

@@ -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();


+ 1
- 1
misc/maintenance/cmp_sysprefs.pl View File

@@ -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,


+ 0
- 1
misc/maintenance/fix_accountlines_rmdupfines_bug8253.pl View File

@@ -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 );


+ 6
- 4
misc/maintenance/touch_all_biblios.pl View File

@@ -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();


+ 6
- 4
misc/maintenance/touch_all_items.pl View File

@@ -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();


+ 2
- 3
misc/migration_tools/22_to_30/export_Authorities.pl View File

@@ -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");


+ 2
- 3
misc/migration_tools/22_to_30/export_Authorities_xml.pl View File

@@ -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");


+ 1
- 2
misc/migration_tools/22_to_30/move_marc_to_biblioitems.pl View File

@@ -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 {


+ 1
- 1
misc/migration_tools/buildCOUNTRY.pl View File

@@ -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,


+ 0
- 1
misc/migration_tools/buildEDITORS.pl View File

@@ -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) {


+ 1
- 1
misc/migration_tools/buildLANG.pl View File

@@ -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,


+ 4
- 3
misc/migration_tools/bulkmarcimport.pl View File

@@ -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 )


+ 0
- 1
misc/migration_tools/remove_unused_authorities.pl View File

@@ -71,7 +71,6 @@ unless ($nb > 0) {
}

my $dbh=C4::Context->dbh;
my @results;
# prepare the request to retrieve all authorities of the requested types
my $rqsql = q{ SELECT authid,authtypecode FROM auth_header };
$rqsql .= q{ WHERE authtypecode IN (}.join(',',map{ '?' }@authtypes).')' if @authtypes;


+ 1
- 1
misc/perlmodule_rm.pl View File

@@ -2,7 +2,7 @@

# Remove a perl module

use warnings;
use Modern::Perl;
use ExtUtils::Packlist;
use ExtUtils::Installed;



+ 1
- 1
misc/translator/LangInstaller.pm View File

@@ -1087,7 +1087,7 @@ sub get_all_langs {
opendir( my $dh, $self->{path_po} );
my @files = grep { $_ =~ /-pref.(po|po.gz)$/ }
readdir $dh;
@files = map { $_ =~ s/-pref.(po|po.gz)$//; $_ } @files;
@files = map { $_ =~ s/-pref.(po|po.gz)$//r } @files;
}




+ 28
- 28
misc/translator/TmplTokenizer.pm View File

@@ -138,7 +138,7 @@ BEGIN {
sub parenleft () { '(' }
sub parenright () { ')' }

sub _split_js ($) {
sub _split_js {
my ($s0) = @_;
my @it = ();
while (length $s0) {
@@ -190,7 +190,7 @@ sub STATE_STRING_LITERAL () { 3 }

# XXX This is a crazy hack. I don't want to write an ECMAScript parser.
# XXX A scanner is one thing; a parser another thing.
sub _identify_js_translatables (@) {
sub _identify_js_translatables {
my @input = @_;
my @output = ();
# We mark a JavaScript translatable string as in C, i.e., _("literal")
@@ -227,7 +227,7 @@ sub _identify_js_translatables (@) {

###############################################################################

sub string_canon ($) {
sub string_canon {
my $s = shift;
# Fold all whitespace into single blanks
$s =~ s/\s+/ /g;
@@ -236,7 +236,7 @@ sub string_canon ($) {
}

# safer version used internally, preserves new lines
sub string_canon_safe ($) {
sub string_canon_safe {
my $s = shift;
# fold tabs and spaces into single spaces
$s =~ s/[\ \t]+/ /gs;
@@ -252,7 +252,7 @@ sub _quote_cformat{

sub _formalize_string_cformat{
my $s = shift;
return _quote_cformat( string_canon_safe $s );
return _quote_cformat( string_canon_safe($s) );
}

sub _formalize{
@@ -314,7 +314,7 @@ sub next_token {
return $self->_parametrize_internal(@parts);
}
else {
return undef;
return;
}
}
# if cformat mode is off, dont bother parametrizing, just return them as they come
@@ -337,7 +337,7 @@ sub next_token {
push @tail, $3;
$s0 = $2;
}
push @head, _split_js $s0;
push @head, _split_js($s0);
$next->set_js_data(_identify_js_translatables(@head, @tail) );
return $next unless @parts;
$self->{_parser}->unshift_token($next);
@@ -359,7 +359,7 @@ sub next_token {

# function taken from old version
# used by tmpl_process3
sub parametrize ($$$$) {
sub parametrize {
my($fmt_0, $cformat_p, $t, $f) = @_;
my $it = '';
if ($cformat_p) {
@@ -379,13 +379,13 @@ sub parametrize ($$$$) {
;
} elsif (defined $params[$i - 1]) {
my $param = $params[$i - 1];
warn_normal "$fmt_0: $&: Expected a TMPL_VAR, but found a "
. $param->type->to_string . "\n", undef
warn_normal("$fmt_0: $&: Expected a TMPL_VAR, but found a "
. $param->type->to_string . "\n", undef)
if $param->type != C4::TmplTokenType::DIRECTIVE;
warn_normal "$fmt_0: $&: Unsupported "
. "field width or precision\n", undef
warn_normal("$fmt_0: $&: Unsupported "
. "field width or precision\n", undef)
if defined $width || defined $prec;
warn_normal "$fmt_0: $&: Parameter $i not known", undef
warn_normal("$fmt_0: $&: Parameter $i not known", undef)
unless defined $param;
$it .= defined $f? &$f( $param ): $param->string;
}
@@ -396,27 +396,27 @@ sub parametrize ($$$$) {

my $param = $params[$i - 1];
if (!defined $param) {
warn_normal "$fmt_0: $&: Parameter $i not known", undef;
warn_normal("$fmt_0: $&: Parameter $i not known", undef);
} else {
if ($param->type == C4::TmplTokenType::TAG
&& $param->string =~ /^<input\b/is) {
my $type = defined $param->attributes?
lc($param->attributes->{'type'}->[1]): undef;
if ($conv eq 'S') {
warn_normal "$fmt_0: $&: Expected type=text, "
. "but found type=$type", undef
warn_normal("$fmt_0: $&: Expected type=text, "
. "but found type=$type", undef)
unless $type eq 'text';
} elsif ($conv eq 'p') {
warn_normal "$fmt_0: $&: Expected type=radio, "
. "but found type=$type", undef
warn_normal("$fmt_0: $&: Expected type=radio, "
. "but found type=$type", undef)
unless $type eq 'radio';
}
} else {
warn_normal "$&: Expected an INPUT, but found a "
. $param->type->to_string . "\n", undef
warn_normal("$&: Expected an INPUT, but found a "
. $param->type->to_string . "\n", undef)
}
warn_normal "$fmt_0: $&: Unsupported "
. "field width or precision\n", undef
warn_normal("$fmt_0: $&: Unsupported "
. "field width or precision\n", undef)
if defined $width || defined $prec;
$it .= defined $f? &$f( $param ): $param->string;
}
@@ -439,7 +439,7 @@ sub parametrize ($$$$) {
my $i = $1;
$fmt = $';
my $anchor = $anchors[$i - 1];
warn_normal "$&: Anchor $1 not found for msgid \"$fmt_0\"", undef #FIXME
warn_normal("$&: Anchor $1 not found for msgid \"$fmt_0\"", undef) #FIXME
unless defined $anchor;
$it .= $anchor->string;
} else {
@@ -452,12 +452,12 @@ sub parametrize ($$$$) {

# Other simple functions (These are not methods)

sub blank_p ($) {
sub blank_p {
my($s) = @_;
return $s =~ /^(?:\s|\&nbsp$re_end_entity|$re_tmpl_var|$re_xsl)*$/osi;
}

sub trim ($) {
sub trim {
my($s0) = @_;
my $l0 = length $s0;
my $s = $s0;
@@ -466,7 +466,7 @@ sub trim ($) {
return wantarray? (substr($s0, 0, $l1), $s, substr($s0, $l0 - $l2)): $s;
}

sub quote_po ($) {
sub quote_po {
my($s) = @_;
# Locale::PO->quote is buggy, it doesn't quote newlines :-/
$s =~ s/([\\"])/\\$1/gs;
@@ -475,7 +475,7 @@ sub quote_po ($) {
return "\"$s\"";
}

sub charset_canon ($) {
sub charset_canon {
my($charset) = @_;
$charset = uc($charset);
$charset = "$1-$2" if $charset =~ /^(ISO|UTF)(\d.*)/i;
@@ -508,7 +508,7 @@ use vars qw( @latin1_utf8 );
"\303\270", "\303\271", "\303\272", "\303\273", "\303\274", "\303\275",
"\303\276", "\303\277" );

sub charset_convert ($$$) {
sub charset_convert {
my($s, $charset_in, $charset_out) = @_;
if ($s !~ /[\200-\377]/s) { # FIXME: don't worry about iso2022 for now
;


+ 12
- 12
misc/translator/VerboseWarnings.pm View File

@@ -40,32 +40,32 @@ verbose warnings.
use vars qw( $appName $input $input_abbr $pedantic_p $pedantic_tag $quiet);
use vars qw( $warned $erred );

sub set_application_name ($) {
sub set_application_name {
my($s) = @_;
$appName = $& if !defined $appName && $s =~ /[^\/]+$/;
}

sub application_name () {
sub application_name {
return $appName;
}

sub set_input_file_name ($) {
sub set_input_file_name {
my($s) = @_;
$input = $s;
$input_abbr = $& if defined $s && $s =~ /[^\/]+$/;
}

sub set_pedantic_mode ($) {
sub set_pedantic_mode {
my($p) = @_;
$pedantic_p = $p;
$pedantic_tag = $pedantic_p? '': ' (negligible)';
}

sub pedantic_p () {
sub pedantic_p {
return $pedantic_p;
}

sub construct_warn_prefix ($$) {
sub construct_warn_prefix {
my($prefix, $lc) = @_;
die "construct_warn_prefix called before set_application_name"
unless defined $appName;
@@ -80,20 +80,20 @@ sub construct_warn_prefix ($$) {
return "$appName: $prefix: " . (defined $lc? "$input_abbr: line $lc: ": defined $input_abbr? "$input_abbr: ": '');
}

sub warn_additional ($$) {
sub warn_additional {
my($msg, $lc) = @_;
my $prefix = construct_warn_prefix('Warning', $lc);
$msg .= "\n" unless $msg =~ /\n$/s;
warn "$prefix$msg";
}

sub warn_normal ($$) {
sub warn_normal {
my($msg, $lc) = @_;
$warned += 1;
warn_additional($msg, $lc);
}

sub warn_pedantic ($$$) {
sub warn_pedantic {
my($msg, $lc, $flag) = @_;
my $prefix = construct_warn_prefix("Warning$pedantic_tag", $lc);
$msg .= "\n" unless $msg =~ /\n$/s;
@@ -106,20 +106,20 @@ sub warn_pedantic ($$$) {
$warned += 1;
}

sub error_additional ($$) {
sub error_additional {
my($msg, $lc) = @_;
my $prefix = construct_warn_prefix('ERROR', $lc);
$msg .= "\n" unless $msg =~ /\n$/s;
warn "$prefix$msg";
}

sub error_normal ($$) {
sub error_normal {
my($msg, $lc) = @_;
$erred += 1;
error_additional($msg, $lc);
}

sub warned () {
sub warned {
return $warned; # number of times warned
}



+ 9
- 5
misc/translator/po2json View File

@@ -37,7 +37,7 @@ sub usage {

sub main
{
my ($src_fh, $src);
my $src;

my $pretty = 0;
if ($ARGV[0] =~ /^--?p$/) {
@@ -124,7 +124,8 @@ sub main
# on a normal msgid
} else {
my $qmsgctxt = $po->msgctxt;
my $msgctxt = $po->dequote($qmsgctxt) if $qmsgctxt;
my $msgctxt;
$msgctxt = $po->dequote($qmsgctxt) if $qmsgctxt;

# build the new msgid key
my $msg_ctxt_id = defined($msgctxt) ? join($gettext_context_glue, ($msgctxt, $msgid1)) : $msgid1;
@@ -134,7 +135,8 @@ sub main

# msgid plural side
my $qmsgid_plural = $po->msgid_plural;
my $msgid2 = $po->dequote( $qmsgid_plural ) if $qmsgid_plural;
my $msgid2;
$msgid2 = $po->dequote( $qmsgid_plural ) if $qmsgid_plural;
push(@trans, $msgid2);

# translated string
@@ -145,14 +147,16 @@ sub main
for (my $i=0; $i<$plural_form_count; $i++)
{
my $qstr = ref($plurals) ? $$plurals{$i} : undef;
my $str = $po->dequote( $qstr ) if $qstr;
my $str;
$str = $po->dequote( $qstr ) if $qstr;
push(@trans, $str);
}

# singular
} else {
my $qmsgstr = $po->msgstr;
my $msgstr = $po->dequote( $qmsgstr ) if $qmsgstr;
my $msgstr;
$msgstr = $po->dequote( $qmsgstr ) if $qmsgstr;
push(@trans, $msgstr);
}



+ 40
- 41
misc/translator/tmpl_process3.pl View File

@@ -35,7 +35,7 @@ use vars qw( $charset_in $charset_out );

###############################################################################

sub find_translation ($) {
sub find_translation {
my($s) = @_;
my $key = $s;
if ($s =~ /\S/s) {
@@ -56,13 +56,13 @@ sub find_translation ($) {
}
}

sub text_replace_tag ($$) {
sub text_replace_tag {
my($t, $attr) = @_;
my $it;
my @ttvar;

# value [tag=input], meta
my $tag = lc($1) if $t =~ /^<(\S+)/s;
my $tag = ($t =~ /^<(\S+)/s) ? lc($1) : undef;
my $translated_p = 0;
for my $a ('alt', 'content', 'title', 'value', 'label', 'placeholder') {
if ($attr->{$a}) {
@@ -117,10 +117,10 @@ sub text_replace_tag ($$) {
return $it;
}

sub text_replace (**) {
sub text_replace {
my($h, $output) = @_;
for (;;) {
my $s = TmplTokenizer::next_token $h;
my $s = TmplTokenizer::next_token($h);
last unless defined $s;
my($kind, $t, $attr) = ($s->type, $s->string, $s->attributes);
if ($kind eq C4::TmplTokenType::TEXT) {
@@ -138,7 +138,7 @@ sub text_replace (**) {
for my $t (@{$s->js_data}) {
# FIXME for this whole block
if ($t->[0]) {
printf $output "%s%s%s", $t->[2], find_translation $t->[3],
printf $output "%s%s%s", $t->[2], find_translation($t->[3]),
$t->[2];
} else {
print $output $t->[1];
@@ -178,14 +178,14 @@ sub listfiles {
}
}
} else {
warn_normal "$dir: $!", undef;
warn_normal("$dir: $!", undef);
}
return @it;
}

###############################################################################

sub mkdir_recursive ($) {
sub mkdir_recursive {
my($dir) = @_;
local($`, $&, $', $1);
$dir = $` if $dir ne /^\/+$/ && $dir =~ /\/+$/;
@@ -194,13 +194,13 @@ sub mkdir_recursive ($) {
if (!-d $dir) {
print STDERR "Making directory $dir...\n" unless $quiet;
# creates with rwxrwxr-x permissions
mkdir($dir, 0775) || warn_normal "$dir: $!", undef;
mkdir($dir, 0775) || warn_normal("$dir: $!", undef);
}
}

###############################################################################

sub usage ($) {
sub usage {
my($exitcode) = @_;
my $h = $exitcode? *STDERR: *STDOUT;
print $h <<EOF;
@@ -238,7 +238,7 @@ EOF

###############################################################################

sub usage_error (;$) {
sub usage_error {
for my $msg (split(/\n/, $_[0])) {
print STDERR "$msg\n";
}
@@ -260,10 +260,10 @@ GetOptions(
'quiet|q' => \$quiet,
'pedantic-warnings|pedantic' => sub { $pedantic_p = 1 },
'help' => \&usage,
) || usage_error;
) || usage_error();

VerboseWarnings::set_application_name $0;
VerboseWarnings::set_pedantic_mode $pedantic_p;
VerboseWarnings::set_application_name($0);
VerboseWarnings::set_pedantic_mode($pedantic_p);

# keep the buggy Locale::PO quiet if it says stupid things
$SIG{__WARN__} = sub {
@@ -307,7 +307,7 @@ $href = Locale::PO->load_file_ashash($str_file, 'utf-8');
# guess the charsets. HTML::Templates defaults to iso-8859-1
if (defined $href) {
die "$str_file: PO file is corrupted, or not a PO file\n" unless defined $href->{'""'};
$charset_out = TmplTokenizer::charset_canon $2 if $href->{'""'}->msgstr =~ /\bcharset=(["']?)([^;\s"'\\]+)\1/;
$charset_out = TmplTokenizer::charset_canon($2) if $href->{'""'}->msgstr =~ /\bcharset=(["']?)([^;\s"'\\]+)\1/;
$charset_in = $charset_out;
# for my $msgid (keys %$href) {
# if ($msgid =~ /\bcharset=(["']?)([^;\s"'\\]+)\1/) {
@@ -326,22 +326,22 @@ if (defined $href) {
next if $id_count == $str_count ||
$msg->{msgstr} eq '""' ||
grep { /fuzzy/ } @{$msg->{_flags}};
warn_normal
warn_normal(
"unconsistent %s count: ($id_count/$str_count):\n" .
" line: " . $msg->{loaded_line_number} . "\n" .
" msgid: " . $msg->{msgid} . "\n" .
" msgstr: " . $msg->{msgstr} . "\n", undef;
" msgstr: " . $msg->{msgstr} . "\n", undef);
}
}

# set our charset in to UTF-8
if (!defined $charset_in) {
$charset_in = TmplTokenizer::charset_canon 'UTF-8';
$charset_in = TmplTokenizer::charset_canon('UTF-8');
warn "Warning: Can't determine original templates' charset, defaulting to $charset_in\n" unless ( $quiet );
}
# set our charset out to UTF-8
if (!defined $charset_out) {
$charset_out = TmplTokenizer::charset_canon 'UTF-8';
$charset_out = TmplTokenizer::charset_canon('UTF-8');
warn "Warning: Charset Out defaulting to $charset_out\n" unless ( $quiet );
}
my $xgettext = './xgettext.pl'; # actual text extractor script
@@ -376,23 +376,22 @@ if ($action eq 'create') {
# FIXME: msgmerge(1) is a Unix dependency
# FIXME: need to check the return value
unless (-f $str_file) {
local(*INPUT, *OUTPUT);
open(INPUT, "<$tmpfile2");
open(OUTPUT, ">$str_file");
while (<INPUT>) {
print OUTPUT;
open(my $infh, '<', $tmpfile2);
open(my $outfh, '>', $str_file);
while (<$infh>) {
print $outfh;
last if /^\n/s;
}
close INPUT;
close OUTPUT;
close $infh;
close $outfh;
}
$st = system("msgmerge ".($quiet?'-q':'')." -s $str_file $tmpfile2 -o - | msgattrib --no-obsolete -o $str_file");
} else {
error_normal "Text extraction failed: $xgettext: $!\n", undef;
error_additional "Will not run msgmerge\n", undef;
error_normal("Text extraction failed: $xgettext: $!\n", undef);
error_additional("Will not run msgmerge\n", undef);
}
unlink $tmpfile1 || warn_normal "$tmpfile1: unlink failed: $!\n", undef;
unlink $tmpfile2 || warn_normal "$tmpfile2: unlink failed: $!\n", undef;
unlink $tmpfile1 || warn_normal("$tmpfile1: unlink failed: $!\n", undef);
unlink $tmpfile2 || warn_normal("$tmpfile2: unlink failed: $!\n", undef);

} elsif ($action eq 'update') {
my($tmph1, $tmpfile1) = tmpnam();
@@ -421,11 +420,11 @@ if ($action eq 'create') {
$st = system("msgmerge ".($quiet?'-q':'')." -s $str_file $tmpfile2 -o - | msgattrib --no-obsolete -o $str_file");
}
} else {
error_normal "Text extraction failed: $xgettext: $!\n", undef;
error_additional "Will not run msgmerge\n", undef;
error_normal("Text extraction failed: $xgettext: $!\n", undef);
error_additional("Will not run msgmerge\n", undef);
}
unlink $tmpfile1 || warn_normal "$tmpfile1: unlink failed: $!\n", undef;
unlink $tmpfile2 || warn_normal "$tmpfile2: unlink failed: $!\n", undef;
unlink $tmpfile1 || warn_normal("$tmpfile1: unlink failed: $!\n", undef);
unlink $tmpfile2 || warn_normal("$tmpfile2: unlink failed: $!\n", undef);

} elsif ($action eq 'install') {
if(!defined($out_dir)) {
@@ -448,8 +447,8 @@ if ($action eq 'create') {
-d $out_dir || die "$out_dir: The directory does not exist\n";

# Try to open the file, because Locale::PO doesn't check :-/
open(INPUT, "<$str_file") || die "$str_file: $!\n";
close INPUT;
open(my $fh, '<', $str_file) || die "$str_file: $!\n";
close $fh;

# creates the new tmpl file using the new translation
for my $input (@in_files) {
@@ -457,17 +456,17 @@ if ($action eq 'create') {
unless substr($input, 0, length($in_dir) + 1) eq "$in_dir/";

my $target = $out_dir . substr($input, length($in_dir));
my $targetdir = $` if $target =~ /[^\/]+$/s;
my $targetdir = ($target =~ /[^\/]+$/s) ? $` : undef;