Koha-community/Koha
15
7
Fork 0
Code Issues Releases Wiki Activity

Bug 21395: Make perlcritic happy

Browse source 
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>
This commit is contained in:
Julian Maurice 2018-09-21 18:05:42 +02:00 committed by Jonathan Druart
parent 9d890c7636
commit b168f4a2e9
129 changed files with 342 additions and 427 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
t/perlcriticrc → .perlcriticrc
View file

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

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;

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;

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

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

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

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;

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

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

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;

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

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

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

1
C4/InstallAuth.pm
View file

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

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
C4/Labels.pm
View file

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

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

4
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

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;

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

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
C4/Patroncards.pm
View file

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

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

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

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

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

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

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

6
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

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

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

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

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

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

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

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

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

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

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

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

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

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

3
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

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

6
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
misc/cronjobs/thirdparty/TalkingTech_itiva_inbound.pl vendored
View file

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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;

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

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

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

24
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
}

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

81
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;
if (!defined $type || $input =~ /\.(?:$type)$/) {
my $h = TmplTokenizer->new( $input );
$h->set_allow_cformat( 1 );
VerboseWarnings::set_input_file_name $input;
VerboseWarnings::set_input_file_name($input);
mkdir_recursive($targetdir) unless -d $targetdir;
print STDERR "Creating $target...\n" unless $quiet;
open( OUTPUT, ">:encoding(UTF-8)", "$target" ) || die "$target: $!\n";
text_replace( $h, *OUTPUT );
close OUTPUT;
open( my $fh, ">:encoding(UTF-8)", "$target" ) || die "$target: $!\n";
text_replace( $h, $fh );
close $fh;
} else {
# just copying the file
mkdir_recursive($targetdir) unless -d $targetdir;

28
misc/translator/xgettext.pl
View file

@ -102,7 +102,7 @@ sub string_list {
sub text_extract {
my($h) = @_;
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) {
@ -124,7 +124,7 @@ sub text_extract {
next if $a eq 'value' && ($tag ne 'input'
|| (ref $attr->{'type'} && $attr->{'type'}->[1] =~ /^(?:hidden|radio|checkbox)$/)); # FIXME
my($key, $val, $val_orig, $order) = @{$attr->{$a}}; #FIXME
$val = TmplTokenizer::trim $val;
$val = TmplTokenizer::trim($val);
# for selected attributes replace '[%..%]' with '%s' globally
if ( $a =~ /title|value|alt|content|placeholder/ ) {
$val =~ s/\[\%.*?\%\]/\%s/g;
@ -155,7 +155,7 @@ sub generate_strings_list {
sub generate_po_file {
# We don't emit the Plural-Forms header; it's meaningless for us
my $pot_charset = (defined $charset_out? $charset_out: 'CHARSET');
$pot_charset = TmplTokenizer::charset_canon $pot_charset;
$pot_charset = TmplTokenizer::charset_canon($pot_charset);
# Time stamps aren't exactly right semantically. I don't know how to fix it.
my $time = POSIX::strftime('%Y-%m-%d %H:%M%z', localtime(time));
my $time_pot = $time;
@ -244,9 +244,11 @@ EOF
$cformat_p = 1 if $token->type == C4::TmplTokenType::TEXT_PARAMETRIZED;
}
printf $OUTPUT "#, c-format\n" if $cformat_p;
printf $OUTPUT "msgid %s\n", TmplTokenizer::quote_po
TmplTokenizer::string_canon
TmplTokenizer::charset_convert $t, $charset_in, $charset_out;
printf $OUTPUT "msgid %s\n", TmplTokenizer::quote_po(
TmplTokenizer::string_canon(
TmplTokenizer::charset_convert($t, $charset_in, $charset_out)
)
);
printf $OUTPUT "msgstr %s\n\n", (defined $translation{$t}?
TmplTokenizer::quote_po( $translation{$t} ): "\"\"");
}
@ -256,7 +258,7 @@ EOF
sub convert_translation_file {
open(my $INPUT, '<:encoding(utf-8)', $convert_from) || die "$convert_from: $!\n";
VerboseWarnings::set_input_file_name $convert_from;
VerboseWarnings::set_input_file_name($convert_from);
while (<$INPUT>) {
chomp;
my($msgid, $msgstr) = split(/\t/);
@ -273,13 +275,13 @@ sub convert_translation_file {
$translation{$msgid} = $msgstr unless $msgstr eq '*****';
if ($msgid =~ /\bcharset=(["']?)([^;\s"']+)\1/s) {
my $candidate = TmplTokenizer::charset_canon $2;
my $candidate = TmplTokenizer::charset_canon($2);
die "Conflicting charsets in msgid: $candidate vs $charset_in\n"
if defined $charset_in && $charset_in ne $candidate;
$charset_in = $candidate;
}
if ($msgstr =~ /\bcharset=(["']?)([^;\s"']+)\1/s) {
my $candidate = TmplTokenizer::charset_canon $2;
my $candidate = TmplTokenizer::charset_canon($2);
die "Conflicting charsets in msgid: $candidate vs $charset_out\n"
if defined $charset_out && $charset_out ne $candidate;
$charset_out = $candidate;
@ -287,7 +289,7 @@ sub convert_translation_file {
}
# The following assumption is correct; that's what HTML::Template assumes
if (!defined $charset_in) {
$charset_in = $charset_out = TmplTokenizer::charset_canon 'utf-8';
$charset_in = $charset_out = TmplTokenizer::charset_canon('utf-8');
warn "Warning: Can't determine original templates' charset, defaulting to $charset_in\n";
}
}
@ -355,8 +357,8 @@ GetOptions(
'help' => sub { usage(0) },
) || usage_error;
VerboseWarnings::set_application_name $0;
VerboseWarnings::set_pedantic_mode $pedantic_p;
VerboseWarnings::set_application_name($0);
VerboseWarnings::set_pedantic_mode($pedantic_p);
usage_error('Missing mandatory option -f')
unless defined $files_from || defined $convert_from;
@ -381,7 +383,7 @@ if (defined $files_from) {
my $input = /^\//? $_: "$directory/$_";
my $h = TmplTokenizer->new( $input );
$h->set_allow_cformat( 1 );
VerboseWarnings::set_input_file_name $input;
VerboseWarnings::set_input_file_name($input);
print STDERR "$0: Processing file \"$input\"\n" if $verbose_p;
text_extract( $h );
}

1
opac/opac-MARCdetail.pl
View file

@ -155,7 +155,6 @@ if (C4::Context->preference("RequestOnOpac")) {
# fill arrays
my @loop_data = ();
my $tag;
# loop through each tab 0 through 9
for ( my $tabloop = 0 ; $tabloop <= 9 ; $tabloop++ ) {

1
opac/opac-alert-subscribe.pl
View file

@ -32,7 +32,6 @@ my $query = new CGI;
my $op = $query->param('op') || '';
my $dbh = C4::Context->dbh;
my $sth;
my ( $template, $loggedinuser, $cookie );
my $subscriptionid = $query->param('subscriptionid');
my $referer = $query->param('referer') || 'detail';

1
opac/opac-authorities-home.pl
View file

@ -56,7 +56,6 @@ if ( $op eq "do_search" ) {
my @value = $query->multi_param('value');
$value[0] ||= q||;
my @tags;
my $builder = Koha::SearchEngine::QueryBuilder->new(
{ index => $Koha::SearchEngine::AUTHORITIES_INDEX } );
my $searcher = Koha::SearchEngine::Search->new(

1
opac/opac-authoritiesdetail.pl
View file

@ -114,7 +114,6 @@ if ($show_marc) {
# fill arrays
my @loop_data = ();
my $tag;
# loop through each tag
my @fields = $record->fields();

1
opac/opac-basket.pl
View file

@ -119,7 +119,6 @@ foreach my $biblionumber ( @bibs ) {
{ map { $_->{authorised_value} => $_->{opac_description} } Koha::AuthorisedValues->get_descriptions_by_koha_field( { frameworkcode => $dat->{frameworkcode}, kohafield => 'items.location' } ) };
# COinS format FIXME: for books Only
my $coins_format;
my $fmt = substr $record->leader(), 6,2;
my $fmts;
$fmts->{'am'} = 'book';

5
opac/opac-search.pl
View file

@ -534,8 +534,6 @@ my $hits;
# Define some global variables
my ($error,$query,$simple_query,$query_cgi,$query_desc,$limit,$limit_cgi,$limit_desc,$query_type);
my @results;
my $suppress = 0;
if (C4::Context->preference('OpacSuppression')) {
# OPAC suppression by IP address
@ -604,9 +602,7 @@ $template->param ( OPACResultsSidebar => C4::Context->preference('OPACResultsSid
## II. DO THE SEARCH AND GET THE RESULTS
my $total = 0; # the total results for the whole set
my $facets; # this object stores the faceted results that display on the left-hand of the results page
my @results_array;
my $results_hashref;
my @coins;
if ($tag) {
$query_cgi = "tag=" . uri_escape_utf8( $tag ) . "&" . $query_cgi;
@ -969,7 +965,6 @@ for (my $i=0;$i<@servers;$i++) {
# FIXME: can add support for other targets as needed here
$template->param( outer_sup_results_loop => \@sup_results_array);
} #/end of the for loop
#$template->param(FEDERATED_RESULTS => \@results_array);
for my $facet ( @$facets ) {
for my $entry ( @{ $facet->{facets} } ) {

2
opac/opac-serial-issues.pl
View file

@ -34,8 +34,6 @@ my $dbh = C4::Context->dbh;
my $selectview = $query->param('selectview');
$selectview = C4::Context->preference("SubscriptionHistory") unless $selectview;
my $sth;
# my $id;
my ( $template, $loggedinuser, $cookie );
my $biblionumber = $query->param('biblionumber');

1
opac/opac-showreviews.pl
View file

@ -85,7 +85,6 @@ my $reviews = Koha::Reviews->search(
my $marcflavour = C4::Context->preference("marcflavour");
my $hits = Koha::Reviews->search({ approved => 1 })->count;
my $i = 0;
my $latest_comment_date;
for my $result (@$reviews){
my $biblionumber = $result->{biblionumber};
my $biblio = Koha::Biblios->find( $biblionumber );

10
patroncards/create-pdf.pl
View file

@ -44,13 +44,13 @@ my ( $template, $loggedinuser, $cookie ) = get_template_and_user({
flagsrequired => { tools => 'label_creator' },
debug => 1,
});
my $batch_id = $cgi->param('batch_id') if $cgi->param('batch_id');
my $batch_id = $cgi->param('batch_id') || undef;
my $template_id = $cgi->param('template_id') || undef;
my $layout_id = $cgi->param('layout_id') || undef;
my $layout_back_id = $cgi->param('layout_back_id') || undef;
my $start_card = $cgi->param('start_card') || 1;
my @label_ids = $cgi->multi_param('label_id') if $cgi->param('label_id');
my @borrower_numbers = $cgi->multi_param('borrower_number') if $cgi->param('borrower_number');
my @label_ids = $cgi->multi_param('label_id');
my @borrower_numbers = $cgi->multi_param('borrower_number');
my $patronlist_id = $cgi->param('patronlist_id');
my $items = undef; # items = cards
@ -70,7 +70,7 @@ $pdf = C4::Creators::PDF->new(InitVars => 0);
my $batch = C4::Patroncards::Batch->retrieve(batch_id => $batch_id);
my $pc_template = C4::Patroncards::Template->retrieve(template_id => $template_id, profile_id => 1);
my $layout = C4::Patroncards::Layout->retrieve(layout_id => $layout_id);
my $layout_back = C4::Patroncards::Layout->retrieve(layout_id => $layout_back_id) if ( $layout_back_id );
my $layout_back = $layout_back_id ? C4::Patroncards::Layout->retrieve(layout_id => $layout_back_id) : undef;
$| = 1;
@ -111,7 +111,7 @@ else {
}
my $layout_xml = XMLin($layout->get_attr('layout_xml'), ForceArray => 1);
my $layout_back_xml = XMLin($layout_back->get_attr('layout_xml'), ForceArray => 1) if ( defined $layout_back );
my $layout_back_xml = defined $layout_back ? XMLin($layout_back->get_attr('layout_xml'), ForceArray => 1) : undef;
if ($layout_xml->{'page_side'} eq 'B') { # rearrange items on backside of page to swap columns
my $even = 1;

2
patroncards/image-manage.pl
View file

@ -28,7 +28,7 @@ my $file_name = $cgi->param('uploadfile') || '';
my $image_name = $cgi->param('image_name') || $file_name;
my $upload_file = $cgi->upload('uploadfile') || '';
my $op = $cgi->param('op') || 'none';
my @image_ids = $cgi->multi_param('image_id') if $cgi->param('image_id');
my @image_ids = $cgi->multi_param('image_id');
my $source_file = "$file_name"; # otherwise we end up with what amounts to a pointer to a filehandle rather than a user-friendly filename

12
patroncards/print.pl
View file

@ -40,14 +40,14 @@ my ( $template, $loggedinuser, $cookie ) = get_template_and_user(
);
my $op = $cgi->param('op') || 'none';
my @label_ids = $cgi->multi_param('label_id') if $cgi->param('label_id'); # this will handle individual card printing; we use label_id to maintain consistency with the column names in the creator_batches table
my @batch_ids = $cgi->multi_param('batch_id') if $cgi->param('batch_id');
my @label_ids = $cgi->multi_param('label_id'); # this will handle individual card printing; we use label_id to maintain consistency with the column names in the creator_batches table
my @batch_ids = $cgi->multi_param('batch_id');
my $patronlist_id = $cgi->param('patronlist_id') || undef;
my $layout_id = $cgi->param('layout_id') || undef;
my $layout_back_id = $cgi->param('layout_back_id') || undef;
my $template_id = $cgi->param('template_id') || undef;
my $start_card = $cgi->param('start_card') || 1;
my @borrower_numbers = $cgi->multi_param('borrower_number') if $cgi->param('borrower_number');
my @borrower_numbers = $cgi->multi_param('borrower_number');
my $output_format = $cgi->param('output_format') || 'pdf';
my $referer = $cgi->param('referer') || undef;
@ -123,9 +123,9 @@ elsif ($op eq 'none') {
# setup select menus for selecting layout and template for this run...
$referer = $ENV{'HTTP_REFERER'};
$referer =~ s/^.*?:\/\/.*?(\/.*)$/$1/m;
@batch_ids = grep{$_ = {batch_id => $_}} @batch_ids;
@label_ids = grep{$_ = {label_id => $_}} @label_ids;
@borrower_numbers = grep{$_ = {borrower_number => $_}} @borrower_numbers;
@batch_ids = map { {batch_id => $_} } @batch_ids;
@label_ids = map { {label_id => $_} } @label_ids;
@borrower_numbers = map { {borrower_number => $_} } @borrower_numbers;
$templates = get_all_templates( { fields => [qw( template_id template_code ) ], filters => { creator => "Patroncards" } });
$layouts = get_all_layouts({ fields => [ qw( layout_id layout_name ) ], filters => { creator => "Patroncards" } });
$output_formats = get_output_formats();

2
plugins/plugins-upload.pl
View file

@ -50,7 +50,7 @@ my $uploadfile = $input->upload('uploadfile');
my $uploadlocation = $input->param('uploadlocation');
my $op = $input->param('op') || q{};
my ( $total, $handled, @counts, $tempfile, $tfh );
my ( $tempfile, $tfh );
my %errors;

1
reports/acquisitions_stats.pl
View file

@ -426,7 +426,6 @@ sub calculate {
}
my $i = 0;
my @totalcol;
my $hilighted = -1;
#Initialization of cell values.....

26
reports/bor_issues_top.pl
View file

@ -41,7 +41,7 @@ plugin that shows a stats on borrowers
=cut
$debug and open DEBUG, ">/tmp/bor_issues_top.debug.log";
$debug and open my $debugfh, '>', '/tmp/bor_issues_top.debug.log';
my $input = new CGI;
my $fullreportname = "reports/bor_issues_top.tt";
@ -104,7 +104,6 @@ if ($do_it) {
}
my $dbh = C4::Context->dbh;
my @values;
# here each element returned by map is a hashref, get it?
my @mime = ( map { {type =>$_} } (split /[;:]/, 'CSV') ); # FIXME translation
@ -125,7 +124,6 @@ sub calculate {
my ($limit, $column, $filters) = @_;
my @loopcol;
my @loopline;
my @looprow;
my %globalline;
my %columns;
@ -226,25 +224,25 @@ sub calculate {
$strsth2 .=" GROUP BY $colfield";
$strsth2 .=" ORDER BY $colorder";
$debug and print DEBUG "bor_issues_top (old_issues) SQL: $strsth2\n";
$debug and print $debugfh "bor_issues_top (old_issues) SQL: $strsth2\n";
my $sth2 = $dbh->prepare($strsth2);
$sth2->execute;
print DEBUG "rows: ", $sth2->rows, "\n";
print $debugfh "rows: ", $sth2->rows, "\n";
while (my @row = $sth2->fetchrow) {
$columns{($row[0] ||'NULL')}++;
push @loopcol, { coltitle => $row[0] || 'NULL' };
}
$strsth2 =~ s/old_issues/issues/g;
$debug and print DEBUG "bor_issues_top (issues) SQL: $strsth2\n";
$debug and print $debugfh "bor_issues_top (issues) SQL: $strsth2\n";
$sth2 = $dbh->prepare($strsth2);
$sth2->execute;
$debug and print DEBUG "rows: ", $sth2->rows, "\n";
$debug and print $debugfh "rows: ", $sth2->rows, "\n";
while (my @row = $sth2->fetchrow) {
$columns{($row[0] ||'NULL')}++;
push @loopcol, { coltitle => $row[0] || 'NULL' };
}
$debug and print DEBUG "full array: ", Dumper(\%columns), "\n";
$debug and print $debugfh "full array: ", Dumper(\%columns), "\n";
}else{
$columns{''} = 1;
}
@ -281,10 +279,10 @@ sub calculate {
$strcalc .= ",$colfield " if ($colfield);
$strcalc .= " LIMIT $limit" if ($limit);
$debug and print DEBUG "(old_issues) SQL : $strcalc\n";
$debug and print $debugfh "(old_issues) SQL : $strcalc\n";
my $dbcalc = $dbh->prepare($strcalc);
$dbcalc->execute;
$debug and print DEBUG "rows: ", $dbcalc->rows, "\n";
$debug and print $debugfh "rows: ", $dbcalc->rows, "\n";
my %patrons = ();
# DATA STRUCTURE is going to look like this:
# (2253=> {name=>"John Doe",
@ -303,10 +301,10 @@ sub calculate {
use Data::Dumper;
$strcalc =~ s/old_issues/issues/g;
$debug and print DEBUG "(issues) SQL : $strcalc\n";
$debug and print $debugfh "(issues) SQL : $strcalc\n";
$dbcalc = $dbh->prepare($strcalc);
$dbcalc->execute;
$debug and print DEBUG "rows: ", $dbcalc->rows, "\n";
$debug and print $debugfh "rows: ", $dbcalc->rows, "\n";
while (my @data = $dbcalc->fetchrow) {
my ($row, $rank, $id, $col) = @data;
$col = "zzEMPTY" if (!defined($col));
@ -325,7 +323,7 @@ sub calculate {
$patrons{$id}->{total} += $count;
}
}
$debug and print DEBUG "\n\npatrons: ", Dumper(\%patrons);
$debug and print $debugfh "\n\npatrons: ", Dumper(\%patrons);
my $i = 1;
my @cols_in_order = sort keys %columns; # if you want to order the columns, do something here
@ -371,6 +369,6 @@ sub calculate {
return [\%globalline]; # reference to a 1 element array: that element is a hashref
}
$debug and close DEBUG;
$debug and close $debugfh;
1;
__END__

7
reports/borrowers_out.pl
View file

@ -110,11 +110,7 @@ if ($do_it) {
# Displaying choices
} else {
my $dbh = C4::Context->dbh;
my @values;
my %labels;
my %select;
my $req;
my $CGIextChoice = ( 'CSV' ); # FIXME translation
my $CGIsepChoice = GetDelimiterChoices;
@ -133,7 +129,6 @@ sub calculate {
my @mainloop;
my @loopfooter;
my @loopcol;
my @loopline;
my @looprow;
my %globalline;
my $grantotal =0;

2
reports/catalogue_out.pl
View file

@ -66,8 +66,6 @@ output_html_with_http_headers $input, $cookie, $template->output;
sub calculate {
my ( $limit, $column, $filters ) = @_;
my @loopline;
my @looprow;
my %globalline;
my %columns = ();
my $dbh = C4::Context->dbh;

5
reports/catalogue_stats.pl
View file

@ -114,11 +114,7 @@ if ($do_it) {
}
} else {
my $dbh = C4::Context->dbh;
my @values;
my %labels;
my $count=0;
my $req;
my @select;
my $itemtypes = Koha::ItemTypes->search_with_localization;
@ -397,7 +393,6 @@ sub calculate {
}
my $i = 0;
my @totalcol;
my $hilighted = -1;
#Initialization of cell values.....

5
reports/issues_avg_stats.pl
View file

@ -389,7 +389,6 @@ sub calculate {
# warn "fin des titres colonnes";
my $i=0;
my @totalcol;
my $hilighted=-1;
#Initialization of cell values.....
@ -442,12 +441,8 @@ sub calculate {
$dbcalc->execute;
# warn "filling table";
my $issues_count=0;
my $previous_row;
my $previous_col;
my $loanlength;
my $err;
my $emptycol;
my $weightrow;
while (my @data = $dbcalc->fetchrow) {
my ($row, $col, $issuedate, $returndate, $weight)=@data;

5
reports/issues_stats.pl
View file

@ -148,9 +148,6 @@ if ($do_it) {
my $dbh = C4::Context->dbh;
my @values;
my %labels;
my %select;
# location list
my @locations;
@ -525,7 +522,7 @@ sub calculate {
or ( $colsource eq 'items' ) || @$filters[5] || @$filters[6] || @$filters[7] || @$filters[8] || @$filters[9] || @$filters[10] || @$filters[11] || @$filters[12] || @$filters[13] );
$strcalc .= "WHERE 1=1 ";
@$filters = map { defined($_) and s/\*/%/g; $_ } @$filters;
@$filters = map { my $f = $_; defined($f) and $f =~ s/\*/%/g; $f } @$filters;
$strcalc .= " AND statistics.datetime >= '" . @$filters[0] . "'" if ( @$filters[0] );
$strcalc .= " AND statistics.datetime <= '" . @$filters[1] . " 23:59:59'" if ( @$filters[1] );
$strcalc .= " AND borrowers.categorycode LIKE '" . @$filters[2] . "'" if ( @$filters[2] );

4
reports/reserves_stats.pl
View file

@ -126,9 +126,6 @@ if ($do_it) {
}
my $dbh = C4::Context->dbh;
my @values;
my %labels;
my %select;
my $itemtypes = Koha::ItemTypes->search_with_localization;
@ -260,7 +257,6 @@ sub calculate {
push @loopfilter, {crit=>'SQL =', sql=>1, filter=>$strcalc};
@sqlparams=(@sqlparams,@sqlorparams);
$dbcalc->execute(@sqlparams);
my ($emptycol,$emptyrow);
my $data = $dbcalc->fetchall_hashref([qw(line col)]);
my %cols_hash;
foreach my $row (keys %$data){

22
rewrite-config.PL
View file

@ -19,6 +19,7 @@
#
# 2007/11/12 Added DB_PORT and changed other keywords to reflect multi-dbms support. -fbcit
use Modern::Perl;
use Sys::Hostname;
use Socket;
@ -158,7 +159,7 @@ $prefix = $ENV{'INSTALL_BASE'} || "/usr";
);
# Override configuration from the environment
foreach $key (keys %configuration) {
foreach my $key (keys %configuration) {
if (defined($ENV{$key})) {
$configuration{$key} = $ENV{$key};
}
@ -180,21 +181,22 @@ $file =~ s/__.*?__/exists $configuration{$&} ? $configuration{$&} : $&/seg;
# to make it writable. Note that stat and chmod
# (the Perl functions) should work on Win32
my $old_perm;
$old_perm = (stat $fname)[2] & 07777;
my $new_perm = $old_perm | 0200;
$old_perm = (stat $fname)[2] & oct(7777);
my $new_perm = $old_perm | oct(200);
chmod $new_perm, $fname;
open(OUTPUT,">$fname") || die "Can't open $fname for write: $!";
print OUTPUT $file;
close(OUTPUT);
open(my $output, ">", $fname) || die "Can't open $fname for write: $!";
print $output $file;
close($output);
chmod $old_perm, $fname;
# Idea taken from perlfaq5
sub read_file($) {
local(*INPUT,$/);
open(INPUT,$_[0]) || die "Can't open $_[0] for read";
my $file = <INPUT>;
sub read_file {
local $/;
open(my $fh , '<', $_[0]) || die "Can't open $_[0] for read";
my $file = <$fh>;
close $fh;
return $file;
}

1
svc/holds
View file

@ -66,7 +66,6 @@ my $holds_rs = Koha::Holds->search(
}
);
my $borrower;
my @holds;
while ( my $h = $holds_rs->next() ) {
my $item = $h->item();

32
t/00-testcritic.t
View file

@ -1,39 +1,13 @@
#!/usr/bin/env perl
# This script can be used to run perlcritic on perl files in koha
# It calls its own custom perlcriticrc
# The script is purely optional requiring Test::Perl::Critic to be installed
# and the environment variable TEST_QA to be set
# At present only the directories in @dirs will pass the tests in 'Gentle' mode
use Modern::Perl;
use File::Spec;
use Test::More;
use English qw(-no_match_vars);
my @dirs = qw(
acqui
admin
authorities
basket
catalogue
cataloguing
circ
debian
errors
labels
members
offline_circ
reserve
reviews
rotating_collections
serials
sms
virtualshelves
Koha
C4/SIP
);
if ( not $ENV{TEST_QA} ) {
my $msg = 'Author test. Set $ENV{TEST_QA} to a true value to run';
plan( skip_all => $msg );
@ -46,7 +20,5 @@ if ( $EVAL_ERROR ) {
plan( skip_all => $msg );
}
my $rcfile = File::Spec->catfile( 't', 'perlcriticrc' );
Test::Perl::Critic->import( -profile => $rcfile);
all_critic_ok(@dirs);
Test::Perl::Critic->import( -profile => '.perlcriticrc');
all_critic_ok('.');

2
t/Languages.t
View file

@ -37,7 +37,7 @@ $module_context->mock(
preference => sub {
my ($self, $pref) = @_;
if ($return_undef) {
return undef;
return;
} elsif ($pref =~ /language/) {
return join ',', @languages;
} else {

4
t/Prices.t
View file

@ -42,8 +42,8 @@ fixtures_ok [
my $bookseller_module = Test::MockModule->new('Koha::Acquisition::Bookseller');
my ( $basketno_0_0, $basketno_1_1, $basketno_1_0, $basketno_0_1 );
my ( $invoiceid_0_0, $invoiceid_1_1, $invoiceid_1_0, $invoiceid_0_1 );
my ( $basketno_0_0, $basketno_1_1 );
my ( $invoiceid_0_0, $invoiceid_1_1 );
my $today;
for my $currency_format ( qw( US FR ) ) {

2
t/SuggestionEngine.t
View file

@ -13,7 +13,7 @@ BEGIN {
my $plugindir = File::Spec->rel2abs('Koha/SuggestionEngine/Plugin');
opendir(my $dh, $plugindir);
my @installed_plugins = map { ( /\.pm$/ && -f "$plugindir/$_" && s/\.pm$// ) ? "Koha::SuggestionEngine::Plugin::$_" : () } readdir($dh);
my @installed_plugins = map { my $p = $_; ( $p =~ /\.pm$/ && -f "$plugindir/$p" && $p =~ s/\.pm$// ) ? "Koha::SuggestionEngine::Plugin::$p" : () } readdir($dh);
my @available_plugins = Koha::SuggestionEngine::AvailablePlugins();
foreach my $plugin (@installed_plugins) {

Some files were not shown because too many files have changed in this diff Show more