View | Details | Raw Unified | Return to bug 21395
Collapse All | Expand All

(-)a/t/perlcriticrc (+2 lines)
Lines 10-12 equivalent_modules = Modern::Perl Link Here
10
10
11
[TestingAndDebugging::RequireUseWarnings]
11
[TestingAndDebugging::RequireUseWarnings]
12
equivalent_modules = Modern::Perl
12
equivalent_modules = Modern::Perl
13
14
[-Modules::RequireBarewordIncludes]
(-)a/C4/Accounts.pm (-1 lines)
Lines 266-272 sub manualinvoice { Link Here
266
    my $manager_id = 0;
266
    my $manager_id = 0;
267
    $manager_id = C4::Context->userenv->{'number'} if C4::Context->userenv;
267
    $manager_id = C4::Context->userenv->{'number'} if C4::Context->userenv;
268
    my $dbh      = C4::Context->dbh;
268
    my $dbh      = C4::Context->dbh;
269
    my $insert;
270
    my $accountno  = getnextacctno($borrowernumber);
269
    my $accountno  = getnextacctno($borrowernumber);
271
    my $amountleft = $amount;
270
    my $amountleft = $amount;
272
271
(-)a/C4/Acquisition.pm (-1 lines)
Lines 2291-2297 sub GetHistory { Link Here
2291
    my $search_children_too = $params{search_children_too} || 0;
2291
    my $search_children_too = $params{search_children_too} || 0;
2292
    my $created_by = $params{created_by} || [];
2292
    my $created_by = $params{created_by} || [];
2293
2293
2294
    my @order_loop;
2295
    my $total_qty         = 0;
2294
    my $total_qty         = 0;
2296
    my $total_qtyreceived = 0;
2295
    my $total_qtyreceived = 0;
2297
    my $total_price       = 0;
2296
    my $total_price       = 0;
(-)a/C4/Auth_with_cas.pm (-9 / +9 lines)
Lines 257-275 sub logout_if_required { Link Here
257
    my $params = C4::Auth::_get_session_params();
257
    my $params = C4::Auth::_get_session_params();
258
    my $success = CGI::Session->find( $params->{dsn}, sub {delete_cas_session(@_, $ticket)}, $params->{dsn_args} );
258
    my $success = CGI::Session->find( $params->{dsn}, sub {delete_cas_session(@_, $ticket)}, $params->{dsn_args} );
259
259
260
    sub delete_cas_session {
261
        my $session = shift;
262
        my $ticket = shift;
263
        if ($session->param('cas_ticket') && $session->param('cas_ticket') eq $ticket ) {
264
            $session->delete;
265
            $session->flush;
266
        }
267
    }
268
269
    print $query->header;
260
    print $query->header;
270
    exit;
261
    exit;
271
}
262
}
272
263
264
sub delete_cas_session {
265
    my $session = shift;
266
    my $ticket = shift;
267
    if ($session->param('cas_ticket') && $session->param('cas_ticket') eq $ticket ) {
268
        $session->delete;
269
        $session->flush;
270
    }
271
}
272
273
1;
273
1;
274
__END__
274
__END__
275
275
(-)a/C4/AuthoritiesMarc.pm (-1 lines)
Lines 119-125 sub SearchAuthorities { Link Here
119
        # the marclist may contain "mainentry". In this case, search the tag_to_report, that depends on
119
        # the marclist may contain "mainentry". In this case, search the tag_to_report, that depends on
120
        # the authtypecode. Then, search on $a of this tag_to_report
120
        # the authtypecode. Then, search on $a of this tag_to_report
121
        # also store main entry MARC tag, to extract it at end of search
121
        # also store main entry MARC tag, to extract it at end of search
122
    my $mainentrytag;
123
    ##first set the authtype search and may be multiple authorities
122
    ##first set the authtype search and may be multiple authorities
124
    if ($authtypecode) {
123
    if ($authtypecode) {
125
        my $n=0;
124
        my $n=0;
(-)a/C4/Barcodes/ValueBuilder.pm (+2 lines)
Lines 19-24 Link Here
19
# along with Koha; if not, see <http://www.gnu.org/licenses>.
19
# along with Koha; if not, see <http://www.gnu.org/licenses>.
20
20
21
package C4::Barcodes::ValueBuilder::incremental;
21
package C4::Barcodes::ValueBuilder::incremental;
22
23
use Modern::Perl;
22
use C4::Context;
24
use C4::Context;
23
my $DEBUG = 0;
25
my $DEBUG = 0;
24
26
(-)a/C4/Barcodes/annual.pm (-4 / +4 lines)
Lines 36-42 BEGIN { Link Here
36
	$width = 4;
36
	$width = 4;
37
}
37
}
38
38
39
sub db_max ($;$) {
39
sub db_max {
40
	my $self = shift;
40
	my $self = shift;
41
	my $query = "SELECT substring_index(barcode,'-',-1) AS chunk,barcode FROM items WHERE barcode LIKE ? ORDER BY chunk DESC LIMIT 1";
41
	my $query = "SELECT substring_index(barcode,'-',-1) AS chunk,barcode FROM items WHERE barcode LIKE ? ORDER BY chunk DESC LIMIT 1";
42
		# FIXME: unreasonably expensive query on large datasets (I think removal of group by does this?)
42
		# FIXME: unreasonably expensive query on large datasets (I think removal of group by does this?)
Lines 64-70 sub initial () { Link Here
64
    return substr(output_pref({ dt => dt_from_string, dateformat => 'iso', dateonly => 1 }), 0, 4 ) .'-'. sprintf('%'."$width.$width".'d', 1);
64
    return substr(output_pref({ dt => dt_from_string, dateformat => 'iso', dateonly => 1 }), 0, 4 ) .'-'. sprintf('%'."$width.$width".'d', 1);
65
}
65
}
66
66
67
sub parse ($;$) {
67
sub parse {
68
	my $self = shift;
68
	my $self = shift;
69
    my $barcode = (@_) ? shift : $self->value;
69
    my $barcode = (@_) ? shift : $self->value;
70
	unless ($barcode =~ /(\d{4}-)(\d+)$/) {    # non-greedy match in first part
70
	unless ($barcode =~ /(\d{4}-)(\d+)$/) {    # non-greedy match in first part
Lines 74-85 sub parse ($;$) { Link Here
74
	$debug and warn "Barcode '$barcode' parses into: '$1', '$2', ''";
74
	$debug and warn "Barcode '$barcode' parses into: '$1', '$2', ''";
75
	return ($1,$2,'');  # the third part is in anticipation of barcodes that include checkdigits
75
	return ($1,$2,'');  # the third part is in anticipation of barcodes that include checkdigits
76
}
76
}
77
sub width ($;$) {
77
sub width {
78
	my $self = shift;
78
	my $self = shift;
79
	(@_) and $width = shift;	# hitting the class variable.
79
	(@_) and $width = shift;	# hitting the class variable.
80
	return $width;
80
	return $width;
81
}
81
}
82
sub process_head($$;$$) {	# (self,head,whole,specific)
82
sub process_head {
83
	my ($self,$head,$whole,$specific) = @_;
83
	my ($self,$head,$whole,$specific) = @_;
84
	$specific and return $head;	# if this is built off an existing barcode, just return the head unchanged.
84
	$specific and return $head;	# if this is built off an existing barcode, just return the head unchanged.
85
    return substr(output_pref({ dt => dt_from_string, dateformat => 'iso', dateonly => 1 }), 0, 4 ) . '-'; # else get new YYYY-
85
    return substr(output_pref({ dt => dt_from_string, dateformat => 'iso', dateonly => 1 }), 0, 4 ) . '-'; # else get new YYYY-
(-)a/C4/Biblio.pm (-1 lines)
Lines 2297-2303 sub TransformHtmlToXml { Link Here
2297
    # MARC::Record->new_from_xml will fail (and Koha will die)
2297
    # MARC::Record->new_from_xml will fail (and Koha will die)
2298
    my $unimarc_and_100_exist = 0;
2298
    my $unimarc_and_100_exist = 0;
2299
    $unimarc_and_100_exist = 1 if $auth_type eq 'ITEM';    # if we rebuild an item, no need of a 100 field
2299
    $unimarc_and_100_exist = 1 if $auth_type eq 'ITEM';    # if we rebuild an item, no need of a 100 field
2300
    my $prevvalue;
2301
    my $prevtag = -1;
2300
    my $prevtag = -1;
2302
    my $first   = 1;
2301
    my $first   = 1;
2303
    my $j       = -1;
2302
    my $j       = -1;
(-)a/C4/Breeding.pm (-2 lines)
Lines 551-558 sub Z3950SearchAuth { Link Here
551
    my $attr = '';
551
    my $attr = '';
552
    my $host;
552
    my $host;
553
    my $server;
553
    my $server;
554
    my $database;
555
    my $port;
556
    my $marcdata;
554
    my $marcdata;
557
    my @encoding;
555
    my @encoding;
558
    my @results;
556
    my @results;
(-)a/C4/Circulation.pm (-1 lines)
Lines 2328-2334 sub _FixOverduesOnReturn { Link Here
2328
    )->next();
2328
    )->next();
2329
    return 0 unless $accountline;    # no warning, there's just nothing to fix
2329
    return 0 unless $accountline;    # no warning, there's just nothing to fix
2330
2330
2331
    my $uquery;
2332
    if ($exemptfine) {
2331
    if ($exemptfine) {
2333
        my $amountoutstanding = $accountline->amountoutstanding;
2332
        my $amountoutstanding = $accountline->amountoutstanding;
2334
2333
(-)a/C4/ClassSortRoutine.pm (-2 / +2 lines)
Lines 52-59 my @sort_routines = GetSortRoutineNames(); Link Here
52
foreach my $sort_routine (@sort_routines) {
52
foreach my $sort_routine (@sort_routines) {
53
    if (eval "require C4::ClassSortRoutine::$sort_routine") {
53
    if (eval "require C4::ClassSortRoutine::$sort_routine") {
54
        my $ref;
54
        my $ref;
55
        eval "\$ref = \\\&C4::ClassSortRoutine::${sort_routine}::get_class_sort_key";
55
        $ref = \&{"C4::ClassSortRoutine::${sort_routine}::get_class_sort_key"};
56
        if (eval "\$ref->(\"a\", \"b\")") {
56
        if (eval { $ref->("a", "b") }) {
57
            $loaded_routines{$sort_routine} = $ref;
57
            $loaded_routines{$sort_routine} = $ref;
58
        } else {
58
        } else {
59
            $loaded_routines{$sort_routine} = \&_get_class_sort_key;
59
            $loaded_routines{$sort_routine} = \&_get_class_sort_key;
(-)a/C4/Context.pm (-2 lines)
Lines 247-253 sub new { Link Here
247
    }
247
    }
248
248
249
    my $conf_cache = Koha::Caches->get_instance('config');
249
    my $conf_cache = Koha::Caches->get_instance('config');
250
    my $config_from_cache;
251
    if ( $conf_cache->cache ) {
250
    if ( $conf_cache->cache ) {
252
        $self = $conf_cache->get_from_cache('koha_conf');
251
        $self = $conf_cache->get_from_cache('koha_conf');
253
    }
252
    }
Lines 674-680 sub dbh Link Here
674
{
673
{
675
    my $self = shift;
674
    my $self = shift;
676
    my $params = shift;
675
    my $params = shift;
677
    my $sth;
678
676
679
    unless ( $params->{new} ) {
677
    unless ( $params->{new} ) {
680
        return Koha::Database->schema->storage->dbh;
678
        return Koha::Database->schema->storage->dbh;
(-)a/C4/Creators.pm (+2 lines)
Lines 17-22 package C4::Creators; Link Here
17
# You should have received a copy of the GNU General Public License
17
# You should have received a copy of the GNU General Public License
18
# along with Koha; if not, see <http://www.gnu.org/licenses>.
18
# along with Koha; if not, see <http://www.gnu.org/licenses>.
19
19
20
use Modern::Perl;
21
20
BEGIN {
22
BEGIN {
21
    use vars qw(@EXPORT @ISA);
23
    use vars qw(@EXPORT @ISA);
22
    @ISA = qw(Exporter);
24
    @ISA = qw(Exporter);
(-)a/C4/Creators/Lib.pm (-1 / +1 lines)
Lines 513-519 be passed off as a template parameter and used to build an html table. Link Here
513
sub html_table {
513
sub html_table {
514
    my $headers = shift;
514
    my $headers = shift;
515
    my $data = shift;
515
    my $data = shift;
516
    return undef if scalar(@$data) == 0;      # no need to generate a table if there is not data to display
516
    return if scalar(@$data) == 0;      # no need to generate a table if there is not data to display
517
    my $table = [];
517
    my $table = [];
518
    my $fields = [];
518
    my $fields = [];
519
    my @table_columns = ();
519
    my @table_columns = ();
(-)a/C4/ImportBatch.pm (-6 / +6 lines)
Lines 1503-1512 sub RecordsFromISO2709File { Link Here
1503
    my $marc_type = C4::Context->preference('marcflavour');
1503
    my $marc_type = C4::Context->preference('marcflavour');
1504
    $marc_type .= 'AUTH' if ($marc_type eq 'UNIMARC' && $record_type eq 'auth');
1504
    $marc_type .= 'AUTH' if ($marc_type eq 'UNIMARC' && $record_type eq 'auth');
1505
1505
1506
    open IN, "<$input_file" or die "$0: cannot open input file $input_file: $!\n";
1506
    open my $fh, '<', $input_file or die "$0: cannot open input file $input_file: $!\n";
1507
    my @marc_records;
1507
    my @marc_records;
1508
    $/ = "\035";
1508
    $/ = "\035";
1509
    while (<IN>) {
1509
    while (<$fh>) {
1510
        s/^\s+//;
1510
        s/^\s+//;
1511
        s/\s+$//;
1511
        s/\s+$//;
1512
        next unless $_; # skip if record has only whitespace, as might occur
1512
        next unless $_; # skip if record has only whitespace, as might occur
Lines 1518-1524 sub RecordsFromISO2709File { Link Here
1518
                "Unexpected charset $charset_guessed, expecting $encoding";
1518
                "Unexpected charset $charset_guessed, expecting $encoding";
1519
        }
1519
        }
1520
    }
1520
    }
1521
    close IN;
1521
    close $fh;
1522
    return ( \@errors, \@marc_records );
1522
    return ( \@errors, \@marc_records );
1523
}
1523
}
1524
1524
Lines 1561-1575 sub RecordsFromMarcPlugin { Link Here
1561
    return \@return if !$input_file || !$plugin_class;
1561
    return \@return if !$input_file || !$plugin_class;
1562
1562
1563
    # Read input file
1563
    # Read input file
1564
    open IN, "<$input_file" or die "$0: cannot open input file $input_file: $!\n";
1564
    open my $fh, '<', $input_file or die "$0: cannot open input file $input_file: $!\n";
1565
    $/ = "\035";
1565
    $/ = "\035";
1566
    while (<IN>) {
1566
    while (<$fh>) {
1567
        s/^\s+//;
1567
        s/^\s+//;
1568
        s/\s+$//;
1568
        s/\s+$//;
1569
        next unless $_;
1569
        next unless $_;
1570
        $text .= $_;
1570
        $text .= $_;
1571
    }
1571
    }
1572
    close IN;
1572
    close $fh;
1573
1573
1574
    # Convert to large MARC blob with plugin
1574
    # Convert to large MARC blob with plugin
1575
    $text = Koha::Plugins::Handler->run({
1575
    $text = Koha::Plugins::Handler->run({
(-)a/C4/InstallAuth.pm (-1 lines)
Lines 271-277 sub checkauth { Link Here
271
            $loggedin = 1;
271
            $loggedin = 1;
272
            $userid   = $session->param('cardnumber');
272
            $userid   = $session->param('cardnumber');
273
        }
273
        }
274
        my ( $ip, $lasttime );
275
274
276
        if ($logout) {
275
        if ($logout) {
277
276
(-)a/C4/Labels.pm (+2 lines)
Lines 1-5 Link Here
1
package C4::Labels;
1
package C4::Labels;
2
2
3
use Modern::Perl;
4
3
BEGIN {
5
BEGIN {
4
6
5
    use C4::Labels::Batch;
7
    use C4::Labels::Batch;
(-)a/C4/Labels/Label.pm (-3 / +2 lines)
Lines 216-222 sub _get_barcode_data { Link Here
216
        }
216
        }
217
        elsif ( $f =~ /^([0-9a-z]{3})(\w)(\W?).*?/ ) {
217
        elsif ( $f =~ /^([0-9a-z]{3})(\w)(\W?).*?/ ) {
218
            my ($field,$subf,$ws) = ($1,$2,$3);
218
            my ($field,$subf,$ws) = ($1,$2,$3);
219
            my $subf_data;
220
            my ($itemtag, $itemsubfieldcode) = &GetMarcFromKohaField("items.itemnumber",'');
219
            my ($itemtag, $itemsubfieldcode) = &GetMarcFromKohaField("items.itemnumber",'');
221
            my @marcfield = $record->field($field);
220
            my @marcfield = $record->field($field);
222
            if(@marcfield) {
221
            if(@marcfield) {
Lines 366-373 sub create_label { Link Here
366
    my $label_text = '';
365
    my $label_text = '';
367
    my ($text_llx, $text_lly, $line_spacer, $barcode_llx, $barcode_lly, $barcode_width, $barcode_y_scale_factor);
366
    my ($text_llx, $text_lly, $line_spacer, $barcode_llx, $barcode_lly, $barcode_width, $barcode_y_scale_factor);
368
    {
367
    {
369
        no strict 'refs';
368
        my $sub = \&{'_' . $self->{printing_type}};
370
        ($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
369
        ($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
371
    }
370
    }
372
    if ($self->{'printing_type'} =~ /BIB/) {
371
    if ($self->{'printing_type'} =~ /BIB/) {
373
        $label_text = draw_label_text(  $self,
372
        $label_text = draw_label_text(  $self,
(-)a/C4/Languages.pm (-3 / +1 lines)
Lines 315-322 sub _build_languages_arrayref { Link Here
315
        my @languages_loop; # the final reference to an array of hashrefs
315
        my @languages_loop; # the final reference to an array of hashrefs
316
        my @enabled_languages = @$enabled_languages;
316
        my @enabled_languages = @$enabled_languages;
317
        # how many languages are enabled, if one, take note, some contexts won't need to display it
317
        # how many languages are enabled, if one, take note, some contexts won't need to display it
318
        my %seen_languages; # the language tags we've seen
319
        my %found_languages;
320
        my $language_groups;
318
        my $language_groups;
321
        my $track_language_groups;
319
        my $track_language_groups;
322
        my $current_language_regex = regex_lang_subtags($current_language);
320
        my $current_language_regex = regex_lang_subtags($current_language);
Lines 556-562 sub accept_language { Link Here
556
    }
554
    }
557
    # No primary matches. Secondary? (ie, en-us requested and en supported)
555
    # No primary matches. Secondary? (ie, en-us requested and en supported)
558
    return $secondaryMatch if $secondaryMatch;
556
    return $secondaryMatch if $secondaryMatch;
559
    return undef;   # else, we got nothing.
557
    return;   # else, we got nothing.
560
}
558
}
561
559
562
=head2 getlanguage
560
=head2 getlanguage
(-)a/C4/Letters.pm (-1 lines)
Lines 314-320 sub SendAlerts { Link Here
314
          or warn( "No biblionumber for '$subscriptionid'" ),
314
          or warn( "No biblionumber for '$subscriptionid'" ),
315
             return;
315
             return;
316
316
317
        my %letter;
318
        # find the list of subscribers to notify
317
        # find the list of subscribers to notify
319
        my $subscription = Koha::Subscriptions->find( $subscriptionid );
318
        my $subscription = Koha::Subscriptions->find( $subscriptionid );
320
        my $subscribers = $subscription->subscribers;
319
        my $subscribers = $subscription->subscribers;
(-)a/C4/Matcher.pm (-1 / +1 lines)
Lines 165-171 sub fetch { Link Here
165
    $sth->execute($id);
165
    $sth->execute($id);
166
    my $row = $sth->fetchrow_hashref;
166
    my $row = $sth->fetchrow_hashref;
167
    $sth->finish();
167
    $sth->finish();
168
    return undef unless defined $row;
168
    return unless defined $row;
169
169
170
    my $self = {};
170
    my $self = {};
171
    $self->{'id'} = $row->{'matcher_id'};
171
    $self->{'id'} = $row->{'matcher_id'};
(-)a/C4/Members/Messaging.pm (-1 lines)
Lines 88-94 END_SQL Link Here
88
    my $sth = C4::Context->dbh->prepare($sql);
88
    my $sth = C4::Context->dbh->prepare($sql);
89
    $sth->execute(@bind_params);
89
    $sth->execute(@bind_params);
90
    my $return;
90
    my $return;
91
    my %transports; # helps build a list of unique message_transport_types
92
    ROW: while ( my $row = $sth->fetchrow_hashref() ) {
91
    ROW: while ( my $row = $sth->fetchrow_hashref() ) {
93
        next ROW unless $row->{'message_attribute_id'};
92
        next ROW unless $row->{'message_attribute_id'};
94
        $return->{'days_in_advance'} = $row->{'days_in_advance'} if defined $row->{'days_in_advance'};
93
        $return->{'days_in_advance'} = $row->{'days_in_advance'} if defined $row->{'days_in_advance'};
(-)a/C4/Patroncards.pm (+2 lines)
Lines 1-5 Link Here
1
package C4::Patroncards;
1
package C4::Patroncards;
2
2
3
use Modern::Perl;
4
3
BEGIN {
5
BEGIN {
4
    use vars qw(@EXPORT @ISA);
6
    use vars qw(@EXPORT @ISA);
5
    @ISA = qw(Exporter);
7
    @ISA = qw(Exporter);
(-)a/C4/Patroncards/Patroncard.pm (-3 / +5 lines)
Lines 227-237 sub draw_text { Link Here
227
                $parse_line = $2;
227
                $parse_line = $2;
228
            }
228
            }
229
            my $borrower_attributes = get_borrower_attributes($self->{'borrower_number'},@fields);
229
            my $borrower_attributes = get_borrower_attributes($self->{'borrower_number'},@fields);
230
            grep{ # substitute data for db fields
230
            @orig_line = map { # substitute data for db fields
231
                if ($_ =~ m/<([A-Za-z0-9_]+)>/) {
231
                my $l = $_;
232
                if ($l =~ m/<([A-Za-z0-9_]+)>/) {
232
                    my $field = $1;
233
                    my $field = $1;
233
                    $_ =~ s/$_/$borrower_attributes->{$field}/;
234
                    $l =~ s/$l/$borrower_attributes->{$field}/;
234
                }
235
                }
236
                $l;
235
            } @orig_line;
237
            } @orig_line;
236
            $line = join(' ',@orig_line);
238
            $line = join(' ',@orig_line);
237
        }
239
        }
(-)a/C4/Record.pm (-5 / +3 lines)
Lines 377-383 sub marc2endnote { Link Here
377
        Year => $marc_rec_obj->publication_date,
377
        Year => $marc_rec_obj->publication_date,
378
        Abstract => $abstract,
378
        Abstract => $abstract,
379
    };
379
    };
380
    my $endnote;
381
    my $style = new Biblio::EndnoteStyle();
380
    my $style = new Biblio::EndnoteStyle();
382
    my $template;
381
    my $template;
383
    $template.= "DB - DB\n" if C4::Context->preference("LibraryName");
382
    $template.= "DB - DB\n" if C4::Context->preference("LibraryName");
Lines 422-428 sub marc2csv { Link Here
422
    }
421
    }
423
422
424
    # Preprocessing
423
    # Preprocessing
425
    eval $preprocess if ($preprocess);
424
    eval $preprocess if ($preprocess); ## no critic (StringyEval)
426
425
427
    my $firstpass = 1;
426
    my $firstpass = 1;
428
    if ( @$itemnumbers ) {
427
    if ( @$itemnumbers ) {
Lines 440-446 sub marc2csv { Link Here
440
    }
439
    }
441
440
442
    # Postprocessing
441
    # Postprocessing
443
    eval $postprocess if ($postprocess);
442
    eval $postprocess if ($postprocess); ## no critic (StringyEval)
444
443
445
    return $output;
444
    return $output;
446
}
445
}
Lines 574-580 sub marcrecord2csv { Link Here
574
        if ( $content =~ m|\[\%.*\%\]| ) {
573
        if ( $content =~ m|\[\%.*\%\]| ) {
575
            my $tt = Template->new();
574
            my $tt = Template->new();
576
            my $template = $content;
575
            my $template = $content;
577
            my $vars;
578
            # Replace 00X and 0XX with X or XX
576
            # Replace 00X and 0XX with X or XX
579
            $content =~ s|fields.00(\d)|fields.$1|g;
577
            $content =~ s|fields.00(\d)|fields.$1|g;
580
            $content =~ s|fields.0(\d{2})|fields.$1|g;
578
            $content =~ s|fields.0(\d{2})|fields.$1|g;
Lines 623-629 sub marcrecord2csv { Link Here
623
                        # Field processing
621
                        # Field processing
624
                        my $marcfield = $tag->{fieldtag}; # This line fixes a retrocompatibility concern
622
                        my $marcfield = $tag->{fieldtag}; # This line fixes a retrocompatibility concern
625
                                                          # The "processing" could be based on the $marcfield variable.
623
                                                          # The "processing" could be based on the $marcfield variable.
626
                        eval $fieldprocessing if ($fieldprocessing);
624
                        eval $fieldprocessing if ($fieldprocessing); ## no critic (StringyEval)
627
625
628
                        push @loop_values, $value;
626
                        push @loop_values, $value;
629
                    }
627
                    }
(-)a/C4/Ris.pm (-1 lines)
Lines 90-96 C<$record> - a MARC::Record object Link Here
90
90
91
sub marc2ris {
91
sub marc2ris {
92
    my ($record) = @_;
92
    my ($record) = @_;
93
    my $output;
94
93
95
    my $marcflavour = C4::Context->preference("marcflavour");
94
    my $marcflavour = C4::Context->preference("marcflavour");
96
    my $intype = lc($marcflavour);
95
    my $intype = lc($marcflavour);
(-)a/C4/Search.pm (-5 lines)
Lines 88-96 sub FindDuplicate { Link Here
88
    my $result = TransformMarcToKoha( $record, '' );
88
    my $result = TransformMarcToKoha( $record, '' );
89
    my $sth;
89
    my $sth;
90
    my $query;
90
    my $query;
91
    my $search;
92
    my $type;
93
    my ( $biblionumber, $title );
94
91
95
    # search duplicate on ISBN, easy and fast..
92
    # search duplicate on ISBN, easy and fast..
96
    # ... normalize first
93
    # ... normalize first
Lines 335-341 sub getRecords { Link Here
335
    $offset = 0 if $offset < 0;
332
    $offset = 0 if $offset < 0;
336
333
337
    # Initialize variables for the ZOOM connection and results object
334
    # Initialize variables for the ZOOM connection and results object
338
    my $zconn;
339
    my @zconns;
335
    my @zconns;
340
    my @results;
336
    my @results;
341
    my $results_hashref = ();
337
    my $results_hashref = ();
Lines 454-460 sub getRecords { Link Here
454
                }
450
                }
455
451
456
                for ( my $j = $offset ; $j < $times ; $j++ ) {
452
                for ( my $j = $offset ; $j < $times ; $j++ ) {
457
                    my $records_hash;
458
                    my $record;
453
                    my $record;
459
454
460
                    ## Check if it's an index scan
455
                    ## Check if it's an index scan
(-)a/C4/Serials.pm (-9 / +12 lines)
Lines 321-330 sub GetFullSubscription { Link Here
321
    my $sth = $dbh->prepare($query);
321
    my $sth = $dbh->prepare($query);
322
    $sth->execute($subscriptionid);
322
    $sth->execute($subscriptionid);
323
    my $subscriptions = $sth->fetchall_arrayref( {} );
323
    my $subscriptions = $sth->fetchall_arrayref( {} );
324
    my $cannotedit = not can_edit_subscription( $subscriptions->[0] ) if scalar @$subscriptions;
324
    if (scalar @$subscriptions) {
325
    for my $subscription ( @$subscriptions ) {
325
        my $cannotedit = not can_edit_subscription( $subscriptions->[0] );
326
        $subscription->{cannotedit} = $cannotedit;
326
        for my $subscription ( @$subscriptions ) {
327
            $subscription->{cannotedit} = $cannotedit;
328
        }
327
    }
329
    }
330
328
    return $subscriptions;
331
    return $subscriptions;
329
}
332
}
330
333
Lines 344-352 sub PrepareSerialsData { Link Here
344
    my $year;
347
    my $year;
345
    my @res;
348
    my @res;
346
    my $startdate;
349
    my $startdate;
347
    my $aqbooksellername;
348
    my $bibliotitle;
349
    my @loopissues;
350
    my $first;
350
    my $first;
351
    my $previousnote = "";
351
    my $previousnote = "";
352
352
Lines 481-490 sub GetFullSubscriptionsFromBiblionumber { Link Here
481
    my $sth = $dbh->prepare($query);
481
    my $sth = $dbh->prepare($query);
482
    $sth->execute($biblionumber);
482
    $sth->execute($biblionumber);
483
    my $subscriptions = $sth->fetchall_arrayref( {} );
483
    my $subscriptions = $sth->fetchall_arrayref( {} );
484
    my $cannotedit = not can_edit_subscription( $subscriptions->[0] ) if scalar @$subscriptions;
484
    if (scalar @$subscriptions) {
485
    for my $subscription ( @$subscriptions ) {
485
        my $cannotedit = not can_edit_subscription( $subscriptions->[0] );
486
        $subscription->{cannotedit} = $cannotedit;
486
        for my $subscription ( @$subscriptions ) {
487
            $subscription->{cannotedit} = $cannotedit;
488
        }
487
    }
489
    }
490
488
    return $subscriptions;
491
    return $subscriptions;
489
}
492
}
490
493
(-)a/C4/Templates.pm (-1 / +1 lines)
Lines 118-124 sub output { Link Here
118
    $vars = { %$vars, %{ $self->{VARS} } };
118
    $vars = { %$vars, %{ $self->{VARS} } };
119
119
120
    my $data;
120
    my $data;
121
    binmode( STDOUT, ":utf8" );
121
    binmode( STDOUT, ":encoding(UTF-8)" );
122
    $template->process( $self->filename, $vars, \$data )
122
    $template->process( $self->filename, $vars, \$data )
123
      || die "Template process failed: ", $template->error();
123
      || die "Template process failed: ", $template->error();
124
    return $data;
124
    return $data;
(-)a/Makefile.PL (-3 / +3 lines)
Lines 863-870 sub get_install_log_values { Link Here
863
    my $install_log = shift;
863
    my $install_log = shift;
864
    my $values = shift;
864
    my $values = shift;
865
865
866
    open LOG, "<$install_log" or die "Cannot open install log $install_log: $!\n";
866
    open my $log, '<', $install_log or die "Cannot open install log $install_log: $!\n";
867
    while (<LOG>) {
867
    while (<$log>) {
868
        chomp;
868
        chomp;
869
        next if /^#/ or /^\s*$/;
869
        next if /^#/ or /^\s*$/;
870
        next if /^=/;
870
        next if /^=/;
Lines 873-879 sub get_install_log_values { Link Here
873
        my ($key, $value) = split /=/, $_, 2;
873
        my ($key, $value) = split /=/, $_, 2;
874
        $values->{$key} = $value;
874
        $values->{$key} = $value;
875
    }
875
    }
876
    close LOG;
876
    close $log;
877
877
878
    print <<_EXPLAIN_INSTALL_LOG_;
878
    print <<_EXPLAIN_INSTALL_LOG_;
879
Reading values from install log $install_log.  You
879
Reading values from install log $install_log.  You
(-)a/docs/CAS/CASProxy/examples/koha_webservice.pl (-1 / +1 lines)
Lines 33-39 The Proxy Ticket, needed for check_api_auth, that will try to make the CAS Serve Link Here
33
33
34
use utf8;
34
use utf8;
35
use Modern::Perl;
35
use Modern::Perl;
36
binmode(STDOUT, ":utf8");
36
binmode(STDOUT, ":encoding(UTF-8)");
37
37
38
use C4::Auth qw(check_api_auth);
38
use C4::Auth qw(check_api_auth);
39
use C4::Output;
39
use C4::Output;
(-)a/docs/CAS/CASProxy/examples/proxy_cas_callback.pl (-3 / +3 lines)
Lines 49-57 if ($cgi->param('pgtId')) { Link Here
49
49
50
    # Now we store the pgtIou and the pgtId in the application vars (in our case a storable object in a file), 
50
    # Now we store the pgtIou and the pgtId in the application vars (in our case a storable object in a file), 
51
    # so that the page requesting the webservice can retrieve the pgtId matching it's PgtIou 
51
    # so that the page requesting the webservice can retrieve the pgtId matching it's PgtIou 
52
    open FILE, ">", "casSession.tmp" or die "Unable to open file";
52
    open my $fh, ">", "casSession.tmp" or die "Unable to open file";
53
    nstore_fd({$pgtIou => $pgtId}, \*FILE);
53
    nstore_fd({$pgtIou => $pgtId}, $fh);
54
    close FILE;
54
    close $fh;
55
55
56
} else {
56
} else {
57
    warn "Failed to get a Proxy Ticket\n";
57
    warn "Failed to get a Proxy Ticket\n";
(-)a/docs/CAS/CASProxy/examples/proxy_cas_data.pl (-3 / +3 lines)
Lines 54-63 if ($cgi->param('PGTIOU')) { Link Here
54
      # At this point, we must retrieve the PgtId by matching the PgtIou we
54
      # At this point, we must retrieve the PgtId by matching the PgtIou we
55
      # just received and the PgtIou given by the CAS Server to the callback URL
55
      # just received and the PgtIou given by the CAS Server to the callback URL
56
      # The callback page stored it in the application vars (in our case a storable object in a file)
56
      # The callback page stored it in the application vars (in our case a storable object in a file)
57
      open FILE, "casSession.tmp" or die "Unable to open file";
57
      open my $fh, '<', "casSession.tmp" or die "Unable to open file";
58
      my $hashref = fd_retrieve(\*FILE);
58
      my $hashref = fd_retrieve($fh);
59
      my $pgtId = %{$hashref->{$cgi->param('PGTIOU')}};
59
      my $pgtId = %{$hashref->{$cgi->param('PGTIOU')}};
60
      close FILE;
60
      close $fh;
61
61
62
      # Now that we have a PgtId, we can ask the cas server for a proxy ticket...
62
      # Now that we have a PgtId, we can ask the cas server for a proxy ticket...
63
      my $rp = $cas->proxy( $pgtId, $target_service );
63
      my $rp = $cas->proxy( $pgtId, $target_service );
(-)a/fix-perl-path.PL (-2 / +2 lines)
Lines 77-84 sub fixshebang{ Link Here
77
            # to make it writable.  Note that stat and chmod
77
            # to make it writable.  Note that stat and chmod
78
            # (the Perl functions) should work on Win32
78
            # (the Perl functions) should work on Win32
79
            my $old_perm;
79
            my $old_perm;
80
            $old_perm = (stat $pathfile)[2] & 07777;
80
            $old_perm = (stat $pathfile)[2] & oct(7777);
81
            my $new_perm = $old_perm | 0200;
81
            my $new_perm = $old_perm | oct(200);
82
            chmod $new_perm, $pathfile;
82
            chmod $new_perm, $pathfile;
83
83
84
            # tie the file -- note that we're explicitly setting the line (record)
84
            # tie the file -- note that we're explicitly setting the line (record)
(-)a/install-CPAN.pl (+2 lines)
Lines 1-5 Link Here
1
# cpan_install.pl - Install prerequisites from CPAN then Koha
1
# cpan_install.pl - Install prerequisites from CPAN then Koha
2
2
3
use Modern::Perl;
4
3
($ARGV[0] =~ /koha-.*z/) || die "
5
($ARGV[0] =~ /koha-.*z/) || die "
4
 Run this as the CPAN-owning user (usually root) with:
6
 Run this as the CPAN-owning user (usually root) with:
5
   perl $0 path/to/koha.tgz
7
   perl $0 path/to/koha.tgz
(-)a/installer/data/mysql/labels_upgrade.pl (-2 / +1 lines)
Lines 17-24 Link Here
17
# You should have received a copy of the GNU General Public License
17
# You should have received a copy of the GNU General Public License
18
# along with Koha; if not, see <http://www.gnu.org/licenses>.
18
# along with Koha; if not, see <http://www.gnu.org/licenses>.
19
19
20
#use strict;
20
use Modern::Perl;
21
#use warnings; FIXME - Bug 2505
22
21
23
use C4::Context;
22
use C4::Context;
24
23
(-)a/installer/data/mysql/patroncards_upgrade.pl (-2 / +1 lines)
Lines 17-24 Link Here
17
# You should have received a copy of the GNU General Public License
17
# You should have received a copy of the GNU General Public License
18
# along with Koha; if not, see <http://www.gnu.org/licenses>.
18
# along with Koha; if not, see <http://www.gnu.org/licenses>.
19
19
20
#use strict;
20
use Modern::Perl;
21
#use warnings; FIXME - Bug 2505
22
21
23
use C4::Context;
22
use C4::Context;
24
23
(-)a/installer/data/mysql/update22to30.pl (-9 / +7 lines)
Lines 36-42 my ( Link Here
36
    $table,
36
    $table,
37
    $column,
37
    $column,
38
    $type, $null, $key, $default, $extra,
38
    $type, $null, $key, $default, $extra,
39
    $prefitem,          # preference item in systempreferences table
40
);
39
);
41
40
42
my $silent;
41
my $silent;
Lines 3049-3055 my $DBversion = "3.00.00.000"; Link Here
3049
                             ],
3048
                             ],
3050
    );
3049
    );
3051
3050
3052
    foreach $table ( keys %required_prereq_fields ) {
3051
    foreach my $table ( keys %required_prereq_fields ) {
3053
        print "Check table $table\n" if $debug and not $silent;
3052
        print "Check table $table\n" if $debug and not $silent;
3054
        $sth = $dbh->prepare("show columns from $table");
3053
        $sth = $dbh->prepare("show columns from $table");
3055
        $sth->execute();
3054
        $sth->execute();
Lines 3158-3164 my $DBversion = "3.00.00.000"; Link Here
3158
    
3157
    
3159
    
3158
    
3160
    # Now add any missing tables
3159
    # Now add any missing tables
3161
    foreach $table ( keys %requiretables ) {
3160
    foreach my $table ( keys %requiretables ) {
3162
        unless ( $existingtables{$table} ) {
3161
        unless ( $existingtables{$table} ) {
3163
        print "Adding $table table...\n" unless $silent;
3162
        print "Adding $table table...\n" unless $silent;
3164
            my $sth = $dbh->prepare("create table $table $requiretables{$table} ENGINE=InnoDB DEFAULT CHARSET=utf8");
3163
            my $sth = $dbh->prepare("create table $table $requiretables{$table} ENGINE=InnoDB DEFAULT CHARSET=utf8");
Lines 3173-3179 my $DBversion = "3.00.00.000"; Link Here
3173
    #---------------------------------
3172
    #---------------------------------
3174
    # Columns
3173
    # Columns
3175
    
3174
    
3176
    foreach $table ( keys %requirefields ) {
3175
    foreach my $table ( keys %requirefields ) {
3177
        print "Check table $table\n" if $debug and not $silent;
3176
        print "Check table $table\n" if $debug and not $silent;
3178
        $sth = $dbh->prepare("show columns from $table");
3177
        $sth = $dbh->prepare("show columns from $table");
3179
        $sth->execute();
3178
        $sth->execute();
Lines 3182-3188 my $DBversion = "3.00.00.000"; Link Here
3182
        {
3181
        {
3183
            $types{$column} = $type;
3182
            $types{$column} = $type;
3184
        }    # while
3183
        }    # while
3185
        foreach $column ( keys %{ $requirefields{$table} } ) {
3184
        foreach my $column ( keys %{ $requirefields{$table} } ) {
3186
            print "  Check column $column  [$types{$column}]\n" if $debug and not $silent;
3185
            print "  Check column $column  [$types{$column}]\n" if $debug and not $silent;
3187
            if ( !$types{$column} ) {
3186
            if ( !$types{$column} ) {
3188
    
3187
    
Lines 3201-3207 my $DBversion = "3.00.00.000"; Link Here
3201
        }    # foreach column
3200
        }    # foreach column
3202
    }    # foreach table
3201
    }    # foreach table
3203
    
3202
    
3204
    foreach $table ( sort keys %fielddefinitions ) {
3203
    foreach my $table ( sort keys %fielddefinitions ) {
3205
        print "Check table $table\n" if $debug;
3204
        print "Check table $table\n" if $debug;
3206
        $sth = $dbh->prepare("show columns from $table");
3205
        $sth = $dbh->prepare("show columns from $table");
3207
        $sth->execute();
3206
        $sth->execute();
Lines 3455-3461 my $DBversion = "3.00.00.000"; Link Here
3455
        }
3454
        }
3456
    }
3455
    }
3457
    # now drop useless tables
3456
    # now drop useless tables
3458
    foreach $table ( @TableToDelete ) {
3457
    foreach my $table ( @TableToDelete ) {
3459
        if ( $existingtables{$table} ) {
3458
        if ( $existingtables{$table} ) {
3460
            print "Dropping unused table $table\n" if $debug and not $silent;
3459
            print "Dropping unused table $table\n" if $debug and not $silent;
3461
            $dbh->do("drop table $table");
3460
            $dbh->do("drop table $table");
Lines 3500-3508 my $DBversion = "3.00.00.000"; Link Here
3500
    }
3499
    }
3501
    
3500
    
3502
    # at last, remove useless fields
3501
    # at last, remove useless fields
3503
    foreach $table ( keys %uselessfields ) {
3502
    foreach my $table ( keys %uselessfields ) {
3504
        my @fields = split (/,/,$uselessfields{$table});
3503
        my @fields = split (/,/,$uselessfields{$table});
3505
        my $fields;
3506
        my $exists;
3504
        my $exists;
3507
        foreach my $fieldtodrop (@fields) {
3505
        foreach my $fieldtodrop (@fields) {
3508
            $fieldtodrop =~ s/\t//g;
3506
            $fieldtodrop =~ s/\t//g;
(-)a/installer/data/mysql/updatedatabase.pl (-7 / +3 lines)
Lines 54-67 use File::Slurp; Link Here
54
my $debug = 0;
54
my $debug = 0;
55
55
56
my (
56
my (
57
    $sth, $sti,
57
    $sth,
58
    $query,
58
    $query,
59
    %existingtables,    # tables already in database
60
    %types,
61
    $table,
59
    $table,
62
    $column,
60
    $type,
63
    $type, $null, $key, $default, $extra,
64
    $prefitem,          # preference item in systempreferences table
65
);
61
);
66
62
67
my $schema = Koha::Database->new()->schema();
63
my $schema = Koha::Database->new()->schema();
Lines 16433-16439 foreach my $file ( sort readdir $dirh ) { Link Here
16433
        my $rv = $installer->load_sql( $update_dir . $file ) ? 0 : 1;
16429
        my $rv = $installer->load_sql( $update_dir . $file ) ? 0 : 1;
16434
    } elsif ( $file =~ /\.perl$/ ) {
16430
    } elsif ( $file =~ /\.perl$/ ) {
16435
        my $code = read_file( $update_dir . $file );
16431
        my $code = read_file( $update_dir . $file );
16436
        eval $code;
16432
        eval $code; ## no critic (StringyEval)
16437
        say "Atomic update generated errors: $@" if $@;
16433
        say "Atomic update generated errors: $@" if $@;
16438
    }
16434
    }
16439
}
16435
}
(-)a/installer/externalmodules.pl (-3 / +3 lines)
Lines 13-21 qx(grep -r "^ *use" $dir | grep -v "C4\|strict\|vars" >/tmp/modulesKoha.log); Link Here
13
$dir=C4::Context->config('opacdir');
13
$dir=C4::Context->config('opacdir');
14
qx(grep -r "^ *use" $dir | grep -v "C4\|strict\|vars" >>/tmp/modulesKoha.log);
14
qx(grep -r "^ *use" $dir | grep -v "C4\|strict\|vars" >>/tmp/modulesKoha.log);
15
15
16
open FILE, "< /tmp/modulesKoha.log" ||die "unable to open file /tmp/modulesKoha.log";
16
open my $fh, '<', '/tmp/modulesKoha.log' ||die "unable to open file /tmp/modulesKoha.log";
17
my %modulehash;
17
my %modulehash;
18
while (my $line=<FILE>){
18
while (my $line=<$fh>){
19
  if ( $line=~m#(.*)\:\s*use\s+([A-Z][^\s;]+)# ){
19
  if ( $line=~m#(.*)\:\s*use\s+([A-Z][^\s;]+)# ){
20
    my ($file,$module)=($1,$2);
20
    my ($file,$module)=($1,$2);
21
    my @filename = split /\//, $file;
21
    my @filename = split /\//, $file;
Lines 24-28 while (my $line=<FILE>){ Link Here
24
}
24
}
25
print "external modules used in Koha ARE :\n";
25
print "external modules used in Koha ARE :\n";
26
map {print "* $_ \t in files ",join (",",@{$modulehash{$_}}),"\n" } sort keys %modulehash;
26
map {print "* $_ \t in files ",join (",",@{$modulehash{$_}}),"\n" } sort keys %modulehash;
27
close FILE;
27
close $fh;
28
unlink "/tmp/modulesKoha.log";
28
unlink "/tmp/modulesKoha.log";
(-)a/misc/admin/koha-preferences (+1 lines)
Lines 18-23 Link Here
18
# along with Koha; if not, see <http://www.gnu.org/licenses>.
18
# along with Koha; if not, see <http://www.gnu.org/licenses>.
19
#
19
#
20
20
21
use Modern::Perl;
21
use C4::Boolean;
22
use C4::Boolean;
22
use C4::Context;
23
use C4::Context;
23
use C4::Debug;
24
use C4::Debug;
(-)a/misc/batchRepairMissingBiblionumbers.pl (-1 lines)
Lines 18-24 use C4::Biblio; Link Here
18
18
19
19
20
my $dbh = C4::Context->dbh;
20
my $dbh = C4::Context->dbh;
21
my %kohafields;
22
21
23
my $sth=$dbh->prepare("SELECT biblio.biblionumber, biblioitemnumber, frameworkcode FROM biblio JOIN biblioitems USING (biblionumber)");
22
my $sth=$dbh->prepare("SELECT biblio.biblionumber, biblioitemnumber, frameworkcode FROM biblio JOIN biblioitems USING (biblionumber)");
24
$sth->execute();
23
$sth->execute();
(-)a/misc/batchdeletebiblios.pl (-1 / +1 lines)
Lines 7-13 use IO::File; Link Here
7
7
8
use C4::Biblio;
8
use C4::Biblio;
9
9
10
my ($help, $files);
10
my $help;
11
GetOptions(
11
GetOptions(
12
    'h|help' => \$help,
12
    'h|help' => \$help,
13
);
13
);
(-)a/misc/bin/connexion_import_daemon.pl (+1 lines)
Lines 132-137 sub parse_config { Link Here
132
        die "Invalid config line $line: $_" unless defined $v;
132
        die "Invalid config line $line: $_" unless defined $v;
133
        $param{$p} = $v;
133
        $param{$p} = $v;
134
    }
134
    }
135
    close($conf_fh);
135
136
136
    $self->{koha} = delete( $param{koha} )
137
    $self->{koha} = delete( $param{koha} )
137
      or die "No koha base url in config file";
138
      or die "No koha base url in config file";
(-)a/misc/check_sysprefs.pl (-3 / +3 lines)
Lines 21-28 sub check_sys_pref { Link Here
21
    if ( !-d _ ) {
21
    if ( !-d _ ) {
22
        my $name = $File::Find::name;
22
        my $name = $File::Find::name;
23
        if ( $name =~ /(\.pl|\.pm)$/ ) {
23
        if ( $name =~ /(\.pl|\.pm)$/ ) {
24
            open( FILE, "$_" ) || die "cant open $name";
24
            open( my $fh, '<', $_ ) || die "cant open $name";
25
            while ( my $inp = <FILE> ) {
25
            while ( my $inp = <$fh> ) {
26
                if ( $inp =~ /C4::Context->preference\((.*?)\)/ ) {
26
                if ( $inp =~ /C4::Context->preference\((.*?)\)/ ) {
27
                    my $variable = $1;
27
                    my $variable = $1;
28
                    $variable =~ s /\'|\"//g;
28
                    $variable =~ s /\'|\"//g;
Lines 36-42 sub check_sys_pref { Link Here
36
"$name has a reference to $variable, this does not exist in the database\n";
36
"$name has a reference to $variable, this does not exist in the database\n";
37
                }
37
                }
38
            }
38
            }
39
            close FILE;
39
            close $fh;
40
        }
40
        }
41
    }
41
    }
42
    $sth->finish();
42
    $sth->finish();
(-)a/misc/cronjobs/build_browser_and_cloud.pl (-1 / +1 lines)
Lines 21-27 use Getopt::Long; Link Here
21
use C4::Log;
21
use C4::Log;
22
22
23
my ( $input_marc_file, $number) = ('',0);
23
my ( $input_marc_file, $number) = ('',0);
24
my ($version, $confirm,$test_parameter,$field,$batch,$max_digits,$cloud_tag);
24
my ($version, $confirm,$field,$batch,$max_digits,$cloud_tag);
25
GetOptions(
25
GetOptions(
26
	'c' => \$confirm,
26
	'c' => \$confirm,
27
	'h' => \$version,
27
	'h' => \$version,
(-)a/misc/cronjobs/gather_print_notices.pl (-2 / +1 lines)
Lines 24-30 use Koha::DateUtils; Link Here
24
use MIME::Lite;
24
use MIME::Lite;
25
25
26
my (
26
my (
27
    $stylesheet,
28
    $help,
27
    $help,
29
    $split,
28
    $split,
30
    $html,
29
    $html,
Lines 230-236 sub generate_csv { Link Here
230
229
231
    open my $OUTPUT, '>encoding(utf-8)', $filepath
230
    open my $OUTPUT, '>encoding(utf-8)', $filepath
232
        or die "Could not open $filepath: $!";
231
        or die "Could not open $filepath: $!";
233
    my ( @csv_lines, $headers );
232
    my $headers;
234
    foreach my $message ( @$messages ) {
233
    foreach my $message ( @$messages ) {
235
        my @lines = split /\n/, $message->{content};
234
        my @lines = split /\n/, $message->{content};
236
        chomp for @lines;
235
        chomp for @lines;
(-)a/misc/cronjobs/holds/cancel_expired_holds.pl (-2 / +1 lines)
Lines 17-24 Link Here
17
# You should have received a copy of the GNU General Public License
17
# You should have received a copy of the GNU General Public License
18
# along with Koha; if not, see <http://www.gnu.org/licenses>.
18
# along with Koha; if not, see <http://www.gnu.org/licenses>.
19
19
20
#use strict;
20
use Modern::Perl;
21
#use warnings; FIXME - Bug 2505
22
21
23
BEGIN {
22
BEGIN {
24
    # find Koha's Perl modules
23
    # find Koha's Perl modules
(-)a/misc/cronjobs/longoverdue.pl (-3 / +3 lines)
Lines 233-239 cronlogaction(); Link Here
233
# In my opinion, this line is safe SQL to have outside the API. --atz
233
# In my opinion, this line is safe SQL to have outside the API. --atz
234
our $bounds_sth = C4::Context->dbh->prepare("SELECT DATE_SUB(CURDATE(), INTERVAL ? DAY)");
234
our $bounds_sth = C4::Context->dbh->prepare("SELECT DATE_SUB(CURDATE(), INTERVAL ? DAY)");
235
235
236
sub bounds ($) {
236
sub bounds {
237
    $bounds_sth->execute(shift);
237
    $bounds_sth->execute(shift);
238
    return $bounds_sth->fetchrow;
238
    return $bounds_sth->fetchrow;
239
}
239
}
Lines 332-341 foreach my $startrange (sort keys %$lost) { Link Here
332
    $endrange = $startrange;
332
    $endrange = $startrange;
333
}
333
}
334
334
335
sub summarize ($$) {
335
sub summarize {
336
    my $arg = shift;    # ref to array
336
    my $arg = shift;    # ref to array
337
    my $got_items = shift || 0;     # print "count" line for items
337
    my $got_items = shift || 0;     # print "count" line for items
338
    my @report = @$arg or return undef;
338
    my @report = @$arg or return;
339
    my $i = 0;
339
    my $i = 0;
340
    for my $range (@report) {
340
    for my $range (@report) {
341
        printf "\nRange %s\nDue %3s - %3s days ago (%s to %s), lost => %s\n", ++$i,
341
        printf "\nRange %s\nDue %3s - %3s days ago (%s to %s), lost => %s\n", ++$i,
(-)a/misc/cronjobs/rss/rss.pl (-3 / +3 lines)
Lines 72-79 sub getConf { Link Here
72
    my %return;
72
    my %return;
73
    my $inSection = 0;
73
    my $inSection = 0;
74
74
75
    open( FILE, $file ) or die "can't open $file";
75
    open( my $fh, '<', $file ) or die "can't open $file";
76
    while (<FILE>) {
76
    while (<$fh>) {
77
        if ($inSection) {
77
        if ($inSection) {
78
            my @line = split( /=/, $_, 2 );
78
            my @line = split( /=/, $_, 2 );
79
            unless ( $line[1] ) {
79
            unless ( $line[1] ) {
Lines 89-95 sub getConf { Link Here
89
            if ( $_ eq "$section\n" ) { $inSection = 1 }
89
            if ( $_ eq "$section\n" ) { $inSection = 1 }
90
        }
90
        }
91
    }
91
    }
92
    close FILE;
92
    close $fh;
93
    return %return;
93
    return %return;
94
}
94
}
95
95
(-)a/misc/cronjobs/thirdparty/TalkingTech_itiva_inbound.pl (+1 lines)
Lines 76-81 if ( defined $infile ) { Link Here
76
        $updated += $result;
76
        $updated += $result;
77
        $total++;
77
        $total++;
78
    }
78
    }
79
    close($IN);
79
}
80
}
80
else {
81
else {
81
    die pod2usage( -verbose => 1 );
82
    die pod2usage( -verbose => 1 );
(-)a/misc/cronjobs/update_totalissues.pl (-1 / +1 lines)
Lines 69-75 my $result = GetOptions( Link Here
69
    'h|help'       => \$want_help
69
    'h|help'       => \$want_help
70
);
70
);
71
71
72
binmode( STDOUT, ":utf8" );
72
binmode( STDOUT, ":encoding(UTF-8)" );
73
73
74
if ( defined $since && defined $interval ) {
74
if ( defined $since && defined $interval ) {
75
    print "The --since and --interval options are mutually exclusive.\n\n";
75
    print "The --since and --interval options are mutually exclusive.\n\n";
(-)a/misc/devel/populate_db.pl (-1 / +1 lines)
Lines 189-195 sub update_database { Link Here
189
        if $verbose;
189
        if $verbose;
190
    my $file = `cat $update_db_path`;
190
    my $file = `cat $update_db_path`;
191
    $file =~ s/exit;//;
191
    $file =~ s/exit;//;
192
    eval $file;
192
    eval $file; ## no critic (StringyEval)
193
    if ($@) {
193
    if ($@) {
194
        die "updatedatabase.pl process failed: $@";
194
        die "updatedatabase.pl process failed: $@";
195
    } else {
195
    } else {
(-)a/misc/exportauth.pl (-3 / +3 lines)
Lines 16-22 use C4::Context; Link Here
16
use C4::Biblio;
16
use C4::Biblio;
17
use C4::Auth;
17
use C4::Auth;
18
my $outfile = $ARGV[0];
18
my $outfile = $ARGV[0];
19
open(OUT,">$outfile") or die $!;
19
open(my $fh, '>', $outfile) or die $!;
20
my $dbh=C4::Context->dbh;
20
my $dbh=C4::Context->dbh;
21
#$dbh->do("set character_set_client='latin5'"); 
21
#$dbh->do("set character_set_client='latin5'"); 
22
$dbh->do("set character_set_connection='utf8'");
22
$dbh->do("set character_set_connection='utf8'");
Lines 24-29 $dbh->do("set character_set_connection='utf8'"); Link Here
24
my $sth=$dbh->prepare("select marc from auth_header order by authid");
24
my $sth=$dbh->prepare("select marc from auth_header order by authid");
25
$sth->execute();
25
$sth->execute();
26
while (my ($marc) = $sth->fetchrow) {
26
while (my ($marc) = $sth->fetchrow) {
27
    print OUT $marc;
27
    print $fh $marc;
28
 }
28
 }
29
close(OUT);
29
close($fh);
(-)a/misc/link_bibs_to_authorities.pl (-1 / +1 lines)
Lines 46-52 my $result = GetOptions( Link Here
46
    'h|help'         => \$want_help
46
    'h|help'         => \$want_help
47
);
47
);
48
48
49
binmode( STDOUT, ":utf8" );
49
binmode( STDOUT, ":encoding(UTF-8)" );
50
50
51
if ( not $result or $want_help ) {
51
if ( not $result or $want_help ) {
52
    usage();
52
    usage();
(-)a/misc/maintenance/cmp_sysprefs.pl (-1 / +1 lines)
Lines 33-39 use Pod::Usage; Link Here
33
use C4::Context;
33
use C4::Context;
34
my $dbh = C4::Context->dbh;
34
my $dbh = C4::Context->dbh;
35
35
36
my ( $help, $cmd, $filename, $override, $compare_add, $compare_del, $compare_upd, $ignore_opt, $partial );
36
my ( $help, $cmd, $filename, $compare_add, $compare_del, $compare_upd, $ignore_opt, $partial );
37
GetOptions(
37
GetOptions(
38
    'help'    => \$help,
38
    'help'    => \$help,
39
    'cmd:s'   => \$cmd,
39
    'cmd:s'   => \$cmd,
(-)a/misc/maintenance/fix_accountlines_rmdupfines_bug8253.pl (-1 lines)
Lines 75-81 $query = Link Here
75
"SELECT * FROM accountlines WHERE description LIKE ? AND description NOT LIKE ?";
75
"SELECT * FROM accountlines WHERE description LIKE ? AND description NOT LIKE ?";
76
$sth = $dbh->prepare($query);
76
$sth = $dbh->prepare($query);
77
77
78
my @fines;
79
foreach my $keeper (@$results) {
78
foreach my $keeper (@$results) {
80
79
81
    warn "WORKING ON KEEPER: " . Data::Dumper::Dumper( $keeper );
80
    warn "WORKING ON KEEPER: " . Data::Dumper::Dumper( $keeper );
(-)a/misc/maintenance/touch_all_biblios.pl (-4 / +6 lines)
Lines 67-76 if ($whereclause) { Link Here
67
}
67
}
68
68
69
# output log or STDOUT
69
# output log or STDOUT
70
my $fh;
70
if (defined $outfile) {
71
if (defined $outfile) {
71
   open (OUT, ">$outfile") || die ("Cannot open output file");
72
   open ($fh, '>', $outfile) || die ("Cannot open output file");
72
} else {
73
} else {
73
   open(OUT, ">&STDOUT") || die ("Couldn't duplicate STDOUT: $!");
74
   open($fh, '>&', \*STDOUT) || die ("Couldn't duplicate STDOUT: $!");
74
}
75
}
75
76
76
my $sth1 = $dbh->prepare("SELECT biblionumber, frameworkcode FROM biblio $whereclause");
77
my $sth1 = $dbh->prepare("SELECT biblionumber, frameworkcode FROM biblio $whereclause");
Lines 84-98 while (my ($biblionumber, $frameworkcode) = $sth1->fetchrow_array){ Link Here
84
85
85
  if ($modok) {
86
  if ($modok) {
86
     $goodcount++;
87
     $goodcount++;
87
     print OUT "Touched biblio $biblionumber\n" if (defined $verbose);
88
     print $fh "Touched biblio $biblionumber\n" if (defined $verbose);
88
  } else {
89
  } else {
89
     $badcount++;
90
     $badcount++;
90
     print OUT "ERROR WITH BIBLIO $biblionumber !!!!\n";
91
     print $fh "ERROR WITH BIBLIO $biblionumber !!!!\n";
91
  }
92
  }
92
93
93
  $totalcount++;
94
  $totalcount++;
94
95
95
}
96
}
97
close($fh);
96
98
97
# Benchmarking
99
# Benchmarking
98
my $endtime = time();
100
my $endtime = time();
(-)a/misc/maintenance/touch_all_items.pl (-4 / +6 lines)
Lines 67-76 if ($whereclause) { Link Here
67
}
67
}
68
68
69
# output log or STDOUT
69
# output log or STDOUT
70
my $fh;
70
if (defined $outfile) {
71
if (defined $outfile) {
71
   open (OUT, ">$outfile") || die ("Cannot open output file");
72
   open ($fh, '>', $outfile) || die ("Cannot open output file");
72
} else {
73
} else {
73
   open(OUT, ">&STDOUT") || die ("Couldn't duplicate STDOUT: $!");
74
   open($fh, '>&', \*STDOUT) || die ("Couldn't duplicate STDOUT: $!");
74
}
75
}
75
76
76
my $sth_fetch = $dbh->prepare("SELECT biblionumber, itemnumber, itemcallnumber FROM items $whereclause");
77
my $sth_fetch = $dbh->prepare("SELECT biblionumber, itemnumber, itemcallnumber FROM items $whereclause");
Lines 84-98 while (my ($biblionumber, $itemnumber, $itemcallnumber) = $sth_fetch->fetchrow_a Link Here
84
85
85
  if ($modok) {
86
  if ($modok) {
86
     $goodcount++;
87
     $goodcount++;
87
     print OUT "Touched item $itemnumber\n" if (defined $verbose);
88
     print $fh "Touched item $itemnumber\n" if (defined $verbose);
88
  } else {
89
  } else {
89
     $badcount++;
90
     $badcount++;
90
     print OUT "ERROR WITH ITEM $itemnumber !!!!\n";
91
     print $fh "ERROR WITH ITEM $itemnumber !!!!\n";
91
  }
92
  }
92
93
93
  $totalcount++;
94
  $totalcount++;
94
95
95
}
96
}
97
close($fh);
96
98
97
# Benchmarking
99
# Benchmarking
98
my $endtime = time();
100
my $endtime = time();
(-)a/misc/migration_tools/22_to_30/export_Authorities.pl (-3 / +2 lines)
Lines 1-6 Link Here
1
#!/usr/bin/perl
1
#!/usr/bin/perl
2
#use strict;
2
use Modern::Perl;
3
#use warnings; FIXME - Bug 2505
4
BEGIN {
3
BEGIN {
5
    # find Koha's Perl modules
4
    # find Koha's Perl modules
6
    # test carefully before changing this
5
    # test carefully before changing this
Lines 32-38 while (my ($authid,$authtypecode)=$rq->fetchrow){ Link Here
32
  
31
  
33
  if (C4::Context->preference('marcflavour') eq "UNIMARC"){
32
  if (C4::Context->preference('marcflavour') eq "UNIMARC"){
34
	$record->leader('     nac  22     1u 4500');
33
	$record->leader('     nac  22     1u 4500');
35
    my $string=$1 if $time=~m/([0-9\-]+)/;
34
    my $string= ($time=~m/([0-9\-]+)/) ? $1 : undef
36
    $string=~s/\-//g;
35
    $string=~s/\-//g;
37
     $string = sprintf("%-*s",26, $string);
36
     $string = sprintf("%-*s",26, $string);
38
     substr($string,9,6,"frey50");
37
     substr($string,9,6,"frey50");
(-)a/misc/migration_tools/22_to_30/export_Authorities_xml.pl (-3 / +2 lines)
Lines 1-6 Link Here
1
#!/usr/bin/perl
1
#!/usr/bin/perl
2
#use strict;
2
use Modern::Perl;
3
#use warnings; FIXME - Bug 2505
4
BEGIN {
3
BEGIN {
5
    # find Koha's Perl modules
4
    # find Koha's Perl modules
6
    # test carefully before changing this
5
    # test carefully before changing this
Lines 31-37 open my $fileoutput, '>:encoding(UTF-8)', "./$filename/$authid.xml" or die "unab Link Here
31
			
30
			
32
#  if (C4::Context->preference('marcflavour') eq "UNIMARC"){
31
#  if (C4::Context->preference('marcflavour') eq "UNIMARC"){
33
	$record->leader('     nac  22     1u 4500');
32
	$record->leader('     nac  22     1u 4500');
34
    my $string=$1 if $time=~m/([0-9\-]+)/;
33
    my $string = ($time=~m/([0-9\-]+)/) ? $1 : undef
35
    $string=~s/\-//g;
34
    $string=~s/\-//g;
36
     $string = sprintf("%-*s",26, $string);
35
     $string = sprintf("%-*s",26, $string);
37
     substr($string,9,6,"frey50");
36
     substr($string,9,6,"frey50");
(-)a/misc/migration_tools/22_to_30/move_marc_to_biblioitems.pl (-2 / +1 lines)
Lines 1-6 Link Here
1
#!/usr/bin/perl
1
#!/usr/bin/perl
2
#use strict;
2
use Modern::Perl;
3
#use warnings; FIXME - Bug 2505
4
# script to shift marc to biblioitems
3
# script to shift marc to biblioitems
5
# scraped from updatedatabase for dev week by chris@katipo.co.nz
4
# scraped from updatedatabase for dev week by chris@katipo.co.nz
6
BEGIN {
5
BEGIN {
(-)a/misc/migration_tools/buildCOUNTRY.pl (-1 / +1 lines)
Lines 13-19 use Time::HiRes qw(gettimeofday); Link Here
13
13
14
use Getopt::Long;
14
use Getopt::Long;
15
my ( $fields, $number,$language) = ('',0);
15
my ( $fields, $number,$language) = ('',0);
16
my ($version, $verbose, $test_parameter, $field,$delete,$subfields);
16
my ($version, $verbose, $test_parameter, $delete);
17
GetOptions(
17
GetOptions(
18
    'h' => \$version,
18
    'h' => \$version,
19
    'd' => \$delete,
19
    'd' => \$delete,
(-)a/misc/migration_tools/buildEDITORS.pl (-1 lines)
Lines 66-72 my $starttime = gettimeofday; Link Here
66
my $sth = $dbh->prepare("select bibid from marc_biblio");
66
my $sth = $dbh->prepare("select bibid from marc_biblio");
67
$sth->execute;
67
$sth->execute;
68
my $i=1;
68
my $i=1;
69
my %alreadydone;
70
my $counter;
69
my $counter;
71
my %hash;
70
my %hash;
72
while (my ($bibid) = $sth->fetchrow) {
71
while (my ($bibid) = $sth->fetchrow) {
(-)a/misc/migration_tools/buildLANG.pl (-1 / +1 lines)
Lines 13-19 use Time::HiRes qw(gettimeofday); Link Here
13
13
14
use Getopt::Long;
14
use Getopt::Long;
15
my ( $fields, $number,$language) = ('',0);
15
my ( $fields, $number,$language) = ('',0);
16
my ($version, $verbose, $test_parameter, $field,$delete,$subfields);
16
my ($version, $verbose, $test_parameter, $delete);
17
GetOptions(
17
GetOptions(
18
    'h' => \$version,
18
    'h' => \$version,
19
    'd' => \$delete,
19
    'd' => \$delete,
(-)a/misc/migration_tools/bulkmarcimport.pl (-3 / +4 lines)
Lines 146-153 if($marc_mod_template ne '') { Link Here
146
my $dbh = C4::Context->dbh;
146
my $dbh = C4::Context->dbh;
147
my $heading_fields=get_heading_fields();
147
my $heading_fields=get_heading_fields();
148
148
149
my $idmapfh;
149
if (defined $idmapfl) {
150
if (defined $idmapfl) {
150
  open(IDMAP,">$idmapfl") or die "cannot open $idmapfl \n";
151
  open($idmapfh, '>', $idmapfl) or die "cannot open $idmapfl \n";
151
}
152
}
152
153
153
if ((not defined $sourcesubfield) && (not defined $sourcetag)){
154
if ((not defined $sourcesubfield) && (not defined $sourcetag)){
Lines 441-451 RECORD: while ( ) { Link Here
441
			 	if ($sourcetag < "010"){
442
			 	if ($sourcetag < "010"){
442
					if ($record->field($sourcetag)){
443
					if ($record->field($sourcetag)){
443
					  my $source = $record->field($sourcetag)->data();
444
					  my $source = $record->field($sourcetag)->data();
444
					  printf(IDMAP "%s|%s\n",$source,$biblionumber);
445
					  printf($idmapfh "%s|%s\n",$source,$biblionumber);
445
					}
446
					}
446
			    } else {
447
			    } else {
447
					my $source=$record->subfield($sourcetag,$sourcesubfield);
448
					my $source=$record->subfield($sourcetag,$sourcesubfield);
448
					printf(IDMAP "%s|%s\n",$source,$biblionumber);
449
					printf($idmapfh "%s|%s\n",$source,$biblionumber);
449
			  }
450
			  }
450
			}
451
			}
451
					# create biblio, unless we already have it ( either match or isbn )
452
					# create biblio, unless we already have it ( either match or isbn )
(-)a/misc/migration_tools/remove_unused_authorities.pl (-1 lines)
Lines 57-63 if ( $errZebraConnection == 10000 ) { Link Here
57
my $dbh=C4::Context->dbh;
57
my $dbh=C4::Context->dbh;
58
my $thresholdmin=0;
58
my $thresholdmin=0;
59
my $thresholdmax=0;
59
my $thresholdmax=0;
60
my @results;
61
# prepare the request to retrieve all authorities of the requested types
60
# prepare the request to retrieve all authorities of the requested types
62
my $rqsql = "SELECT * from auth_header where 1";
61
my $rqsql = "SELECT * from auth_header where 1";
63
$rqsql .= " AND authtypecode IN (".join(",",map{$dbh->quote($_)}@authtypes).")" if @authtypes;
62
$rqsql .= " AND authtypecode IN (".join(",",map{$dbh->quote($_)}@authtypes).")" if @authtypes;
(-)a/misc/perlmodule_rm.pl (-1 / +1 lines)
Lines 2-8 Link Here
2
2
3
# Remove a perl module
3
# Remove a perl module
4
4
5
use warnings;
5
use Modern::Perl;
6
use ExtUtils::Packlist;
6
use ExtUtils::Packlist;
7
use ExtUtils::Installed;
7
use ExtUtils::Installed;
8
8
(-)a/misc/translator/LangInstaller.pm (-1 / +1 lines)
Lines 552-558 sub get_all_langs { Link Here
552
    opendir( my $dh, $self->{path_po} );
552
    opendir( my $dh, $self->{path_po} );
553
    my @files = grep { $_ =~ /-pref.po$/ }
553
    my @files = grep { $_ =~ /-pref.po$/ }
554
        readdir $dh;
554
        readdir $dh;
555
    @files = map { $_ =~ s/-pref.po$//; $_ } @files;
555
    @files = map { my $f = $_; $f =~ s/-pref.po$//; $f } @files;
556
}
556
}
557
557
558
558
(-)a/misc/translator/TmplTokenizer.pm (-28 / +28 lines)
Lines 139-145 BEGIN { Link Here
139
sub parenleft  () { '(' }
139
sub parenleft  () { '(' }
140
sub parenright () { ')' }
140
sub parenright () { ')' }
141
141
142
sub _split_js ($) {
142
sub _split_js {
143
    my ($s0) = @_;
143
    my ($s0) = @_;
144
    my @it = ();
144
    my @it = ();
145
    while (length $s0) {
145
    while (length $s0) {
Lines 191-197 sub STATE_STRING_LITERAL () { 3 } Link Here
191
191
192
# XXX This is a crazy hack. I don't want to write an ECMAScript parser.
192
# XXX This is a crazy hack. I don't want to write an ECMAScript parser.
193
# XXX A scanner is one thing; a parser another thing.
193
# XXX A scanner is one thing; a parser another thing.
194
sub _identify_js_translatables (@) {
194
sub _identify_js_translatables {
195
    my @input = @_;
195
    my @input = @_;
196
    my @output = ();
196
    my @output = ();
197
    # We mark a JavaScript translatable string as in C, i.e., _("literal")
197
    # We mark a JavaScript translatable string as in C, i.e., _("literal")
Lines 228-234 sub _identify_js_translatables (@) { Link Here
228
228
229
###############################################################################
229
###############################################################################
230
230
231
sub string_canon ($) {
231
sub string_canon {
232
  my $s = shift;
232
  my $s = shift;
233
  # Fold all whitespace into single blanks
233
  # Fold all whitespace into single blanks
234
  $s =~ s/\s+/ /g;
234
  $s =~ s/\s+/ /g;
Lines 237-243 sub string_canon ($) { Link Here
237
}
237
}
238
238
239
# safer version used internally, preserves new lines
239
# safer version used internally, preserves new lines
240
sub string_canon_safe ($) {
240
sub string_canon_safe {
241
  my $s = shift;
241
  my $s = shift;
242
  # fold tabs and spaces into single spaces
242
  # fold tabs and spaces into single spaces
243
  $s =~ s/[\ \t]+/ /gs;
243
  $s =~ s/[\ \t]+/ /gs;
Lines 253-259 sub _quote_cformat{ Link Here
253
253
254
sub _formalize_string_cformat{
254
sub _formalize_string_cformat{
255
  my $s = shift;
255
  my $s = shift;
256
  return _quote_cformat( string_canon_safe $s );
256
  return _quote_cformat( string_canon_safe($s) );
257
}
257
}
258
258
259
sub _formalize{
259
sub _formalize{
Lines 315-321 sub next_token { Link Here
315
                return $self->_parametrize_internal(@parts);
315
                return $self->_parametrize_internal(@parts);
316
            }
316
            }
317
            else {
317
            else {
318
                return undef;
318
                return;
319
            }
319
            }
320
        }
320
        }
321
        # if cformat mode is off, dont bother parametrizing, just return them as they come
321
        # if cformat mode is off, dont bother parametrizing, just return them as they come
Lines 338-344 sub next_token { Link Here
338
                 push @tail, $3;
338
                 push @tail, $3;
339
                $s0 = $2;
339
                $s0 = $2;
340
            }
340
            }
341
            push @head, _split_js $s0;
341
            push @head, _split_js($s0);
342
            $next->set_js_data(_identify_js_translatables(@head, @tail) );
342
            $next->set_js_data(_identify_js_translatables(@head, @tail) );
343
	    return $next unless @parts;	    
343
	    return $next unless @parts;	    
344
	    $self->{_parser}->unshift_token($next);
344
	    $self->{_parser}->unshift_token($next);
Lines 360-366 sub next_token { Link Here
360
360
361
# function taken from old version
361
# function taken from old version
362
# used by tmpl_process3
362
# used by tmpl_process3
363
sub parametrize ($$$$) {
363
sub parametrize {
364
    my($fmt_0, $cformat_p, $t, $f) = @_;
364
    my($fmt_0, $cformat_p, $t, $f) = @_;
365
    my $it = '';
365
    my $it = '';
366
    if ($cformat_p) {
366
    if ($cformat_p) {
Lines 380-392 sub parametrize ($$$$) { Link Here
380
		    ;
380
		    ;
381
		} elsif (defined $params[$i - 1]) {
381
		} elsif (defined $params[$i - 1]) {
382
		    my $param = $params[$i - 1];
382
		    my $param = $params[$i - 1];
383
		    warn_normal "$fmt_0: $&: Expected a TMPL_VAR, but found a "
383
		    warn_normal("$fmt_0: $&: Expected a TMPL_VAR, but found a "
384
			    . $param->type->to_string . "\n", undef
384
			    . $param->type->to_string . "\n", undef)
385
			    if $param->type != C4::TmplTokenType::DIRECTIVE;
385
			    if $param->type != C4::TmplTokenType::DIRECTIVE;
386
		    warn_normal "$fmt_0: $&: Unsupported "
386
		    warn_normal("$fmt_0: $&: Unsupported "
387
				. "field width or precision\n", undef
387
				. "field width or precision\n", undef)
388
			    if defined $width || defined $prec;
388
			    if defined $width || defined $prec;
389
		    warn_normal "$fmt_0: $&: Parameter $i not known", undef
389
		    warn_normal("$fmt_0: $&: Parameter $i not known", undef)
390
			    unless defined $param;
390
			    unless defined $param;
391
		    $it .= defined $f? &$f( $param ): $param->string;
391
		    $it .= defined $f? &$f( $param ): $param->string;
392
		}
392
		}
Lines 397-423 sub parametrize ($$$$) { Link Here
397
397
398
		my $param = $params[$i - 1];
398
		my $param = $params[$i - 1];
399
		if (!defined $param) {
399
		if (!defined $param) {
400
		    warn_normal "$fmt_0: $&: Parameter $i not known", undef;
400
		    warn_normal("$fmt_0: $&: Parameter $i not known", undef);
401
		} else {
401
		} else {
402
		    if ($param->type == C4::TmplTokenType::TAG
402
		    if ($param->type == C4::TmplTokenType::TAG
403
			    && $param->string =~ /^<input\b/is) {
403
			    && $param->string =~ /^<input\b/is) {
404
			my $type = defined $param->attributes?
404
			my $type = defined $param->attributes?
405
				lc($param->attributes->{'type'}->[1]): undef;
405
				lc($param->attributes->{'type'}->[1]): undef;
406
			if ($conv eq 'S') {
406
			if ($conv eq 'S') {
407
			    warn_normal "$fmt_0: $&: Expected type=text, "
407
			    warn_normal("$fmt_0: $&: Expected type=text, "
408
					. "but found type=$type", undef
408
					. "but found type=$type", undef)
409
				    unless $type eq 'text';
409
				    unless $type eq 'text';
410
			} elsif ($conv eq 'p') {
410
			} elsif ($conv eq 'p') {
411
			    warn_normal "$fmt_0: $&: Expected type=radio, "
411
			    warn_normal("$fmt_0: $&: Expected type=radio, "
412
					. "but found type=$type", undef
412
					. "but found type=$type", undef)
413
				    unless $type eq 'radio';
413
				    unless $type eq 'radio';
414
			}
414
			}
415
		    } else {
415
		    } else {
416
			warn_normal "$&: Expected an INPUT, but found a "
416
			warn_normal("$&: Expected an INPUT, but found a "
417
				. $param->type->to_string . "\n", undef
417
				. $param->type->to_string . "\n", undef)
418
		    }
418
		    }
419
		    warn_normal "$fmt_0: $&: Unsupported "
419
		    warn_normal("$fmt_0: $&: Unsupported "
420
				. "field width or precision\n", undef
420
				. "field width or precision\n", undef)
421
			    if defined $width || defined $prec;
421
			    if defined $width || defined $prec;
422
		    $it .= defined $f? &$f( $param ): $param->string;
422
		    $it .= defined $f? &$f( $param ): $param->string;
423
		}
423
		}
Lines 440-446 sub parametrize ($$$$) { Link Here
440
	    my $i  = $1;
440
	    my $i  = $1;
441
	    $fmt = $';
441
	    $fmt = $';
442
	    my $anchor = $anchors[$i - 1];
442
	    my $anchor = $anchors[$i - 1];
443
	    warn_normal "$&: Anchor $1 not found for msgid \"$fmt_0\"", undef #FIXME
443
	    warn_normal("$&: Anchor $1 not found for msgid \"$fmt_0\"", undef) #FIXME
444
		    unless defined $anchor;
444
		    unless defined $anchor;
445
	    $it .= $anchor->string;
445
	    $it .= $anchor->string;
446
	} else {
446
	} else {
Lines 453-464 sub parametrize ($$$$) { Link Here
453
453
454
# Other simple functions (These are not methods)
454
# Other simple functions (These are not methods)
455
455
456
sub blank_p ($) {
456
sub blank_p {
457
    my($s) = @_;
457
    my($s) = @_;
458
    return $s =~ /^(?:\s|\&nbsp$re_end_entity|$re_tmpl_var|$re_xsl)*$/osi;
458
    return $s =~ /^(?:\s|\&nbsp$re_end_entity|$re_tmpl_var|$re_xsl)*$/osi;
459
}
459
}
460
460
461
sub trim ($) {
461
sub trim {
462
    my($s0) = @_;
462
    my($s0) = @_;
463
    my $l0 = length $s0;
463
    my $l0 = length $s0;
464
    my $s = $s0;
464
    my $s = $s0;
Lines 467-473 sub trim ($) { Link Here
467
    return wantarray? (substr($s0, 0, $l1), $s, substr($s0, $l0 - $l2)): $s;
467
    return wantarray? (substr($s0, 0, $l1), $s, substr($s0, $l0 - $l2)): $s;
468
}
468
}
469
469
470
sub quote_po ($) {
470
sub quote_po {
471
    my($s) = @_;
471
    my($s) = @_;
472
    # Locale::PO->quote is buggy, it doesn't quote newlines :-/
472
    # Locale::PO->quote is buggy, it doesn't quote newlines :-/
473
    $s =~ s/([\\"])/\\$1/gs;
473
    $s =~ s/([\\"])/\\$1/gs;
Lines 476-482 sub quote_po ($) { Link Here
476
    return "\"$s\"";
476
    return "\"$s\"";
477
}
477
}
478
478
479
sub charset_canon ($) {
479
sub charset_canon {
480
    my($charset) = @_;
480
    my($charset) = @_;
481
    $charset = uc($charset);
481
    $charset = uc($charset);
482
    $charset = "$1-$2" if $charset =~ /^(ISO|UTF)(\d.*)/i;
482
    $charset = "$1-$2" if $charset =~ /^(ISO|UTF)(\d.*)/i;
Lines 509-515 use vars qw( @latin1_utf8 ); Link Here
509
    "\303\270", "\303\271", "\303\272", "\303\273", "\303\274", "\303\275",
509
    "\303\270", "\303\271", "\303\272", "\303\273", "\303\274", "\303\275",
510
    "\303\276", "\303\277" );
510
    "\303\276", "\303\277" );
511
511
512
sub charset_convert ($$$) {
512
sub charset_convert {
513
    my($s, $charset_in, $charset_out) = @_;
513
    my($s, $charset_in, $charset_out) = @_;
514
    if ($s !~ /[\200-\377]/s) { # FIXME: don't worry about iso2022 for now
514
    if ($s !~ /[\200-\377]/s) { # FIXME: don't worry about iso2022 for now
515
	;
515
	;
(-)a/misc/translator/VerboseWarnings.pm (-12 / +12 lines)
Lines 41-72 verbose warnings. Link Here
41
use vars qw( $appName $input $input_abbr $pedantic_p $pedantic_tag $quiet);
41
use vars qw( $appName $input $input_abbr $pedantic_p $pedantic_tag $quiet);
42
use vars qw( $warned $erred );
42
use vars qw( $warned $erred );
43
43
44
sub set_application_name ($) {
44
sub set_application_name {
45
    my($s) = @_;
45
    my($s) = @_;
46
    $appName = $& if !defined $appName && $s =~ /[^\/]+$/;
46
    $appName = $& if !defined $appName && $s =~ /[^\/]+$/;
47
}
47
}
48
48
49
sub application_name () {
49
sub application_name {
50
    return $appName;
50
    return $appName;
51
}
51
}
52
52
53
sub set_input_file_name ($) {
53
sub set_input_file_name {
54
    my($s) = @_;
54
    my($s) = @_;
55
    $input = $s;
55
    $input = $s;
56
    $input_abbr = $& if defined $s && $s =~ /[^\/]+$/;
56
    $input_abbr = $& if defined $s && $s =~ /[^\/]+$/;
57
}
57
}
58
58
59
sub set_pedantic_mode ($) {
59
sub set_pedantic_mode {
60
    my($p) = @_;
60
    my($p) = @_;
61
    $pedantic_p = $p;
61
    $pedantic_p = $p;
62
    $pedantic_tag = $pedantic_p? '': ' (negligible)';
62
    $pedantic_tag = $pedantic_p? '': ' (negligible)';
63
}
63
}
64
64
65
sub pedantic_p () {
65
sub pedantic_p {
66
    return $pedantic_p;
66
    return $pedantic_p;
67
}
67
}
68
68
69
sub construct_warn_prefix ($$) {
69
sub construct_warn_prefix {
70
    my($prefix, $lc) = @_;
70
    my($prefix, $lc) = @_;
71
    die "construct_warn_prefix called before set_application_name"
71
    die "construct_warn_prefix called before set_application_name"
72
	    unless defined $appName;
72
	    unless defined $appName;
Lines 81-100 sub construct_warn_prefix ($$) { Link Here
81
    return "$appName: $prefix: " . (defined $lc? "$input_abbr: line $lc: ": defined $input_abbr? "$input_abbr: ": '');
81
    return "$appName: $prefix: " . (defined $lc? "$input_abbr: line $lc: ": defined $input_abbr? "$input_abbr: ": '');
82
}
82
}
83
83
84
sub warn_additional ($$) {
84
sub warn_additional {
85
    my($msg, $lc) = @_;
85
    my($msg, $lc) = @_;
86
    my $prefix = construct_warn_prefix('Warning', $lc);
86
    my $prefix = construct_warn_prefix('Warning', $lc);
87
    $msg .= "\n" unless $msg =~ /\n$/s;
87
    $msg .= "\n" unless $msg =~ /\n$/s;
88
    warn "$prefix$msg";
88
    warn "$prefix$msg";
89
}
89
}
90
90
91
sub warn_normal ($$) {
91
sub warn_normal {
92
    my($msg, $lc) = @_;
92
    my($msg, $lc) = @_;
93
    $warned += 1;
93
    $warned += 1;
94
    warn_additional($msg, $lc);
94
    warn_additional($msg, $lc);
95
}
95
}
96
96
97
sub warn_pedantic ($$$) {
97
sub warn_pedantic {
98
    my($msg, $lc, $flag) = @_;
98
    my($msg, $lc, $flag) = @_;
99
    my $prefix = construct_warn_prefix("Warning$pedantic_tag", $lc);
99
    my $prefix = construct_warn_prefix("Warning$pedantic_tag", $lc);
100
    $msg .= "\n" unless $msg =~ /\n$/s;
100
    $msg .= "\n" unless $msg =~ /\n$/s;
Lines 107-126 sub warn_pedantic ($$$) { Link Here
107
    $warned += 1;
107
    $warned += 1;
108
}
108
}
109
109
110
sub error_additional ($$) {
110
sub error_additional {
111
    my($msg, $lc) = @_;
111
    my($msg, $lc) = @_;
112
    my $prefix = construct_warn_prefix('ERROR', $lc);
112
    my $prefix = construct_warn_prefix('ERROR', $lc);
113
    $msg .= "\n" unless $msg =~ /\n$/s;
113
    $msg .= "\n" unless $msg =~ /\n$/s;
114
    warn "$prefix$msg";
114
    warn "$prefix$msg";
115
}
115
}
116
116
117
sub error_normal ($$) {
117
sub error_normal {
118
    my($msg, $lc) = @_;
118
    my($msg, $lc) = @_;
119
    $erred += 1;
119
    $erred += 1;
120
    error_additional($msg, $lc);
120
    error_additional($msg, $lc);
121
}
121
}
122
122
123
sub warned () {
123
sub warned {
124
    return $warned; # number of times warned
124
    return $warned; # number of times warned
125
}
125
}
126
126
(-)a/misc/translator/text-extract.pl (-2 / +1 lines)
Lines 1-6 Link Here
1
#!/usr/bin/perl
1
#!/usr/bin/perl
2
#use strict;
2
use Modern::Perl;
3
#use warnings; FIXME - Bug 2505
4
use HTML::Tree;
3
use HTML::Tree;
5
use Getopt::Std;
4
use Getopt::Std;
6
getopt("f:");
5
getopt("f:");
(-)a/misc/translator/text-extract2.pl (-18 / +18 lines)
Lines 27-42 use vars qw( $allow_cformat_p ); # FOR TESTING PURPOSES ONLY!! Link Here
27
27
28
###############################################################################
28
###############################################################################
29
29
30
sub underline ($) { # for testing only
30
sub underline { # for testing only
31
    my($s) = @_;
31
    my($s) = @_;
32
    join('', map {/[\0-\37]/? $_: "$_\b$_"} split(//, $s));
32
    join('', map {/[\0-\37]/? $_: "$_\b$_"} split(//, $s));
33
}
33
}
34
34
35
sub debug_dump ($) { # for testing only
35
sub debug_dump { # for testing only
36
    my($h) = @_;
36
    my($h) = @_;
37
    print "re_tag_compat is /", TmplTokenizer::re_tag(1), "/\n";
37
    print "re_tag_compat is /", TmplTokenizer::re_tag(1), "/\n";
38
    for (;;) {
38
    for (;;) {
39
	my $s = TmplTokenizer::next_token $h;
39
	my $s = TmplTokenizer::next_token($h);
40
    last unless defined $s;
40
    last unless defined $s;
41
	printf "%s\n", ('-' x 79);
41
	printf "%s\n", ('-' x 79);
42
	my($kind, $t, $attr) = ($s->type, $s->string, $s->attributes);
42
	my($kind, $t, $attr) = ($s->type, $s->string, $s->attributes);
Lines 46-70 sub debug_dump ($) { # for testing only Link Here
46
	    printf "Attributes:\n";
46
	    printf "Attributes:\n";
47
	    for my $a (keys %$attr) {
47
	    for my $a (keys %$attr) {
48
		my($key, $val, $val_orig, $order) = @{$attr->{$a}};
48
		my($key, $val, $val_orig, $order) = @{$attr->{$a}};
49
		printf "%s = %dH%s -- %s\n", $a, length $val, underline $val,
49
		printf "%s = %dH%s -- %s\n", $a, length $val, underline($val),
50
		$val_orig;
50
		$val_orig;
51
	    }
51
	    }
52
	}
52
	}
53
    if ($kind == TmplTokenType::TEXT_PARAMETRIZED()) {
53
    if ($kind == TmplTokenType::TEXT_PARAMETRIZED()) {
54
	    printf "Form (c-format string):\n";
54
	    printf "Form (c-format string):\n";
55
	    printf "%dH%s\n", length $s->form, underline $s->form;
55
	    printf "%dH%s\n", length $s->form, underline($s->form);
56
	    printf "Parameters:\n";
56
	    printf "Parameters:\n";
57
	    my $i = 1;
57
	    my $i = 1;
58
	    for my $a ($s->parameters) {
58
	    for my $a ($s->parameters) {
59
		my $t = $a->string;
59
		my $t = $a->string;
60
		printf "%%%d\$s = %dH%s\n", $i, length $t, underline $t;
60
		printf "%%%d\$s = %dH%s\n", $i, length $t, underline($t);
61
		$i += 1;
61
		$i += 1;
62
	    }
62
	    }
63
	}
63
	}
64
	if ($s->has_js_data) {
64
	if ($s->has_js_data) {
65
	    printf "JavaScript translatable strings:\n";
65
	    printf "JavaScript translatable strings:\n";
66
	    for my $t (@{$s->js_data}) {
66
	    for my $t (@{$s->js_data}) {
67
		printf "%dH%s\n", length $t->[3], underline $t->[3] if $t->[0]; # FIXME
67
		printf "%dH%s\n", length $t->[3], underline($t->[3]) if $t->[0]; # FIXME
68
	    }
68
	    }
69
	}
69
	}
70
    }
70
    }
Lines 72-97 sub debug_dump ($) { # for testing only Link Here
72
72
73
###############################################################################
73
###############################################################################
74
74
75
sub text_extract ($) {
75
sub text_extract {
76
    my($h) = @_;
76
    my($h) = @_;
77
    my %text = ();
77
    my %text = ();
78
    for (;;) {
78
    for (;;) {
79
	my $s = TmplTokenizer::next_token $h;
79
	my $s = TmplTokenizer::next_token($h);
80
    last unless defined $s;
80
    last unless defined $s;
81
	my($kind, $t, $attr) = ($s->type, $s->string, $s->attributes);
81
	my($kind, $t, $attr) = ($s->type, $s->string, $s->attributes);
82
    if ($kind == TmplTokenType::TEXT()) {
82
    if ($kind == TmplTokenType::TEXT()) {
83
	    $t = TmplTokenizer::trim $t;
83
	    $t = TmplTokenizer::trim($t);
84
	    $text{$t} = 1 if $t =~ /\S/s;
84
	    $text{$t} = 1 if $t =~ /\S/s;
85
    } elsif ($kind == TmplTokenType::TAG() && %$attr) {
85
    } elsif ($kind == TmplTokenType::TAG() && %$attr) {
86
	    # value [tag=input], meta
86
	    # value [tag=input], meta
87
	    my $tag = lc($1) if $t =~ /^<(\S+)/s;
87
	    my $tag = ($t =~ /^<(\S+)/s) ? lc($1) : undef;
88
	    for my $a ('alt', 'content', 'title', 'value') {
88
	    for my $a ('alt', 'content', 'title', 'value') {
89
		if ($attr->{$a}) {
89
		if ($attr->{$a}) {
90
		    next if $a eq 'content' && $tag ne 'meta';
90
		    next if $a eq 'content' && $tag ne 'meta';
91
		    next if $a eq 'value' && ($tag ne 'input'
91
		    next if $a eq 'value' && ($tag ne 'input'
92
			|| (ref $attr->{'type'} && $attr->{'type'}->[1] =~ /^(?:hidden|radio)$/)); # FIXME
92
			|| (ref $attr->{'type'} && $attr->{'type'}->[1] =~ /^(?:hidden|radio)$/)); # FIXME
93
		    my($key, $val, $val_orig, $order) = @{$attr->{$a}}; #FIXME
93
		    my($key, $val, $val_orig, $order) = @{$attr->{$a}}; #FIXME
94
		    $val = TmplTokenizer::trim $val;
94
		    $val = TmplTokenizer::trim($val);
95
		    $text{$val} = 1 if $val =~ /\S/s;
95
		    $text{$val} = 1 if $val =~ /\S/s;
96
		}
96
		}
97
	    }
97
	    }
Lines 111-117 sub text_extract ($) { Link Here
111
111
112
###############################################################################
112
###############################################################################
113
113
114
sub usage ($) {
114
sub usage {
115
    my($exitcode) = @_;
115
    my($exitcode) = @_;
116
    my $h = $exitcode? *STDERR: *STDOUT;
116
    my $h = $exitcode? *STDERR: *STDOUT;
117
    print $h <<EOF;
117
    print $h <<EOF;
Lines 129-135 EOF Link Here
129
129
130
###############################################################################
130
###############################################################################
131
131
132
sub usage_error (;$) {
132
sub usage_error {
133
    print STDERR "$_[0]\n" if @_;
133
    print STDERR "$_[0]\n" if @_;
134
    print STDERR "Try `$0 --help' for more information.\n";
134
    print STDERR "Try `$0 --help' for more information.\n";
135
    exit(-1);
135
    exit(-1);
Lines 143-153 GetOptions( Link Here
143
    'debug-dump-only'	=> \$debug_dump_only_p,
143
    'debug-dump-only'	=> \$debug_dump_only_p,
144
    'pedantic-warnings'	=> sub { $pedantic_p = 1 },
144
    'pedantic-warnings'	=> sub { $pedantic_p = 1 },
145
    'help'		=> sub { usage(0) },
145
    'help'		=> sub { usage(0) },
146
) || usage_error;
146
) || usage_error();
147
147
148
VerboseWarnings::set_application_name $0;
148
VerboseWarnings::set_application_name($0);
149
VerboseWarnings::set_input_file_name $input;
149
VerboseWarnings::set_input_file_name($input);
150
VerboseWarnings::set_pedantic_mode $pedantic_p;
150
VerboseWarnings::set_pedantic_mode($pedantic_p);
151
151
152
usage_error('Missing mandatory option -f') unless defined $input;
152
usage_error('Missing mandatory option -f') unless defined $input;
153
153
(-)a/misc/translator/tmpl_process3.pl (-41 / +40 lines)
Lines 32-38 use vars qw( $charset_in $charset_out ); Link Here
32
32
33
###############################################################################
33
###############################################################################
34
34
35
sub find_translation ($) {
35
sub find_translation {
36
    my($s) = @_;
36
    my($s) = @_;
37
    my $key = $s;
37
    my $key = $s;
38
    if ($s =~ /\S/s) {
38
    if ($s =~ /\S/s) {
Lines 53-64 sub find_translation ($) { Link Here
53
    }
53
    }
54
}
54
}
55
55
56
sub text_replace_tag ($$) {
56
sub text_replace_tag {
57
    my($t, $attr) = @_;
57
    my($t, $attr) = @_;
58
    my $it;
58
    my $it;
59
59
60
    # value [tag=input], meta
60
    # value [tag=input], meta
61
    my $tag = lc($1) if $t =~ /^<(\S+)/s;
61
    my $tag = ($t =~ /^<(\S+)/s) ? lc($1) : undef;
62
    my $translated_p = 0;
62
    my $translated_p = 0;
63
    for my $a ('alt', 'content', 'title', 'value', 'label', 'placeholder') {
63
    for my $a ('alt', 'content', 'title', 'value', 'label', 'placeholder') {
64
    if ($attr->{$a}) {
64
    if ($attr->{$a}) {
Lines 97-106 sub text_replace_tag ($$) { Link Here
97
    return $it;
97
    return $it;
98
}
98
}
99
99
100
sub text_replace (**) {
100
sub text_replace {
101
    my($h, $output) = @_;
101
    my($h, $output) = @_;
102
    for (;;) {
102
    for (;;) {
103
    my $s = TmplTokenizer::next_token $h;
103
    my $s = TmplTokenizer::next_token($h);
104
    last unless defined $s;
104
    last unless defined $s;
105
    my($kind, $t, $attr) = ($s->type, $s->string, $s->attributes);
105
    my($kind, $t, $attr) = ($s->type, $s->string, $s->attributes);
106
    if ($kind eq C4::TmplTokenType::TEXT) {
106
    if ($kind eq C4::TmplTokenType::TEXT) {
Lines 118-124 sub text_replace (**) { Link Here
118
        for my $t (@{$s->js_data}) {
118
        for my $t (@{$s->js_data}) {
119
        # FIXME for this whole block
119
        # FIXME for this whole block
120
        if ($t->[0]) {
120
        if ($t->[0]) {
121
            printf $output "%s%s%s", $t->[2], find_translation $t->[3],
121
            printf $output "%s%s%s", $t->[2], find_translation($t->[3]),
122
                $t->[2];
122
                $t->[2];
123
        } else {
123
        } else {
124
            print $output $t->[1];
124
            print $output $t->[1];
Lines 158-171 sub listfiles { Link Here
158
            }
158
            }
159
        }
159
        }
160
    } else {
160
    } else {
161
        warn_normal "$dir: $!", undef;
161
        warn_normal("$dir: $!", undef);
162
    }
162
    }
163
    return @it;
163
    return @it;
164
}
164
}
165
165
166
###############################################################################
166
###############################################################################
167
167
168
sub mkdir_recursive ($) {
168
sub mkdir_recursive {
169
    my($dir) = @_;
169
    my($dir) = @_;
170
    local($`, $&, $', $1);
170
    local($`, $&, $', $1);
171
    $dir = $` if $dir ne /^\/+$/ && $dir =~ /\/+$/;
171
    $dir = $` if $dir ne /^\/+$/ && $dir =~ /\/+$/;
Lines 174-186 sub mkdir_recursive ($) { Link Here
174
    if (!-d $dir) {
174
    if (!-d $dir) {
175
    print STDERR "Making directory $dir...\n" unless $quiet;
175
    print STDERR "Making directory $dir...\n" unless $quiet;
176
    # creates with rwxrwxr-x permissions
176
    # creates with rwxrwxr-x permissions
177
    mkdir($dir, 0775) || warn_normal "$dir: $!", undef;
177
    mkdir($dir, 0775) || warn_normal("$dir: $!", undef);
178
    }
178
    }
179
}
179
}
180
180
181
###############################################################################
181
###############################################################################
182
182
183
sub usage ($) {
183
sub usage {
184
    my($exitcode) = @_;
184
    my($exitcode) = @_;
185
    my $h = $exitcode? *STDERR: *STDOUT;
185
    my $h = $exitcode? *STDERR: *STDOUT;
186
    print $h <<EOF;
186
    print $h <<EOF;
Lines 218-224 EOF Link Here
218
218
219
###############################################################################
219
###############################################################################
220
220
221
sub usage_error (;$) {
221
sub usage_error {
222
    for my $msg (split(/\n/, $_[0])) {
222
    for my $msg (split(/\n/, $_[0])) {
223
    print STDERR "$msg\n";
223
    print STDERR "$msg\n";
224
    }
224
    }
Lines 240-249 GetOptions( Link Here
240
    'quiet|q'               => \$quiet,
240
    'quiet|q'               => \$quiet,
241
    'pedantic-warnings|pedantic'    => sub { $pedantic_p = 1 },
241
    'pedantic-warnings|pedantic'    => sub { $pedantic_p = 1 },
242
    'help'              => \&usage,
242
    'help'              => \&usage,
243
) || usage_error;
243
) || usage_error();
244
244
245
VerboseWarnings::set_application_name $0;
245
VerboseWarnings::set_application_name($0);
246
VerboseWarnings::set_pedantic_mode $pedantic_p;
246
VerboseWarnings::set_pedantic_mode($pedantic_p);
247
247
248
# keep the buggy Locale::PO quiet if it says stupid things
248
# keep the buggy Locale::PO quiet if it says stupid things
249
$SIG{__WARN__} = sub {
249
$SIG{__WARN__} = sub {
Lines 287-293 $href = Locale::PO->load_file_ashash($str_file); Link Here
287
# guess the charsets. HTML::Templates defaults to iso-8859-1
287
# guess the charsets. HTML::Templates defaults to iso-8859-1
288
if (defined $href) {
288
if (defined $href) {
289
    die "$str_file: PO file is corrupted, or not a PO file\n" unless defined $href->{'""'};
289
    die "$str_file: PO file is corrupted, or not a PO file\n" unless defined $href->{'""'};
290
    $charset_out = TmplTokenizer::charset_canon $2 if $href->{'""'}->msgstr =~ /\bcharset=(["']?)([^;\s"'\\]+)\1/;
290
    $charset_out = TmplTokenizer::charset_canon($2) if $href->{'""'}->msgstr =~ /\bcharset=(["']?)([^;\s"'\\]+)\1/;
291
    $charset_in = $charset_out;
291
    $charset_in = $charset_out;
292
#     for my $msgid (keys %$href) {
292
#     for my $msgid (keys %$href) {
293
#   if ($msgid =~ /\bcharset=(["']?)([^;\s"'\\]+)\1/) {
293
#   if ($msgid =~ /\bcharset=(["']?)([^;\s"'\\]+)\1/) {
Lines 306-327 if (defined $href) { Link Here
306
        next if $id_count == $str_count ||
306
        next if $id_count == $str_count ||
307
                $msg->{msgstr} eq '""' ||
307
                $msg->{msgstr} eq '""' ||
308
                grep { /fuzzy/ } @{$msg->{_flags}};
308
                grep { /fuzzy/ } @{$msg->{_flags}};
309
        warn_normal
309
        warn_normal(
310
            "unconsistent %s count: ($id_count/$str_count):\n" .
310
            "unconsistent %s count: ($id_count/$str_count):\n" .
311
            "  line:   " . $msg->{loaded_line_number} . "\n" .
311
            "  line:   " . $msg->{loaded_line_number} . "\n" .
312
            "  msgid:  " . $msg->{msgid} . "\n" .
312
            "  msgid:  " . $msg->{msgid} . "\n" .
313
            "  msgstr: " . $msg->{msgstr} . "\n", undef;
313
            "  msgstr: " . $msg->{msgstr} . "\n", undef);
314
    }
314
    }
315
}
315
}
316
316
317
# set our charset in to UTF-8
317
# set our charset in to UTF-8
318
if (!defined $charset_in) {
318
if (!defined $charset_in) {
319
    $charset_in = TmplTokenizer::charset_canon 'UTF-8';
319
    $charset_in = TmplTokenizer::charset_canon('UTF-8');
320
    warn "Warning: Can't determine original templates' charset, defaulting to $charset_in\n";
320
    warn "Warning: Can't determine original templates' charset, defaulting to $charset_in\n";
321
}
321
}
322
# set our charset out to UTF-8
322
# set our charset out to UTF-8
323
if (!defined $charset_out) {
323
if (!defined $charset_out) {
324
    $charset_out = TmplTokenizer::charset_canon 'UTF-8';
324
    $charset_out = TmplTokenizer::charset_canon('UTF-8');
325
    warn "Warning: Charset Out defaulting to $charset_out\n";
325
    warn "Warning: Charset Out defaulting to $charset_out\n";
326
}
326
}
327
my $xgettext = './xgettext.pl'; # actual text extractor script
327
my $xgettext = './xgettext.pl'; # actual text extractor script
Lines 356-378 if ($action eq 'create') { Link Here
356
    # FIXME: msgmerge(1) is a Unix dependency
356
    # FIXME: msgmerge(1) is a Unix dependency
357
    # FIXME: need to check the return value
357
    # FIXME: need to check the return value
358
    unless (-f $str_file) {
358
    unless (-f $str_file) {
359
        local(*INPUT, *OUTPUT);
359
        open(my $infh, '<', $tmpfile2);
360
        open(INPUT, "<$tmpfile2");
360
        open(my $outfh, '>', $str_file);
361
        open(OUTPUT, ">$str_file");
361
        while (<$infh>) {
362
        while (<INPUT>) {
362
        print $outfh;
363
        print OUTPUT;
364
        last if /^\n/s;
363
        last if /^\n/s;
365
        }
364
        }
366
        close INPUT;
365
        close $infh;
367
        close OUTPUT;
366
        close $outfh;
368
    }
367
    }
369
    $st = system("msgmerge ".($quiet?'-q':'')." -s $str_file $tmpfile2 -o - | msgattrib --no-obsolete -o $str_file");
368
    $st = system("msgmerge ".($quiet?'-q':'')." -s $str_file $tmpfile2 -o - | msgattrib --no-obsolete -o $str_file");
370
    } else {
369
    } else {
371
    error_normal "Text extraction failed: $xgettext: $!\n", undef;
370
    error_normal("Text extraction failed: $xgettext: $!\n", undef);
372
    error_additional "Will not run msgmerge\n", undef;
371
    error_additional("Will not run msgmerge\n", undef);
373
    }
372
    }
374
    unlink $tmpfile1 || warn_normal "$tmpfile1: unlink failed: $!\n", undef;
373
    unlink $tmpfile1 || warn_normal("$tmpfile1: unlink failed: $!\n", undef);
375
    unlink $tmpfile2 || warn_normal "$tmpfile2: unlink failed: $!\n", undef;
374
    unlink $tmpfile2 || warn_normal("$tmpfile2: unlink failed: $!\n", undef);
376
375
377
} elsif ($action eq 'update') {
376
} elsif ($action eq 'update') {
378
    my($tmph1, $tmpfile1) = tmpnam();
377
    my($tmph1, $tmpfile1) = tmpnam();
Lines 401-411 if ($action eq 'create') { Link Here
401
            $st = system("msgmerge ".($quiet?'-q':'')." -s $str_file $tmpfile2 -o - | msgattrib --no-obsolete -o $str_file");
400
            $st = system("msgmerge ".($quiet?'-q':'')." -s $str_file $tmpfile2 -o - | msgattrib --no-obsolete -o $str_file");
402
        }
401
        }
403
    } else {
402
    } else {
404
        error_normal "Text extraction failed: $xgettext: $!\n", undef;
403
        error_normal("Text extraction failed: $xgettext: $!\n", undef);
405
        error_additional "Will not run msgmerge\n", undef;
404
        error_additional("Will not run msgmerge\n", undef);
406
    }
405
    }
407
    unlink $tmpfile1 || warn_normal "$tmpfile1: unlink failed: $!\n", undef;
406
    unlink $tmpfile1 || warn_normal("$tmpfile1: unlink failed: $!\n", undef);
408
    unlink $tmpfile2 || warn_normal "$tmpfile2: unlink failed: $!\n", undef;
407
    unlink $tmpfile2 || warn_normal("$tmpfile2: unlink failed: $!\n", undef);
409
408
410
} elsif ($action eq 'install') {
409
} elsif ($action eq 'install') {
411
    if(!defined($out_dir)) {
410
    if(!defined($out_dir)) {
Lines 428-435 if ($action eq 'create') { Link Here
428
    -d $out_dir || die "$out_dir: The directory does not exist\n";
427
    -d $out_dir || die "$out_dir: The directory does not exist\n";
429
428
430
    # Try to open the file, because Locale::PO doesn't check :-/
429
    # Try to open the file, because Locale::PO doesn't check :-/
431
    open(INPUT, "<$str_file") || die "$str_file: $!\n";
430
    open(my $fh, '<', $str_file) || die "$str_file: $!\n";
432
    close INPUT;
431
    close $fh;
433
432
434
    # creates the new tmpl file using the new translation
433
    # creates the new tmpl file using the new translation
435
    for my $input (@in_files) {
434
    for my $input (@in_files) {
Lines 437-453 if ($action eq 'create') { Link Here
437
            unless substr($input, 0, length($in_dir) + 1) eq "$in_dir/";
436
            unless substr($input, 0, length($in_dir) + 1) eq "$in_dir/";
438
437
439
        my $target = $out_dir . substr($input, length($in_dir));
438
        my $target = $out_dir . substr($input, length($in_dir));
440
        my $targetdir = $` if $target =~ /[^\/]+$/s;
439
        my $targetdir = ($target =~ /[^\/]+$/s) ? $` : undef;
441
440
442
        if (!defined $type || $input =~ /\.(?:$type)$/) {
441
        if (!defined $type || $input =~ /\.(?:$type)$/) {
443
            my $h = TmplTokenizer->new( $input );
442
            my $h = TmplTokenizer->new( $input );
444
            $h->set_allow_cformat( 1 );
443
            $h->set_allow_cformat( 1 );
445
            VerboseWarnings::set_input_file_name $input;
444
            VerboseWarnings::set_input_file_name($input);
446
            mkdir_recursive($targetdir) unless -d $targetdir;
445
            mkdir_recursive($targetdir) unless -d $targetdir;
447
            print STDERR "Creating $target...\n" unless $quiet;
446
            print STDERR "Creating $target...\n" unless $quiet;
448
            open( OUTPUT, ">$target" ) || die "$target: $!\n";
447
            open( my $fh, '>', $target ) || die "$target: $!\n";
449
            text_replace( $h, *OUTPUT );
448
            text_replace( $h, $fh );
450
            close OUTPUT;
449
            close $fh;
451
        } else {
450
        } else {
452
        # just copying the file
451
        # just copying the file
453
            mkdir_recursive($targetdir) unless -d $targetdir;
452
            mkdir_recursive($targetdir) unless -d $targetdir;
(-)a/misc/translator/xgettext.pl (-13 / +15 lines)
Lines 98-104 sub string_list { Link Here
98
sub text_extract {
98
sub text_extract {
99
    my($h) = @_;
99
    my($h) = @_;
100
    for (;;) {
100
    for (;;) {
101
        my $s = TmplTokenizer::next_token $h;
101
        my $s = TmplTokenizer::next_token($h);
102
        last unless defined $s;
102
        last unless defined $s;
103
        my($kind, $t, $attr) = ($s->type, $s->string, $s->attributes);
103
        my($kind, $t, $attr) = ($s->type, $s->string, $s->attributes);
104
        if ($kind eq C4::TmplTokenType::TEXT) {
104
        if ($kind eq C4::TmplTokenType::TEXT) {
Lines 120-126 sub text_extract { Link Here
120
                    next if $a eq 'value' && ($tag ne 'input'
120
                    next if $a eq 'value' && ($tag ne 'input'
121
                        || (ref $attr->{'type'} && $attr->{'type'}->[1] =~ /^(?:hidden|radio|checkbox)$/)); # FIXME
121
                        || (ref $attr->{'type'} && $attr->{'type'}->[1] =~ /^(?:hidden|radio|checkbox)$/)); # FIXME
122
                    my($key, $val, $val_orig, $order) = @{$attr->{$a}}; #FIXME
122
                    my($key, $val, $val_orig, $order) = @{$attr->{$a}}; #FIXME
123
                    $val = TmplTokenizer::trim $val;
123
                    $val = TmplTokenizer::trim($val);
124
                    remember( $s, $val ) if $val =~ /\S/s;
124
                    remember( $s, $val ) if $val =~ /\S/s;
125
                }
125
                }
126
            }
126
            }
Lines 146-152 sub generate_strings_list { Link Here
146
sub generate_po_file {
146
sub generate_po_file {
147
    # We don't emit the Plural-Forms header; it's meaningless for us
147
    # We don't emit the Plural-Forms header; it's meaningless for us
148
    my $pot_charset = (defined $charset_out? $charset_out: 'CHARSET');
148
    my $pot_charset = (defined $charset_out? $charset_out: 'CHARSET');
149
    $pot_charset = TmplTokenizer::charset_canon $pot_charset;
149
    $pot_charset = TmplTokenizer::charset_canon($pot_charset);
150
    # Time stamps aren't exactly right semantically. I don't know how to fix it.
150
    # Time stamps aren't exactly right semantically. I don't know how to fix it.
151
    my $time = POSIX::strftime('%Y-%m-%d %H:%M%z', localtime(time));
151
    my $time = POSIX::strftime('%Y-%m-%d %H:%M%z', localtime(time));
152
    my $time_pot = $time;
152
    my $time_pot = $time;
Lines 235-243 EOF Link Here
235
	    $cformat_p = 1 if $token->type == C4::TmplTokenType::TEXT_PARAMETRIZED;
235
	    $cformat_p = 1 if $token->type == C4::TmplTokenType::TEXT_PARAMETRIZED;
236
	}
236
	}
237
        printf $OUTPUT "#, c-format\n" if $cformat_p;
237
        printf $OUTPUT "#, c-format\n" if $cformat_p;
238
        printf $OUTPUT "msgid %s\n", TmplTokenizer::quote_po
238
        printf $OUTPUT "msgid %s\n", TmplTokenizer::quote_po(
239
		TmplTokenizer::string_canon
239
            TmplTokenizer::string_canon(
240
		TmplTokenizer::charset_convert $t, $charset_in, $charset_out;
240
                TmplTokenizer::charset_convert($t, $charset_in, $charset_out)
241
            )
242
        );
241
        printf $OUTPUT "msgstr %s\n\n", (defined $translation{$t}?
243
        printf $OUTPUT "msgstr %s\n\n", (defined $translation{$t}?
242
		TmplTokenizer::quote_po( $translation{$t} ): "\"\"");
244
		TmplTokenizer::quote_po( $translation{$t} ): "\"\"");
243
    }
245
    }
Lines 247-253 EOF Link Here
247
249
248
sub convert_translation_file {
250
sub convert_translation_file {
249
    open(my $INPUT, '<', $convert_from) || die "$convert_from: $!\n";
251
    open(my $INPUT, '<', $convert_from) || die "$convert_from: $!\n";
250
    VerboseWarnings::set_input_file_name $convert_from;
252
    VerboseWarnings::set_input_file_name($convert_from);
251
    while (<$INPUT>) {
253
    while (<$INPUT>) {
252
	chomp;
254
	chomp;
253
	my($msgid, $msgstr) = split(/\t/);
255
	my($msgid, $msgstr) = split(/\t/);
Lines 264-276 sub convert_translation_file { Link Here
264
	$translation{$msgid} = $msgstr unless $msgstr eq '*****';
266
	$translation{$msgid} = $msgstr unless $msgstr eq '*****';
265
267
266
	if ($msgid  =~ /\bcharset=(["']?)([^;\s"']+)\1/s) {
268
	if ($msgid  =~ /\bcharset=(["']?)([^;\s"']+)\1/s) {
267
	    my $candidate = TmplTokenizer::charset_canon $2;
269
	    my $candidate = TmplTokenizer::charset_canon($2);
268
	    die "Conflicting charsets in msgid: $candidate vs $charset_in\n"
270
	    die "Conflicting charsets in msgid: $candidate vs $charset_in\n"
269
		    if defined $charset_in && $charset_in ne $candidate;
271
		    if defined $charset_in && $charset_in ne $candidate;
270
	    $charset_in = $candidate;
272
	    $charset_in = $candidate;
271
	}
273
	}
272
	if ($msgstr =~ /\bcharset=(["']?)([^;\s"']+)\1/s) {
274
	if ($msgstr =~ /\bcharset=(["']?)([^;\s"']+)\1/s) {
273
	    my $candidate = TmplTokenizer::charset_canon $2;
275
	    my $candidate = TmplTokenizer::charset_canon($2);
274
	    die "Conflicting charsets in msgid: $candidate vs $charset_out\n"
276
	    die "Conflicting charsets in msgid: $candidate vs $charset_out\n"
275
		    if defined $charset_out && $charset_out ne $candidate;
277
		    if defined $charset_out && $charset_out ne $candidate;
276
	    $charset_out = $candidate;
278
	    $charset_out = $candidate;
Lines 278-284 sub convert_translation_file { Link Here
278
    }
280
    }
279
    # The following assumption is correct; that's what HTML::Template assumes
281
    # The following assumption is correct; that's what HTML::Template assumes
280
    if (!defined $charset_in) {
282
    if (!defined $charset_in) {
281
	$charset_in = $charset_out = TmplTokenizer::charset_canon 'utf-8';
283
	$charset_in = $charset_out = TmplTokenizer::charset_canon('utf-8');
282
	warn "Warning: Can't determine original templates' charset, defaulting to $charset_in\n";
284
	warn "Warning: Can't determine original templates' charset, defaulting to $charset_in\n";
283
    }
285
    }
284
}
286
}
Lines 346-353 GetOptions( Link Here
346
    'help'				=> sub { usage(0) },
348
    'help'				=> sub { usage(0) },
347
) || usage_error;
349
) || usage_error;
348
350
349
VerboseWarnings::set_application_name $0;
351
VerboseWarnings::set_application_name($0);
350
VerboseWarnings::set_pedantic_mode $pedantic_p;
352
VerboseWarnings::set_pedantic_mode($pedantic_p);
351
353
352
usage_error('Missing mandatory option -f')
354
usage_error('Missing mandatory option -f')
353
	unless defined $files_from || defined $convert_from;
355
	unless defined $files_from || defined $convert_from;
Lines 372-378 if (defined $files_from) { Link Here
372
	my $input = /^\//? $_: "$directory/$_";
374
	my $input = /^\//? $_: "$directory/$_";
373
	my $h = TmplTokenizer->new( $input );
375
	my $h = TmplTokenizer->new( $input );
374
	$h->set_allow_cformat( 1 );
376
	$h->set_allow_cformat( 1 );
375
	VerboseWarnings::set_input_file_name $input;
377
	VerboseWarnings::set_input_file_name($input);
376
	print STDERR "$0: Processing file \"$input\"\n" if $verbose_p;
378
	print STDERR "$0: Processing file \"$input\"\n" if $verbose_p;
377
	text_extract( $h );
379
	text_extract( $h );
378
    }
380
    }
(-)a/opac/opac-MARCdetail.pl (-1 lines)
Lines 152-158 if (C4::Context->preference("RequestOnOpac")) { Link Here
152
152
153
# fill arrays
153
# fill arrays
154
my @loop_data = ();
154
my @loop_data = ();
155
my $tag;
156
155
157
# loop through each tab 0 through 9
156
# loop through each tab 0 through 9
158
for ( my $tabloop = 0 ; $tabloop <= 9 ; $tabloop++ ) {
157
for ( my $tabloop = 0 ; $tabloop <= 9 ; $tabloop++ ) {
(-)a/opac/opac-alert-subscribe.pl (-1 lines)
Lines 32-38 my $query = new CGI; Link Here
32
my $op    = $query->param('op') || '';
32
my $op    = $query->param('op') || '';
33
my $dbh   = C4::Context->dbh;
33
my $dbh   = C4::Context->dbh;
34
34
35
my $sth;
36
my ( $template, $loggedinuser, $cookie );
35
my ( $template, $loggedinuser, $cookie );
37
my $subscriptionid = $query->param('subscriptionid');
36
my $subscriptionid = $query->param('subscriptionid');
38
my $referer      = $query->param('referer') || 'detail';
37
my $referer      = $query->param('referer') || 'detail';
(-)a/opac/opac-authorities-home.pl (-1 lines)
Lines 56-62 if ( $op eq "do_search" ) { Link Here
56
    my @value = $query->multi_param('value');
56
    my @value = $query->multi_param('value');
57
    $value[0] ||= q||;
57
    $value[0] ||= q||;
58
58
59
    my @tags;
60
    my $builder = Koha::SearchEngine::QueryBuilder->new(
59
    my $builder = Koha::SearchEngine::QueryBuilder->new(
61
        { index => $Koha::SearchEngine::AUTHORITIES_INDEX } );
60
        { index => $Koha::SearchEngine::AUTHORITIES_INDEX } );
62
    my $searcher = Koha::SearchEngine::Search->new(
61
    my $searcher = Koha::SearchEngine::Search->new(
(-)a/opac/opac-authoritiesdetail.pl (-1 lines)
Lines 109-115 if ($show_marc) { Link Here
109
109
110
# fill arrays
110
# fill arrays
111
    my @loop_data = ();
111
    my @loop_data = ();
112
    my $tag;
113
112
114
# loop through each tag
113
# loop through each tag
115
    my @fields    = $record->fields();
114
    my @fields    = $record->fields();
(-)a/opac/opac-basket.pl (-1 lines)
Lines 89-95 foreach my $biblionumber ( @bibs ) { Link Here
89
      { map { $_->{authorised_value} => $_->{opac_description} } Koha::AuthorisedValues->get_descriptions_by_koha_field( { frameworkcode => $dat->{frameworkcode}, kohafield => 'items.location' } ) };
89
      { map { $_->{authorised_value} => $_->{opac_description} } Koha::AuthorisedValues->get_descriptions_by_koha_field( { frameworkcode => $dat->{frameworkcode}, kohafield => 'items.location' } ) };
90
90
91
	# COinS format FIXME: for books Only
91
	# COinS format FIXME: for books Only
92
        my $coins_format;
93
        my $fmt = substr $record->leader(), 6,2;
92
        my $fmt = substr $record->leader(), 6,2;
94
        my $fmts;
93
        my $fmts;
95
        $fmts->{'am'} = 'book';
94
        $fmts->{'am'} = 'book';
(-)a/opac/opac-search.pl (-5 lines)
Lines 531-538 my $expanded_facet = $params->{'expand'}; Link Here
531
# Define some global variables
531
# Define some global variables
532
my ($error,$query,$simple_query,$query_cgi,$query_desc,$limit,$limit_cgi,$limit_desc,$query_type);
532
my ($error,$query,$simple_query,$query_cgi,$query_desc,$limit,$limit_cgi,$limit_desc,$query_type);
533
533
534
my @results;
535
536
my $suppress = 0;
534
my $suppress = 0;
537
if (C4::Context->preference('OpacSuppression')) {
535
if (C4::Context->preference('OpacSuppression')) {
538
    # OPAC suppression by IP address
536
    # OPAC suppression by IP address
Lines 583-591 $template->param ( OPACResultsSidebar => C4::Context->preference('OPACResultsSid Link Here
583
## II. DO THE SEARCH AND GET THE RESULTS
581
## II. DO THE SEARCH AND GET THE RESULTS
584
my $total = 0; # the total results for the whole set
582
my $total = 0; # the total results for the whole set
585
my $facets; # this object stores the faceted results that display on the left-hand of the results page
583
my $facets; # this object stores the faceted results that display on the left-hand of the results page
586
my @results_array;
587
my $results_hashref;
584
my $results_hashref;
588
my @coins;
589
585
590
if ($tag) {
586
if ($tag) {
591
    $query_cgi = "tag=" .$tag . "&" . $query_cgi;
587
    $query_cgi = "tag=" .$tag . "&" . $query_cgi;
Lines 938-944 for (my $i=0;$i<@servers;$i++) { Link Here
938
    # FIXME: can add support for other targets as needed here
934
    # FIXME: can add support for other targets as needed here
939
    $template->param(           outer_sup_results_loop => \@sup_results_array);
935
    $template->param(           outer_sup_results_loop => \@sup_results_array);
940
} #/end of the for loop
936
} #/end of the for loop
941
#$template->param(FEDERATED_RESULTS => \@results_array);
942
937
943
for my $facet ( @$facets ) {
938
for my $facet ( @$facets ) {
944
    for my $entry ( @{ $facet->{facets} } ) {
939
    for my $entry ( @{ $facet->{facets} } ) {
(-)a/opac/opac-serial-issues.pl (-2 lines)
Lines 34-41 my $dbh = C4::Context->dbh; Link Here
34
my $selectview = $query->param('selectview');
34
my $selectview = $query->param('selectview');
35
$selectview = C4::Context->preference("SubscriptionHistory") unless $selectview;
35
$selectview = C4::Context->preference("SubscriptionHistory") unless $selectview;
36
36
37
my $sth;
38
39
# my $id;
37
# my $id;
40
my ( $template, $loggedinuser, $cookie );
38
my ( $template, $loggedinuser, $cookie );
41
my $biblionumber = $query->param('biblionumber');
39
my $biblionumber = $query->param('biblionumber');
(-)a/opac/opac-showreviews.pl (-1 lines)
Lines 85-91 my $reviews = Koha::Reviews->search( Link Here
85
my $marcflavour      = C4::Context->preference("marcflavour");
85
my $marcflavour      = C4::Context->preference("marcflavour");
86
my $hits = Koha::Reviews->search({ approved => 1 })->count;
86
my $hits = Koha::Reviews->search({ approved => 1 })->count;
87
my $i = 0;
87
my $i = 0;
88
my $latest_comment_date;
89
for my $result (@$reviews){
88
for my $result (@$reviews){
90
    my $biblionumber = $result->{biblionumber};
89
    my $biblionumber = $result->{biblionumber};
91
    my $biblio = Koha::Biblios->find( $biblionumber );
90
    my $biblio = Koha::Biblios->find( $biblionumber );
(-)a/patroncards/create-pdf.pl (-5 / +5 lines)
Lines 44-56 my ( $template, $loggedinuser, $cookie ) = get_template_and_user({ Link Here
44
                                                                     flagsrequired   => { tools => 'label_creator' },
44
                                                                     flagsrequired   => { tools => 'label_creator' },
45
                                                                     debug           => 1,
45
                                                                     debug           => 1,
46
                                                                     });
46
                                                                     });
47
my $batch_id    = $cgi->param('batch_id') if $cgi->param('batch_id');
47
my $batch_id    = $cgi->param('batch_id') || undef;
48
my $template_id = $cgi->param('template_id') || undef;
48
my $template_id = $cgi->param('template_id') || undef;
49
my $layout_id   = $cgi->param('layout_id') || undef;
49
my $layout_id   = $cgi->param('layout_id') || undef;
50
my $layout_back_id   = $cgi->param('layout_back_id') || undef;
50
my $layout_back_id   = $cgi->param('layout_back_id') || undef;
51
my $start_card = $cgi->param('start_card') || 1;
51
my $start_card = $cgi->param('start_card') || 1;
52
my @label_ids   = $cgi->multi_param('label_id') if $cgi->param('label_id');
52
my @label_ids   = $cgi->multi_param('label_id');
53
my @borrower_numbers  = $cgi->multi_param('borrower_number') if $cgi->param('borrower_number');
53
my @borrower_numbers  = $cgi->multi_param('borrower_number');
54
my $patronlist_id = $cgi->param('patronlist_id');
54
my $patronlist_id = $cgi->param('patronlist_id');
55
55
56
my $items = undef; # items = cards
56
my $items = undef; # items = cards
Lines 70-76 $pdf = C4::Creators::PDF->new(InitVars => 0); Link Here
70
my $batch = C4::Patroncards::Batch->retrieve(batch_id => $batch_id);
70
my $batch = C4::Patroncards::Batch->retrieve(batch_id => $batch_id);
71
my $pc_template = C4::Patroncards::Template->retrieve(template_id => $template_id, profile_id => 1);
71
my $pc_template = C4::Patroncards::Template->retrieve(template_id => $template_id, profile_id => 1);
72
my $layout = C4::Patroncards::Layout->retrieve(layout_id => $layout_id);
72
my $layout = C4::Patroncards::Layout->retrieve(layout_id => $layout_id);
73
my $layout_back = C4::Patroncards::Layout->retrieve(layout_id => $layout_back_id) if ( $layout_back_id );
73
my $layout_back = $layout_back_id ? C4::Patroncards::Layout->retrieve(layout_id => $layout_back_id) : undef;
74
74
75
$| = 1;
75
$| = 1;
76
76
Lines 111-117 else { Link Here
111
}
111
}
112
112
113
my $layout_xml = XMLin($layout->get_attr('layout_xml'), ForceArray => 1);
113
my $layout_xml = XMLin($layout->get_attr('layout_xml'), ForceArray => 1);
114
my $layout_back_xml = XMLin($layout_back->get_attr('layout_xml'), ForceArray => 1) if ( defined $layout_back );
114
my $layout_back_xml = defined $layout_back ? XMLin($layout_back->get_attr('layout_xml'), ForceArray => 1) : undef;
115
115
116
if ($layout_xml->{'page_side'} eq 'B') { # rearrange items on backside of page to swap columns
116
if ($layout_xml->{'page_side'} eq 'B') { # rearrange items on backside of page to swap columns
117
    my $even = 1;
117
    my $even = 1;
(-)a/patroncards/image-manage.pl (-1 / +1 lines)
Lines 28-34 my $file_name = $cgi->param('uploadfile') || ''; Link Here
28
my $image_name = $cgi->param('image_name') || $file_name;
28
my $image_name = $cgi->param('image_name') || $file_name;
29
my $upload_file = $cgi->upload('uploadfile') || '';
29
my $upload_file = $cgi->upload('uploadfile') || '';
30
my $op = $cgi->param('op') || 'none';
30
my $op = $cgi->param('op') || 'none';
31
my @image_ids = $cgi->multi_param('image_id') if $cgi->param('image_id');
31
my @image_ids = $cgi->multi_param('image_id');
32
32
33
my $source_file = "$file_name"; # otherwise we end up with what amounts to a pointer to a filehandle rather than a user-friendly filename
33
my $source_file = "$file_name"; # otherwise we end up with what amounts to a pointer to a filehandle rather than a user-friendly filename
34
34
(-)a/patroncards/print.pl (-6 / +6 lines)
Lines 40-53 my ( $template, $loggedinuser, $cookie ) = get_template_and_user( Link Here
40
);
40
);
41
41
42
my $op = $cgi->param('op') || 'none';
42
my $op = $cgi->param('op') || 'none';
43
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
43
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
44
my @batch_ids = $cgi->multi_param('batch_id') if $cgi->param('batch_id');
44
my @batch_ids = $cgi->multi_param('batch_id');
45
my $patronlist_id = $cgi->param('patronlist_id') || undef;
45
my $patronlist_id = $cgi->param('patronlist_id') || undef;
46
my $layout_id = $cgi->param('layout_id') || undef;
46
my $layout_id = $cgi->param('layout_id') || undef;
47
my $layout_back_id = $cgi->param('layout_back_id') || undef;
47
my $layout_back_id = $cgi->param('layout_back_id') || undef;
48
my $template_id = $cgi->param('template_id') || undef;
48
my $template_id = $cgi->param('template_id') || undef;
49
my $start_card = $cgi->param('start_card') || 1;
49
my $start_card = $cgi->param('start_card') || 1;
50
my @borrower_numbers = $cgi->multi_param('borrower_number') if $cgi->param('borrower_number');
50
my @borrower_numbers = $cgi->multi_param('borrower_number');
51
my $output_format = $cgi->param('output_format') || 'pdf';
51
my $output_format = $cgi->param('output_format') || 'pdf';
52
my $referer = $cgi->param('referer') || undef;
52
my $referer = $cgi->param('referer') || undef;
53
53
Lines 123-131 elsif ($op eq 'none') { Link Here
123
    # setup select menus for selecting layout and template for this run...
123
    # setup select menus for selecting layout and template for this run...
124
    $referer = $ENV{'HTTP_REFERER'};
124
    $referer = $ENV{'HTTP_REFERER'};
125
    $referer =~ s/^.*?:\/\/.*?(\/.*)$/$1/m;
125
    $referer =~ s/^.*?:\/\/.*?(\/.*)$/$1/m;
126
    @batch_ids = grep{$_ = {batch_id => $_}} @batch_ids;
126
    @batch_ids = map { {batch_id => $_} } @batch_ids;
127
    @label_ids = grep{$_ = {label_id => $_}} @label_ids;
127
    @label_ids = map { {label_id => $_} } @label_ids;
128
    @borrower_numbers = grep{$_ = {borrower_number => $_}} @borrower_numbers;
128
    @borrower_numbers = map { {borrower_number => $_} } @borrower_numbers;
129
    $templates = get_all_templates( { fields => [qw( template_id template_code ) ], filters => { creator => "Patroncards" } });
129
    $templates = get_all_templates( { fields => [qw( template_id template_code ) ], filters => { creator => "Patroncards" } });
130
    $layouts = get_all_layouts({ fields => [ qw( layout_id layout_name ) ], filters => { creator => "Patroncards" } });
130
    $layouts = get_all_layouts({ fields => [ qw( layout_id layout_name ) ], filters => { creator => "Patroncards" } });
131
    $output_formats = get_output_formats();
131
    $output_formats = get_output_formats();
(-)a/plugins/plugins-upload.pl (-1 / +1 lines)
Lines 48-54 my $uploadfilename = $input->param('uploadfile'); Link Here
48
my $uploadfile     = $input->upload('uploadfile');
48
my $uploadfile     = $input->upload('uploadfile');
49
my $op             = $input->param('op') || q{};
49
my $op             = $input->param('op') || q{};
50
50
51
my ( $total, $handled, @counts, $tempfile, $tfh );
51
my ( $tempfile, $tfh );
52
52
53
my %errors;
53
my %errors;
54
54
(-)a/reports/acquisitions_stats.pl (-1 lines)
Lines 426-432 sub calculate { Link Here
426
    }
426
    }
427
427
428
    my $i = 0;
428
    my $i = 0;
429
    my @totalcol;
430
    my $hilighted = -1;
429
    my $hilighted = -1;
431
430
432
    #Initialization of cell values.....
431
    #Initialization of cell values.....
(-)a/reports/bor_issues_top.pl (-14 / +12 lines)
Lines 41-47 plugin that shows a stats on borrowers Link Here
41
41
42
=cut
42
=cut
43
43
44
$debug and open DEBUG, ">/tmp/bor_issues_top.debug.log";
44
$debug and open my $debugfh, '>', '/tmp/bor_issues_top.debug.log';
45
45
46
my $input = new CGI;
46
my $input = new CGI;
47
my $fullreportname = "reports/bor_issues_top.tt";
47
my $fullreportname = "reports/bor_issues_top.tt";
Lines 104-110 if ($do_it) { Link Here
104
}
104
}
105
105
106
my $dbh = C4::Context->dbh;
106
my $dbh = C4::Context->dbh;
107
my @values;
108
107
109
# here each element returned by map is a hashref, get it?
108
# here each element returned by map is a hashref, get it?
110
my @mime  = ( map { {type =>$_} } (split /[;:]/, 'CSV') ); # FIXME translation
109
my @mime  = ( map { {type =>$_} } (split /[;:]/, 'CSV') ); # FIXME translation
Lines 125-131 sub calculate { Link Here
125
    my ($limit, $column, $filters) = @_;
124
    my ($limit, $column, $filters) = @_;
126
125
127
    my @loopcol;
126
    my @loopcol;
128
    my @loopline;
129
    my @looprow;
127
    my @looprow;
130
    my %globalline;
128
    my %globalline;
131
	my %columns;
129
	my %columns;
Lines 226-250 sub calculate { Link Here
226
        $strsth2 .=" GROUP BY $colfield";
224
        $strsth2 .=" GROUP BY $colfield";
227
        $strsth2 .=" ORDER BY $colorder";
225
        $strsth2 .=" ORDER BY $colorder";
228
226
229
        $debug and print DEBUG "bor_issues_top (old_issues) SQL: $strsth2\n";
227
        $debug and print $debugfh "bor_issues_top (old_issues) SQL: $strsth2\n";
230
        my $sth2 = $dbh->prepare($strsth2);
228
        my $sth2 = $dbh->prepare($strsth2);
231
        $sth2->execute;
229
        $sth2->execute;
232
        print DEBUG "rows: ", $sth2->rows, "\n";
230
        print $debugfh "rows: ", $sth2->rows, "\n";
233
        while (my @row = $sth2->fetchrow) {
231
        while (my @row = $sth2->fetchrow) {
234
			$columns{($row[0] ||'NULL')}++;
232
			$columns{($row[0] ||'NULL')}++;
235
            push @loopcol, { coltitle => $row[0] || 'NULL' };
233
            push @loopcol, { coltitle => $row[0] || 'NULL' };
236
        }
234
        }
237
235
238
		$strsth2 =~ s/old_issues/issues/g;
236
		$strsth2 =~ s/old_issues/issues/g;
239
        $debug and print DEBUG "bor_issues_top (issues) SQL: $strsth2\n";
237
        $debug and print $debugfh "bor_issues_top (issues) SQL: $strsth2\n";
240
		$sth2 = $dbh->prepare($strsth2);
238
		$sth2 = $dbh->prepare($strsth2);
241
        $sth2->execute;
239
        $sth2->execute;
242
        $debug and print DEBUG "rows: ", $sth2->rows, "\n";
240
        $debug and print $debugfh "rows: ", $sth2->rows, "\n";
243
        while (my @row = $sth2->fetchrow) {
241
        while (my @row = $sth2->fetchrow) {
244
			$columns{($row[0] ||'NULL')}++;
242
			$columns{($row[0] ||'NULL')}++;
245
            push @loopcol, { coltitle => $row[0] || 'NULL' };
243
            push @loopcol, { coltitle => $row[0] || 'NULL' };
246
        }
244
        }
247
		$debug and print DEBUG "full array: ", Dumper(\%columns), "\n";
245
		$debug and print $debugfh "full array: ", Dumper(\%columns), "\n";
248
    }else{
246
    }else{
249
        $columns{''} = 1;
247
        $columns{''} = 1;
250
    }
248
    }
Lines 281-290 sub calculate { Link Here
281
    $strcalc .= ",$colfield " if ($colfield);
279
    $strcalc .= ",$colfield " if ($colfield);
282
    $strcalc .= " LIMIT $limit" if ($limit);
280
    $strcalc .= " LIMIT $limit" if ($limit);
283
281
284
    $debug and print DEBUG "(old_issues) SQL : $strcalc\n";
282
    $debug and print $debugfh "(old_issues) SQL : $strcalc\n";
285
    my $dbcalc = $dbh->prepare($strcalc);
283
    my $dbcalc = $dbh->prepare($strcalc);
286
    $dbcalc->execute;
284
    $dbcalc->execute;
287
    $debug and print DEBUG "rows: ", $dbcalc->rows, "\n";
285
    $debug and print $debugfh "rows: ", $dbcalc->rows, "\n";
288
	my %patrons = ();
286
	my %patrons = ();
289
	# DATA STRUCTURE is going to look like this:
287
	# DATA STRUCTURE is going to look like this:
290
	# 	(2253=> {name=>"John Doe",
288
	# 	(2253=> {name=>"John Doe",
Lines 303-312 sub calculate { Link Here
303
	use Data::Dumper;
301
	use Data::Dumper;
304
302
305
	$strcalc =~ s/old_issues/issues/g;
303
	$strcalc =~ s/old_issues/issues/g;
306
    $debug and print DEBUG "(issues) SQL : $strcalc\n";
304
    $debug and print $debugfh "(issues) SQL : $strcalc\n";
307
    $dbcalc = $dbh->prepare($strcalc);
305
    $dbcalc = $dbh->prepare($strcalc);
308
    $dbcalc->execute;
306
    $dbcalc->execute;
309
    $debug and print DEBUG "rows: ", $dbcalc->rows, "\n";
307
    $debug and print $debugfh "rows: ", $dbcalc->rows, "\n";
310
    while (my @data = $dbcalc->fetchrow) {
308
    while (my @data = $dbcalc->fetchrow) {
311
        my ($row, $rank, $id, $col) = @data;
309
        my ($row, $rank, $id, $col) = @data;
312
        $col = "zzEMPTY" if (!defined($col));
310
        $col = "zzEMPTY" if (!defined($col));
Lines 325-331 sub calculate { Link Here
325
			$patrons{$id}->{total} += $count;
323
			$patrons{$id}->{total} += $count;
326
		}
324
		}
327
	}
325
	}
328
    $debug and print DEBUG "\n\npatrons: ", Dumper(\%patrons);
326
    $debug and print $debugfh "\n\npatrons: ", Dumper(\%patrons);
329
    
327
    
330
	my $i = 1;
328
	my $i = 1;
331
	my @cols_in_order = sort keys %columns;		# if you want to order the columns, do something here
329
	my @cols_in_order = sort keys %columns;		# if you want to order the columns, do something here
Lines 371-376 sub calculate { Link Here
371
    return [\%globalline];	# reference to a 1 element array: that element is a hashref
369
    return [\%globalline];	# reference to a 1 element array: that element is a hashref
372
}
370
}
373
371
374
$debug and close DEBUG;
372
$debug and close $debugfh;
375
1;
373
1;
376
__END__
374
__END__
(-)a/reports/borrowers_out.pl (-6 / +1 lines)
Lines 110-120 if ($do_it) { Link Here
110
# Displaying choices
110
# Displaying choices
111
} else {
111
} else {
112
    my $dbh = C4::Context->dbh;
112
    my $dbh = C4::Context->dbh;
113
    my @values;
113
114
    my %labels;
115
    my %select;
116
    my $req;
117
    
118
    my $CGIextChoice = ( 'CSV' ); # FIXME translation
114
    my $CGIextChoice = ( 'CSV' ); # FIXME translation
119
	my $CGIsepChoice = GetDelimiterChoices;
115
	my $CGIsepChoice = GetDelimiterChoices;
120
116
Lines 133-139 sub calculate { Link Here
133
    my @mainloop;
129
    my @mainloop;
134
    my @loopfooter;
130
    my @loopfooter;
135
    my @loopcol;
131
    my @loopcol;
136
    my @loopline;
137
    my @looprow;
132
    my @looprow;
138
    my %globalline;
133
    my %globalline;
139
    my $grantotal =0;
134
    my $grantotal =0;
(-)a/reports/catalogue_out.pl (-2 lines)
Lines 66-73 output_html_with_http_headers $input, $cookie, $template->output; Link Here
66
66
67
sub calculate {
67
sub calculate {
68
    my ( $limit, $column, $filters ) = @_;
68
    my ( $limit, $column, $filters ) = @_;
69
    my @loopline;
70
    my @looprow;
71
    my %globalline;
69
    my %globalline;
72
    my %columns = ();
70
    my %columns = ();
73
    my $dbh     = C4::Context->dbh;
71
    my $dbh     = C4::Context->dbh;
(-)a/reports/catalogue_stats.pl (-5 lines)
Lines 114-124 if ($do_it) { Link Here
114
    }
114
    }
115
} else {
115
} else {
116
	my $dbh = C4::Context->dbh;
116
	my $dbh = C4::Context->dbh;
117
	my @values;
118
	my %labels;
119
	my $count=0;
117
	my $count=0;
120
	my $req;
121
	my @select;
122
118
123
    my $itemtypes = Koha::ItemTypes->search_with_localization;
119
    my $itemtypes = Koha::ItemTypes->search_with_localization;
124
120
Lines 397-403 sub calculate { Link Here
397
    }
393
    }
398
394
399
    my $i = 0;
395
    my $i = 0;
400
    my @totalcol;
401
    my $hilighted = -1;
396
    my $hilighted = -1;
402
397
403
    #Initialization of cell values.....
398
    #Initialization of cell values.....
(-)a/reports/issues_avg_stats.pl (-5 lines)
Lines 389-395 sub calculate { Link Here
389
#	warn "fin des titres colonnes";
389
#	warn "fin des titres colonnes";
390
390
391
    my $i=0;
391
    my $i=0;
392
    my @totalcol;
393
    my $hilighted=-1;
392
    my $hilighted=-1;
394
    
393
    
395
    #Initialization of cell values.....
394
    #Initialization of cell values.....
Lines 442-453 sub calculate { Link Here
442
    $dbcalc->execute;
441
    $dbcalc->execute;
443
# 	warn "filling table";
442
# 	warn "filling table";
444
    my $issues_count=0;
443
    my $issues_count=0;
445
    my $previous_row; 
446
    my $previous_col;
447
    my $loanlength; 
444
    my $loanlength; 
448
    my $err;
449
    my $emptycol;
445
    my $emptycol;
450
    my $weightrow;
451
446
452
    while (my  @data = $dbcalc->fetchrow) {
447
    while (my  @data = $dbcalc->fetchrow) {
453
        my ($row, $col, $issuedate, $returndate, $weight)=@data;
448
        my ($row, $col, $issuedate, $returndate, $weight)=@data;
(-)a/reports/issues_stats.pl (-4 / +1 lines)
Lines 148-156 if ($do_it) { Link Here
148
148
149
149
150
my $dbh = C4::Context->dbh;
150
my $dbh = C4::Context->dbh;
151
my @values;
152
my %labels;
153
my %select;
154
151
155
    # location list
152
    # location list
156
my @locations;
153
my @locations;
Lines 523-529 sub calculate { Link Here
523
        or ( $colsource eq 'items' ) || @$filters[5] || @$filters[6] || @$filters[7] || @$filters[8] || @$filters[9] || @$filters[10] || @$filters[11] || @$filters[12] || @$filters[13] );
520
        or ( $colsource eq 'items' ) || @$filters[5] || @$filters[6] || @$filters[7] || @$filters[8] || @$filters[9] || @$filters[10] || @$filters[11] || @$filters[12] || @$filters[13] );
524
521
525
    $strcalc .= "WHERE 1=1 ";
522
    $strcalc .= "WHERE 1=1 ";
526
    @$filters = map { defined($_) and s/\*/%/g; $_ } @$filters;
523
    @$filters = map { my $f = $_; defined($f) and $f =~ s/\*/%/g; $f } @$filters;
527
    $strcalc .= " AND statistics.datetime >= '" . @$filters[0] . "'"       if ( @$filters[0] );
524
    $strcalc .= " AND statistics.datetime >= '" . @$filters[0] . "'"       if ( @$filters[0] );
528
    $strcalc .= " AND statistics.datetime <= '" . @$filters[1] . " 23:59:59'"       if ( @$filters[1] );
525
    $strcalc .= " AND statistics.datetime <= '" . @$filters[1] . " 23:59:59'"       if ( @$filters[1] );
529
    $strcalc .= " AND borrowers.categorycode LIKE '" . @$filters[2] . "'" if ( @$filters[2] );
526
    $strcalc .= " AND borrowers.categorycode LIKE '" . @$filters[2] . "'" if ( @$filters[2] );
(-)a/reports/reserves_stats.pl (-4 lines)
Lines 126-134 if ($do_it) { Link Here
126
}
126
}
127
127
128
my $dbh = C4::Context->dbh;
128
my $dbh = C4::Context->dbh;
129
my @values;
130
my %labels;
131
my %select;
132
129
133
my $itemtypes = Koha::ItemTypes->search_with_localization;
130
my $itemtypes = Koha::ItemTypes->search_with_localization;
134
131
Lines 260-266 sub calculate { Link Here
260
	push @loopfilter, {crit=>'SQL =', sql=>1, filter=>$strcalc};
257
	push @loopfilter, {crit=>'SQL =', sql=>1, filter=>$strcalc};
261
	@sqlparams=(@sqlparams,@sqlorparams);
258
	@sqlparams=(@sqlparams,@sqlorparams);
262
	$dbcalc->execute(@sqlparams);
259
	$dbcalc->execute(@sqlparams);
263
	my ($emptycol,$emptyrow); 
264
	my $data = $dbcalc->fetchall_hashref([qw(line col)]);
260
	my $data = $dbcalc->fetchall_hashref([qw(line col)]);
265
	my %cols_hash;
261
	my %cols_hash;
266
	foreach my $row (keys %$data){
262
	foreach my $row (keys %$data){
(-)a/rewrite-config.PL (-10 / +12 lines)
Lines 19-24 Link Here
19
# 
19
# 
20
# 2007/11/12	Added DB_PORT and changed other keywords to reflect multi-dbms support.	-fbcit
20
# 2007/11/12	Added DB_PORT and changed other keywords to reflect multi-dbms support.	-fbcit
21
21
22
use Modern::Perl;
22
use Sys::Hostname;
23
use Sys::Hostname;
23
use Socket;
24
use Socket;
24
25
Lines 155-161 $prefix = $ENV{'INSTALL_BASE'} || "/usr"; Link Here
155
);
156
);
156
157
157
# Override configuration from the environment
158
# Override configuration from the environment
158
foreach $key (keys %configuration) {
159
foreach my $key (keys %configuration) {
159
  if (defined($ENV{$key})) {
160
  if (defined($ENV{$key})) {
160
    $configuration{$key} = $ENV{$key};
161
    $configuration{$key} = $ENV{$key};
161
  }
162
  }
Lines 177-197 $file =~ s/__.*?__/exists $configuration{$&} ? $configuration{$&} : $&/seg; Link Here
177
# to make it writable.  Note that stat and chmod
178
# to make it writable.  Note that stat and chmod
178
# (the Perl functions) should work on Win32
179
# (the Perl functions) should work on Win32
179
my $old_perm;
180
my $old_perm;
180
$old_perm = (stat $fname)[2] & 07777;
181
$old_perm = (stat $fname)[2] & oct(7777);
181
my $new_perm = $old_perm | 0200;
182
my $new_perm = $old_perm | oct(200);
182
chmod $new_perm, $fname;
183
chmod $new_perm, $fname;
183
184
184
open(OUTPUT,">$fname") || die "Can't open $fname for write: $!";
185
open(my $output, ">", $fname) || die "Can't open $fname for write: $!";
185
print OUTPUT $file;
186
print $output $file;
186
close(OUTPUT);
187
close($output);
187
188
188
chmod $old_perm, $fname;
189
chmod $old_perm, $fname;
189
190
190
# Idea taken from perlfaq5
191
# Idea taken from perlfaq5
191
sub read_file($) {
192
sub read_file {
192
  local(*INPUT,$/);
193
  local $/;
193
  open(INPUT,$_[0]) || die "Can't open $_[0] for read";
194
  open(my $fh , '<', $_[0]) || die "Can't open $_[0] for read";
194
  my $file = <INPUT>;
195
  my $file = <$fh>;
196
  close $fh;
195
  return $file;
197
  return $file;
196
}
198
}
197
199
(-)a/svc/holds (-1 lines)
Lines 67-73 my $holds_rs = Koha::Holds->search( Link Here
67
    }
67
    }
68
);
68
);
69
69
70
my $borrower;
71
my @holds;
70
my @holds;
72
while ( my $h = $holds_rs->next() ) {
71
while ( my $h = $holds_rs->next() ) {
73
    my $item = $h->item();
72
    my $item = $h->item();
(-)a/t/00-testcritic.t (-30 / +2 lines)
Lines 1-39 Link Here
1
#!/usr/bin/env perl
1
#!/usr/bin/env perl
2
2
3
# This script can be used to run perlcritic on perl files in koha
3
# This script can be used to run perlcritic on perl files in koha
4
# It calls its own custom perlcriticrc
5
# The script is purely optional requiring Test::Perl::Critic to be installed 
4
# The script is purely optional requiring Test::Perl::Critic to be installed 
6
# and the environment variable TEST_QA to be set
5
# and the environment variable TEST_QA to be set
7
# At present only the directories in @dirs will pass the tests in 'Gentle' mode
8
6
9
use Modern::Perl;
7
use Modern::Perl;
10
use File::Spec;
11
use Test::More;
8
use Test::More;
12
use English qw(-no_match_vars);
9
use English qw(-no_match_vars);
13
10
14
my @dirs = qw(
15
    acqui
16
    admin
17
    authorities
18
    basket
19
    catalogue
20
    cataloguing
21
    circ
22
    debian
23
    errors
24
    labels
25
    members
26
    offline_circ
27
    reserve
28
    reviews
29
    rotating_collections
30
    serials
31
    sms
32
    virtualshelves
33
    Koha
34
    C4/SIP
35
);
36
37
if ( not $ENV{TEST_QA} ) {
11
if ( not $ENV{TEST_QA} ) {
38
    my $msg = 'Author test. Set $ENV{TEST_QA} to a true value to run';
12
    my $msg = 'Author test. Set $ENV{TEST_QA} to a true value to run';
39
    plan( skip_all => $msg );
13
    plan( skip_all => $msg );
Lines 46-52 if ( $EVAL_ERROR ) { Link Here
46
    plan( skip_all => $msg );
20
    plan( skip_all => $msg );
47
}
21
}
48
22
49
my $rcfile = File::Spec->catfile( 't', 'perlcriticrc' );
23
Test::Perl::Critic->import( -profile => '.perlcriticrc');
50
Test::Perl::Critic->import( -profile => $rcfile);
24
all_critic_ok('.');
51
all_critic_ok(@dirs);
52
(-)a/t/Languages.t (-1 / +1 lines)
Lines 37-43 $module_context->mock( Link Here
37
    preference => sub {
37
    preference => sub {
38
        my ($self, $pref) = @_;
38
        my ($self, $pref) = @_;
39
        if ($return_undef) {
39
        if ($return_undef) {
40
            return undef;
40
            return;
41
        } elsif ($pref =~ /language/) {
41
        } elsif ($pref =~ /language/) {
42
            return join ',', @languages;
42
            return join ',', @languages;
43
        } else {
43
        } else {
(-)a/t/Prices.t (-2 / +2 lines)
Lines 42-49 fixtures_ok [ Link Here
42
42
43
my $bookseller_module = Test::MockModule->new('Koha::Acquisition::Bookseller');
43
my $bookseller_module = Test::MockModule->new('Koha::Acquisition::Bookseller');
44
44
45
my ( $basketno_0_0,  $basketno_1_1,  $basketno_1_0,  $basketno_0_1 );
45
my ( $basketno_0_0,  $basketno_1_1 );
46
my ( $invoiceid_0_0, $invoiceid_1_1, $invoiceid_1_0, $invoiceid_0_1 );
46
my ( $invoiceid_0_0, $invoiceid_1_1 );
47
my $today;
47
my $today;
48
48
49
for my $currency_format ( qw( US FR ) ) {
49
for my $currency_format ( qw( US FR ) ) {
(-)a/t/SuggestionEngine.t (-1 / +1 lines)
Lines 13-19 BEGIN { Link Here
13
my $plugindir = File::Spec->rel2abs('Koha/SuggestionEngine/Plugin');
13
my $plugindir = File::Spec->rel2abs('Koha/SuggestionEngine/Plugin');
14
14
15
opendir(my $dh, $plugindir);
15
opendir(my $dh, $plugindir);
16
my @installed_plugins = map { ( /\.pm$/ && -f "$plugindir/$_" && s/\.pm$// ) ? "Koha::SuggestionEngine::Plugin::$_" : () } readdir($dh);
16
my @installed_plugins = map { my $p = $_; ( $p =~ /\.pm$/ && -f "$plugindir/$p" && $p =~ s/\.pm$// ) ? "Koha::SuggestionEngine::Plugin::$p" : () } readdir($dh);
17
my @available_plugins = Koha::SuggestionEngine::AvailablePlugins();
17
my @available_plugins = Koha::SuggestionEngine::AvailablePlugins();
18
18
19
foreach my $plugin (@installed_plugins) {
19
foreach my $plugin (@installed_plugins) {
(-)a/t/db_dependent/Accounts.t (-1 lines)
Lines 61-67 $dbh->do(q|DELETE FROM issues|); Link Here
61
$dbh->do(q|DELETE FROM borrowers|);
61
$dbh->do(q|DELETE FROM borrowers|);
62
62
63
my $branchcode = $library->{branchcode};
63
my $branchcode = $library->{branchcode};
64
my $borrower_number;
65
64
66
my $context = new Test::MockModule('C4::Context');
65
my $context = new Test::MockModule('C4::Context');
67
$context->mock( 'userenv', sub {
66
$context->mock( 'userenv', sub {
(-)a/t/db_dependent/Acquisition/OrderFromSubscription.t (-2 / +1 lines)
Lines 31-37 my $bookseller = Koha::Acquisition::Bookseller->new( Link Here
31
)->store;
31
)->store;
32
32
33
my ($biblionumber, $biblioitemnumber) = AddBiblio(MARC::Record->new, '');
33
my ($biblionumber, $biblioitemnumber) = AddBiblio(MARC::Record->new, '');
34
my $budgetid;
35
my $bpid = AddBudgetPeriod({
34
my $bpid = AddBudgetPeriod({
36
    budget_period_startdate   => '2015-01-01',
35
    budget_period_startdate   => '2015-01-01',
37
    budget_period_enddate     => '2015-12-31',
36
    budget_period_enddate     => '2015-12-31',
Lines 56-62 my $subscriptionid = NewSubscription( Link Here
56
);
55
);
57
die unless $subscriptionid;
56
die unless $subscriptionid;
58
57
59
my ($basket, $basketno);
58
my $basketno;
60
ok($basketno = NewBasket($bookseller->id, 1), "NewBasket(  " . $bookseller->id . ", 1  ) returns $basketno");
59
ok($basketno = NewBasket($bookseller->id, 1), "NewBasket(  " . $bookseller->id . ", 1  ) returns $basketno");
61
60
62
my $cost = 42.00;
61
my $cost = 42.00;
(-)a/t/db_dependent/Acquisition/OrderUsers.t (-1 lines)
Lines 41-47 my $budgetid = C4::Budgets::AddBudget( Link Here
41
);
41
);
42
my $budget = C4::Budgets::GetBudget($budgetid);
42
my $budget = C4::Budgets::GetBudget($budgetid);
43
43
44
my @ordernumbers;
45
my ( $biblionumber, $biblioitemnumber ) = C4::Biblio::AddBiblio( MARC::Record->new, '' );
44
my ( $biblionumber, $biblioitemnumber ) = C4::Biblio::AddBiblio( MARC::Record->new, '' );
46
45
47
my $order = Koha::Acquisition::Order->new(
46
my $order = Koha::Acquisition::Order->new(
(-)a/t/db_dependent/AdditionalField.t (-1 lines)
Lines 108-114 use C4::Serials::Frequency; Link Here
108
use C4::Serials::Numberpattern;
108
use C4::Serials::Numberpattern;
109
109
110
my ($biblionumber, $biblioitemnumber) = AddBiblio(MARC::Record->new, '');
110
my ($biblionumber, $biblioitemnumber) = AddBiblio(MARC::Record->new, '');
111
my $budgetid;
112
my $bpid = AddBudgetPeriod({
111
my $bpid = AddBudgetPeriod({
113
    budget_period_startdate => '2015-01-01',
112
    budget_period_startdate => '2015-01-01',
114
    budget_period_enddate   => '2016-01-01',
113
    budget_period_enddate   => '2016-01-01',
(-)a/t/db_dependent/Barcodes.t (-2 / +2 lines)
Lines 149-155 my %thash = ( Link Here
149
    EAN13 => ['0000000695152','892685001928'],
149
    EAN13 => ['0000000695152','892685001928'],
150
);
150
);
151
151
152
my ($obj1,$obj2,$format,$value,$initial,$serial,$re,$next,$previous,$temp);
152
my ($obj1,$obj2,$format,$value,$initial,$serial,$next,$previous,$temp);
153
my @formats = sort keys %thash;
153
my @formats = sort keys %thash;
154
foreach (@formats) {
154
foreach (@formats) {
155
    my $pre = sprintf '(%-12s)', $_;
155
    my $pre = sprintf '(%-12s)', $_;
Lines 214-220 foreach (@formats) { Link Here
214
    }
214
    }
215
}
215
}
216
216
217
foreach $format (@formats) {
217
foreach my $format (@formats) {
218
    my $pre = sprintf '(%-12s)', $format;
218
    my $pre = sprintf '(%-12s)', $format;
219
    foreach my $testval (@{$thash{ $format }}) {
219
    foreach my $testval (@{$thash{ $format }}) {
220
        if ($format eq 'hbyymmincr') {
220
        if ($format eq 'hbyymmincr') {
(-)a/t/db_dependent/Context.t (-2 lines)
Lines 68-75 ok($config = $koha->{config}, 'Getting $koha->{config} '); Link Here
68
# Testing syspref caching
68
# Testing syspref caching
69
use Test::DBIx::Class;
69
use Test::DBIx::Class;
70
70
71
my $history;
72
73
my $schema = Koha::Database->new()->schema();
71
my $schema = Koha::Database->new()->schema();
74
$schema->storage->debug(1);
72
$schema->storage->debug(1);
75
my $trace_read;
73
my $trace_read;
(-)a/t/db_dependent/Hold.t (-1 / +1 lines)
Lines 77-83 my $hold = Koha::Hold->new( Link Here
77
$hold->store();
77
$hold->store();
78
78
79
my $b1_cal = C4::Calendar->new( branchcode => $branches[1]->{branchcode} );
79
my $b1_cal = C4::Calendar->new( branchcode => $branches[1]->{branchcode} );
80
$b1_cal->insert_single_holiday( day => 02, month => 01, year => 2017, title => "Morty Day", description => "Rick" ); #Add a holiday
80
$b1_cal->insert_single_holiday( day => 2, month => 1, year => 2017, title => "Morty Day", description => "Rick" ); #Add a holiday
81
my $today = dt_from_string;
81
my $today = dt_from_string;
82
is( $hold->age(), $today->delta_days( dt_from_string( '2017-01-01' ) )->in_units( 'days')  , "Age of hold is days from reservedate to now if calendar ignored");
82
is( $hold->age(), $today->delta_days( dt_from_string( '2017-01-01' ) )->in_units( 'days')  , "Age of hold is days from reservedate to now if calendar ignored");
83
is( $hold->age(1), $today->delta_days( dt_from_string( '2017-01-01' ) )->in_units( 'days' ) - 1 , "Age of hold is days from reservedate to now minus 1 if calendar used");
83
is( $hold->age(1), $today->delta_days( dt_from_string( '2017-01-01' ) )->in_units( 'days' ) - 1 , "Age of hold is days from reservedate to now minus 1 if calendar used");
(-)a/t/db_dependent/LDAP/test_ldap_add.pl (-1 / +1 lines)
Lines 46-52 sub hashup { Link Here
46
}
46
}
47
47
48
sub recursive_breakdown {
48
sub recursive_breakdown {
49
	my $dse = shift or return undef;
49
	my $dse = shift or return;
50
	if (ref($dse) =~ /HASH/) {
50
	if (ref($dse) =~ /HASH/) {
51
		return join "\n", map {"$_\t=> " . recursive_breakdown($dse->{$_})} keys %$dse;
51
		return join "\n", map {"$_\t=> " . recursive_breakdown($dse->{$_})} keys %$dse;
52
	} elsif (ref($dse) =~ /ARRAY/) {
52
	} elsif (ref($dse) =~ /ARRAY/) {
(-)a/t/db_dependent/Record/Record.t (-16 / +16 lines)
Lines 45-92 $ ./Record_test.pl Link Here
45
ok (1, 'module compiled');
45
ok (1, 'module compiled');
46
46
47
# open some files for testing
47
# open some files for testing
48
open MARC21MARC8,WHEREAMI."/marc21_marc8.dat" or die $!;
48
open my $MARC21MARC8, '<', WHEREAMI."/marc21_marc8.dat" or die $!;
49
my $marc21_marc8; # = scalar (MARC21MARC8);
49
my $marc21_marc8; # = scalar (MARC21MARC8);
50
foreach my $line (<MARC21MARC8>) {
50
foreach my $line (<$MARC21MARC8>) {
51
    $marc21_marc8 .= $line;
51
    $marc21_marc8 .= $line;
52
}
52
}
53
$marc21_marc8 =~ s/\n$//;
53
$marc21_marc8 =~ s/\n$//;
54
close MARC21MARC8;
54
close $MARC21MARC8;
55
55
56
open (MARC21UTF8,"<:utf8",WHEREAMI."/marc21_utf8.dat") or die $!;
56
open (my $MARC21UTF8, '<:encoding(UTF-8)', WHEREAMI."/marc21_utf8.dat") or die $!;
57
my $marc21_utf8;
57
my $marc21_utf8;
58
foreach my $line (<MARC21UTF8>) {
58
foreach my $line (<$MARC21UTF8>) {
59
	$marc21_utf8 .= $line;
59
	$marc21_utf8 .= $line;
60
}
60
}
61
$marc21_utf8 =~ s/\n$//;
61
$marc21_utf8 =~ s/\n$//;
62
close MARC21UTF8;
62
close $MARC21UTF8;
63
63
64
open MARC21MARC8COMBCHARS,WHEREAMI."/marc21_marc8_combining_chars.dat" or die $!;
64
open(my $MARC21MARC8COMBCHARS, '<', WHEREAMI."/marc21_marc8_combining_chars.dat" or die $!;
65
my $marc21_marc8_combining_chars;
65
my $marc21_marc8_combining_chars;
66
foreach my $line(<MARC21MARC8COMBCHARS>) {
66
foreach my $line(<$MARC21MARC8COMBCHARS>) {
67
	$marc21_marc8_combining_chars.=$line;
67
	$marc21_marc8_combining_chars.=$line;
68
}
68
}
69
$marc21_marc8_combining_chars =~ s/\n$//; #FIXME: why is a newline ending up here?
69
$marc21_marc8_combining_chars =~ s/\n$//; #FIXME: why is a newline ending up here?
70
close MARC21MARC8COMBCHARS;
70
close $MARC21MARC8COMBCHARS;
71
71
72
open (MARC21UTF8COMBCHARS,"<:utf8",WHEREAMI."/marc21_utf8_combining_chars.dat") or die $!;
72
open (my $MARC21UTF8COMBCHARS, '<:encoding(UTF-8)', WHEREAMI."/marc21_utf8_combining_chars.dat") or die $!;
73
my $marc21_utf8_combining_chars;
73
my $marc21_utf8_combining_chars;
74
foreach my $line(<MARC21UTF8COMBCHARS>) {
74
foreach my $line(<$MARC21UTF8COMBCHARS>) {
75
	$marc21_utf8_combining_chars.=$line;
75
	$marc21_utf8_combining_chars.=$line;
76
}
76
}
77
close MARC21UTF8COMBCHARS;
77
close $MARC21UTF8COMBCHARS;
78
78
79
open (MARCXMLUTF8,"<:utf8",WHEREAMI."/marcxml_utf8.xml") or die $!;
79
open (my $MARCXMLUTF8, '<:encoding(UTF-8)', WHEREAMI."/marcxml_utf8.xml") or die $!;
80
my $marcxml_utf8;
80
my $marcxml_utf8;
81
foreach my $line (<MARCXMLUTF8>) {
81
foreach my $line (<$MARCXMLUTF8>) {
82
	$marcxml_utf8 .= $line;
82
	$marcxml_utf8 .= $line;
83
}
83
}
84
close MARCXMLUTF8;
84
close $MARCXMLUTF8;
85
85
86
$marcxml_utf8 =~ s/\n//g;
86
$marcxml_utf8 =~ s/\n//g;
87
87
88
## The Tests:
88
## The Tests:
89
my $error; my $marc; my $marcxml; my $dcxml; # some scalars to store values
89
my $error; my $marc; my $marcxml; # some scalars to store values
90
## MARC to MARCXML
90
## MARC to MARCXML
91
print "\n1. Checking conversion of simple ISO-2709 (MARC21) records to MARCXML\n";
91
print "\n1. Checking conversion of simple ISO-2709 (MARC21) records to MARCXML\n";
92
ok (($error,$marcxml) = marc2marcxml($marc21_marc8,'UTF-8','MARC21'), 'marc2marcxml - from MARC-8 to UTF-8 (MARC21)');
92
ok (($error,$marcxml) = marc2marcxml($marc21_marc8,'UTF-8','MARC21'), 'marc2marcxml - from MARC-8 to UTF-8 (MARC21)');
(-)a/t/db_dependent/Search.t (-6 / +6 lines)
Lines 92-97 END { Link Here
92
    cleanup();
92
    cleanup();
93
}
93
}
94
94
95
sub matchesExplodedTerms {
96
    my ($message, $query, @terms) = @_;
97
    my $match = '(' . join ('|', map { " \@attr 1=Subject \@attr 4=1 \"$_\"" } @terms) . "){" . scalar(@terms) . "}";
98
    like($query, qr/$match/, $message);
99
}
100
95
our $QueryStemming = 0;
101
our $QueryStemming = 0;
96
our $QueryAutoTruncate = 0;
102
our $QueryAutoTruncate = 0;
97
our $QueryWeightFields = 0;
103
our $QueryWeightFields = 0;
Lines 700-711 ok(MARC::Record::new_from_xml($results_hashref->{biblioserver}->{RECORDS}->[0],' Link Here
700
    matchesExplodedTerms("Simple search for related subjects and keyword 'history' searches related subjects", $query, 'Arizona', 'United States', 'Maricopa County', 'Navajo County', 'Pima County');
706
    matchesExplodedTerms("Simple search for related subjects and keyword 'history' searches related subjects", $query, 'Arizona', 'United States', 'Maricopa County', 'Navajo County', 'Pima County');
701
    like($query, qr/history/, "Simple search for related subjects and keyword 'history' searches for 'history'");
707
    like($query, qr/history/, "Simple search for related subjects and keyword 'history' searches for 'history'");
702
708
703
    sub matchesExplodedTerms {
704
        my ($message, $query, @terms) = @_;
705
        my $match = '(' . join ('|', map { " \@attr 1=Subject \@attr 4=1 \"$_\"" } @terms) . "){" . scalar(@terms) . "}";
706
        like($query, qr/$match/, $message);
707
    }
708
709
    # authority records
709
    # authority records
710
    use_ok('C4::AuthoritiesMarc');
710
    use_ok('C4::AuthoritiesMarc');
711
    $UseQueryParser = 0;
711
    $UseQueryParser = 0;
(-)a/t/db_dependent/Serials.t (-1 lines)
Lines 49-55 my $bookseller = Koha::Acquisition::Bookseller->new( Link Here
49
49
50
my ($biblionumber, $biblioitemnumber) = AddBiblio(MARC::Record->new, '');
50
my ($biblionumber, $biblioitemnumber) = AddBiblio(MARC::Record->new, '');
51
51
52
my $budgetid;
53
my $bpid = AddBudgetPeriod({
52
my $bpid = AddBudgetPeriod({
54
    budget_period_startdate   => '2015-01-01',
53
    budget_period_startdate   => '2015-01-01',
55
    budget_period_enddate     => '2015-12-31',
54
    budget_period_enddate     => '2015-12-31',
(-)a/t/db_dependent/Serials_2.t (-1 lines)
Lines 39-45 my ( $biblionumber, $biblioitemnumber ) = C4::Biblio::AddBiblio($record, ''); Link Here
39
39
40
my $my_branch = $library1->{branchcode};
40
my $my_branch = $library1->{branchcode};
41
my $another_branch = $library2->{branchcode};
41
my $another_branch = $library2->{branchcode};
42
my $budgetid;
43
my $bpid = AddBudgetPeriod({
42
my $bpid = AddBudgetPeriod({
44
    budget_period_startdate   => '2015-01-01',
43
    budget_period_startdate   => '2015-01-01',
45
    budget_period_enddate     => '2015-12-31',
44
    budget_period_enddate     => '2015-12-31',
(-)a/t/db_dependent/XISBN.t (-1 lines)
Lines 25-31 $dbh->{AutoCommit} = 0; Link Here
25
my $search_module = new Test::MockModule('C4::Search');
25
my $search_module = new Test::MockModule('C4::Search');
26
26
27
$search_module->mock('SimpleSearch', \&Mock_SimpleSearch );
27
$search_module->mock('SimpleSearch', \&Mock_SimpleSearch );
28
my $errors;
29
my $context = C4::Context->new;
28
my $context = C4::Context->new;
30
29
31
my ( $biblionumber_tag, $biblionumber_subfield ) =
30
my ( $biblionumber_tag, $biblionumber_subfield ) =
(-)a/t/db_dependent/www/auth_values_input_www.t (-1 lines)
Lines 57-63 my $dbh = C4::Context->dbh; Link Here
57
$intranet =~ s#/$##;
57
$intranet =~ s#/$##;
58
58
59
my $agent = Test::WWW::Mechanize->new( autocheck => 1 );
59
my $agent = Test::WWW::Mechanize->new( autocheck => 1 );
60
my $jsonresponse;
61
my ($category, $expected_base, $add_form_link_exists, $delete_form_link_exists);
60
my ($category, $expected_base, $add_form_link_exists, $delete_form_link_exists);
62
61
63
# -------------------------------------------------- LOGIN
62
# -------------------------------------------------- LOGIN
(-)a/t/dummy.t (+1 lines)
Lines 1-3 Link Here
1
# Dummy test until Test::Harness or similar
1
# Dummy test until Test::Harness or similar
2
# is used by the other tests to check deps.
2
# is used by the other tests to check deps.
3
use Modern::Perl;
3
print "1..1\nok 1\n";
4
print "1..1\nok 1\n";
(-)a/tags/review.pl (-3 / +3 lines)
Lines 36-42 use C4::Tags qw(get_tags get_approval_rows approval_counts whitelist blacklist i Link Here
36
my $script_name = "/cgi-bin/koha/tags/review.pl";
36
my $script_name = "/cgi-bin/koha/tags/review.pl";
37
my $needed_flags = { tools => 'moderate_tags' };	# FIXME: replace when more specific permission is created.
37
my $needed_flags = { tools => 'moderate_tags' };	# FIXME: replace when more specific permission is created.
38
38
39
sub ajax_auth_cgi ($) {		# returns CGI object
39
sub ajax_auth_cgi {		# returns CGI object
40
	my $needed_flags = shift;
40
	my $needed_flags = shift;
41
    my %cookies = CGI::Cookie->fetch;
41
    my %cookies = CGI::Cookie->fetch;
42
	my $input = CGI->new;
42
	my $input = CGI->new;
Lines 122-129 foreach (keys %$counts) { Link Here
122
	$template->param($_ => $counts->{$_});
122
	$template->param($_ => $counts->{$_});
123
}
123
}
124
124
125
sub pagination_calc ($;$) {
125
sub pagination_calc {
126
	my $query = shift or return undef;	
126
	my $query = shift or return;
127
	my $hardlimit = (@_) ? shift : 100;	# hardcoded, could be another syspref
127
	my $hardlimit = (@_) ? shift : 100;	# hardcoded, could be another syspref
128
	my $pagesize = $query->param('limit' ) || $hardlimit;
128
	my $pagesize = $query->param('limit' ) || $hardlimit;
129
	my $page     = $query->param('page'  ) || 1;
129
	my $page     = $query->param('page'  ) || 1;
(-)a/test/search.pl (+1 lines)
Lines 1-5 Link Here
1
#!/usr/bin/perl -w
1
#!/usr/bin/perl -w
2
2
3
use Modern::Perl;
3
use C4::Search;
4
use C4::Search;
4
5
5
my @SEARCH = (
6
my @SEARCH = (
(-)a/tools/batchMod.pl (-2 / +1 lines)
Lines 81-87 $restrictededition = 0 if ($restrictededition != 0 && C4::Context->IsSuperLibrar Link Here
81
81
82
$template->param(del       => $del);
82
$template->param(del       => $del);
83
83
84
my $itemrecord;
85
my $nextop="";
84
my $nextop="";
86
my @errors; # store errors found while checking data BEFORE saving item.
85
my @errors; # store errors found while checking data BEFORE saving item.
87
my $items_display_hashref;
86
my $items_display_hashref;
Lines 335-341 foreach my $tag (sort keys %{$tagslib}) { Link Here
335
	$subfield_data{marc_lib}   ="<span id=\"error$i\" title=\"".$tagslib->{$tag}->{$subfield}->{lib}."\">".$tagslib->{$tag}->{$subfield}->{lib}."</span>";
334
	$subfield_data{marc_lib}   ="<span id=\"error$i\" title=\"".$tagslib->{$tag}->{$subfield}->{lib}."\">".$tagslib->{$tag}->{$subfield}->{lib}."</span>";
336
	$subfield_data{mandatory}  = $tagslib->{$tag}->{$subfield}->{mandatory};
335
	$subfield_data{mandatory}  = $tagslib->{$tag}->{$subfield}->{mandatory};
337
	$subfield_data{repeatable} = $tagslib->{$tag}->{$subfield}->{repeatable};
336
	$subfield_data{repeatable} = $tagslib->{$tag}->{$subfield}->{repeatable};
338
	my ($x,$value);
337
	my $value;
339
	$value =~ s/"/&quot;/g;
338
	$value =~ s/"/&quot;/g;
340
   if ( !$value && $use_default_values) {
339
   if ( !$value && $use_default_values) {
341
	    $value = $tagslib->{$tag}->{$subfield}->{defaultvalue};
340
	    $value = $tagslib->{$tag}->{$subfield}->{defaultvalue};
(-)a/tools/export.pl (-2 lines)
Lines 88-95 if ( $op eq "export" ) { Link Here
88
    my @biblionumbers      = $query->multi_param("biblionumbers");
88
    my @biblionumbers      = $query->multi_param("biblionumbers");
89
    my @itemnumbers        = $query->multi_param("itemnumbers");
89
    my @itemnumbers        = $query->multi_param("itemnumbers");
90
    my $strip_items_not_from_libraries =  $query->param('strip_items_not_from_libraries');
90
    my $strip_items_not_from_libraries =  $query->param('strip_items_not_from_libraries');
91
    my @sql_params;
92
    my $sql_query;
93
91
94
    my $libraries = Koha::Libraries->search_filtered->unblessed;
92
    my $libraries = Koha::Libraries->search_filtered->unblessed;
95
    my $only_export_items_for_branches = $strip_items_not_from_libraries ? \@branch : undef;
93
    my $only_export_items_for_branches = $strip_items_not_from_libraries ? \@branch : undef;
(-)a/tools/import_borrowers.pl (-3 lines)
Lines 57-63 use Text::CSV; Link Here
57
57
58
use CGI qw ( -utf8 );
58
use CGI qw ( -utf8 );
59
59
60
my ( @errors, @feedback );
61
my $extended = C4::Context->preference('ExtendedPatronAttributes');
60
my $extended = C4::Context->preference('ExtendedPatronAttributes');
62
61
63
my @columnkeys = map { $_ ne 'borrowernumber' ? $_ : () } Koha::Patrons->columns();
62
my @columnkeys = map { $_ ne 'borrowernumber' ? $_ : () } Koha::Patrons->columns();
Lines 65-72 push( @columnkeys, 'patron_attributes' ) if $extended; Link Here
65
64
66
my $input = CGI->new();
65
my $input = CGI->new();
67
66
68
#push @feedback, {feedback=>1, name=>'backend', value=>$csv->backend, backend=>$csv->backend}; #XXX
69
70
my ( $template, $loggedinuser, $cookie ) = get_template_and_user(
67
my ( $template, $loggedinuser, $cookie ) = get_template_and_user(
71
    {
68
    {
72
        template_name   => "tools/import_borrowers.tt",
69
        template_name   => "tools/import_borrowers.tt",
(-)a/tools/letter.pl (-1 / +1 lines)
Lines 188-194 sub add_form { Link Here
188
            code       => $code,
188
            code       => $code,
189
        );
189
        );
190
        my $first_flag_name = 1;
190
        my $first_flag_name = 1;
191
        my ( $lang, @templates );
191
        my $lang;
192
        # The letter name is contained into each mtt row.
192
        # The letter name is contained into each mtt row.
193
        # So we can only sent the first one to the template.
193
        # So we can only sent the first one to the template.
194
        for my $letter ( @$letters ) {
194
        for my $letter ( @$letters ) {
(-)a/tools/modborrowers.pl (-2 / +1 lines)
Lines 64-73 if ( $op eq 'show' ) { Link Here
64
    my $patron_list_id = $input->param('patron_list_id');
64
    my $patron_list_id = $input->param('patron_list_id');
65
    my @borrowers;
65
    my @borrowers;
66
    my @cardnumbers;
66
    my @cardnumbers;
67
    my ( @notfoundcardnumbers, @from_another_group_of_libraries );
67
    my @notfoundcardnumbers;
68
68
69
    # Get cardnumbers from a file or the input area
69
    # Get cardnumbers from a file or the input area
70
    my @contentlist;
71
    if ($filefh) {
70
    if ($filefh) {
72
        while ( my $content = <$filefh> ) {
71
        while ( my $content = <$filefh> ) {
73
            $content =~ s/[\r\n]*$//g;
72
            $content =~ s/[\r\n]*$//g;
(-)a/tools/overduerules.pl (-2 lines)
Lines 216-223 my $letters = C4::Letters::GetLettersAvailableForALibrary( Link Here
216
    }
216
    }
217
);
217
);
218
218
219
my @line_loop;
220
221
my $message_transport_types = C4::Letters::GetMessageTransportTypes();
219
my $message_transport_types = C4::Letters::GetMessageTransportTypes();
222
my ( @first, @second, @third );
220
my ( @first, @second, @third );
223
for my $patron_category (@patron_categories) {
221
for my $patron_category (@patron_categories) {
(-)a/tools/picture-upload.pl (-7 / +7 lines)
Lines 211-217 sub handle_dir { Link Here
211
              if ( $filename =~ m/datalink\.txt/i
211
              if ( $filename =~ m/datalink\.txt/i
212
                || $filename =~ m/idlink\.txt/i );
212
                || $filename =~ m/idlink\.txt/i );
213
        }
213
        }
214
        unless ( open( FILE, $file ) ) {
214
        my $fh;
215
        unless ( open( $fh, '<', $file ) ) {
215
            warn "Opening $dir/$file failed!";
216
            warn "Opening $dir/$file failed!";
216
            $direrrors{'OPNLINK'} = $file;
217
            $direrrors{'OPNLINK'} = $file;
217
            # This error is fatal to the import of this directory contents
218
            # This error is fatal to the import of this directory contents
Lines 219-225 sub handle_dir { Link Here
219
            return \%direrrors;
220
            return \%direrrors;
220
        }
221
        }
221
222
222
        while ( my $line = <FILE> ) {
223
        while ( my $line = <$fh> ) {
223
            $debug and warn "Reading contents of $file";
224
            $debug and warn "Reading contents of $file";
224
            chomp $line;
225
            chomp $line;
225
            $debug and warn "Examining line: $line";
226
            $debug and warn "Examining line: $line";
Lines 239-245 sub handle_dir { Link Here
239
            $source = "$dir/$filename";
240
            $source = "$dir/$filename";
240
            %counts = handle_file( $cardnumber, $source, $template, %counts );
241
            %counts = handle_file( $cardnumber, $source, $template, %counts );
241
        }
242
        }
242
        close FILE;
243
        close $fh;
243
        closedir DIR;
244
        closedir DIR;
244
    }
245
    }
245
    else {
246
    else {
Lines 282-290 sub handle_file { Link Here
282
            return %count;
283
            return %count;
283
        }
284
        }
284
        my ( $srcimage, $image );
285
        my ( $srcimage, $image );
285
        if ( open( IMG, "$source" ) ) {
286
        if ( open( my $fh, '<', $source ) ) {
286
            $srcimage = GD::Image->new(*IMG);
287
            $srcimage = GD::Image->new($fh);
287
            close(IMG);
288
            close($fh);
288
            if ( defined $srcimage ) {
289
            if ( defined $srcimage ) {
289
                my $imgfile;
290
                my $imgfile;
290
                my $mimetype = 'image/png';
291
                my $mimetype = 'image/png';
Lines 335-341 sub handle_file { Link Here
335
                    undef $srcimage; # This object can get big...
336
                    undef $srcimage; # This object can get big...
336
                }
337
                }
337
                $debug and warn "Image is of mimetype $mimetype";
338
                $debug and warn "Image is of mimetype $mimetype";
338
                my $dberror;
339
                if ($mimetype) {
339
                if ($mimetype) {
340
                    my $patron = Koha::Patrons->find({ cardnumber => $cardnumber });
340
                    my $patron = Koha::Patrons->find({ cardnumber => $cardnumber });
341
                    if ( $patron ) {
341
                    if ( $patron ) {
(-)a/tools/upload-cover-image.pl (-3 / +3 lines)
Lines 130-137 if ($fileID) { Link Here
130
                else {
130
                else {
131
                    next;
131
                    next;
132
                }
132
                }
133
                if ( open( FILE, $file ) ) {
133
                if ( open( my $fh, '<', $file ) ) {
134
                    while ( my $line = <FILE> ) {
134
                    while ( my $line = <$fh> ) {
135
                        my $delim =
135
                        my $delim =
136
                            ( $line =~ /\t/ ) ? "\t"
136
                            ( $line =~ /\t/ ) ? "\t"
137
                          : ( $line =~ /,/ )  ? ","
137
                          : ( $line =~ /,/ )  ? ","
Lines 169-175 if ($fileID) { Link Here
169
                            undef $srcimage;
169
                            undef $srcimage;
170
                        }
170
                        }
171
                    }
171
                    }
172
                    close(FILE);
172
                    close($fh);
173
                }
173
                }
174
                else {
174
                else {
175
                    $error = 'OPNLINK';
175
                    $error = 'OPNLINK';
(-)a/xt/author/show-template-structure.pl (-3 / +3 lines)
Lines 56-62 Output is sent to STDOUT. Link Here
56
56
57
scalar(@ARGV) == 1 or die "Usage: $0 template-file\n";
57
scalar(@ARGV) == 1 or die "Usage: $0 template-file\n";
58
my $file = $ARGV[0];
58
my $file = $ARGV[0];
59
open IN, $file or die "Failed to open template file $file: $!\n";
59
open my $fh, '<', $file or die "Failed to open template file $file: $!\n";
60
60
61
my %valid_tmpl_tags = (
61
my %valid_tmpl_tags = (
62
    tmpl_var     => 1,
62
    tmpl_var     => 1,
Lines 87-93 sub emit { Link Here
87
    print "  " x ( $level - 1 ), shift;
87
    print "  " x ( $level - 1 ), shift;
88
}
88
}
89
89
90
while (<IN>) {
90
while (<$fh>) {
91
    $lineno++;
91
    $lineno++;
92
92
93
    # look for TMPL_IF, TMPL_ELSE, TMPL_UNLESS, and TMPL_LOOPs in HTML comments
93
    # look for TMPL_IF, TMPL_ELSE, TMPL_UNLESS, and TMPL_LOOPs in HTML comments
Lines 147-153 while (<IN>) { Link Here
147
    }
147
    }
148
}
148
}
149
149
150
close IN;
150
close $fh;
151
151
152
# anything left in the stack?
152
# anything left in the stack?
153
if (scalar @tag_stack > 0) {
153
if (scalar @tag_stack > 0) {
(-)a/xt/author/translatable-templates.t (-1 / +1 lines)
Lines 69-75 sub test_string_extraction { Link Here
69
69
70
    my $command = "PERL5LIB=\$PERL5LIB:$misc_translator_dir ./tmpl_process3.pl create -i $template_dir -s $po_dir/$module.po -r --pedantic-warnings";
70
    my $command = "PERL5LIB=\$PERL5LIB:$misc_translator_dir ./tmpl_process3.pl create -i $template_dir -s $po_dir/$module.po -r --pedantic-warnings";
71
   
71
   
72
    open (NULL, ">", File::Spec->devnull);
72
    open (NULL, ">", File::Spec->devnull); ## no critic (BarewordFileHandles)
73
    print NULL "foo"; # avoid warning;
73
    print NULL "foo"; # avoid warning;
74
    my $pid = open3(gensym, ">&NULL", \*PH, $command); 
74
    my $pid = open3(gensym, ">&NULL", \*PH, $command); 
75
    my @warnings;
75
    my @warnings;
(-)a/xt/find-license-problems (-2 / +3 lines)
Lines 46-53 sub has_gpl2plus_and_current_fsf_address { Link Here
46
    my $hasv2;
46
    my $hasv2;
47
    my $hasorlater;
47
    my $hasorlater;
48
    my $hasfranklinst;
48
    my $hasfranklinst;
49
    open(FILE, $name) || return 0;
49
    open(my $fh, '<', $name) || return 0;
50
    while (my $line = <FILE>) {
50
    while (my $line = <$fh>) {
51
        $hascopyright = 1 if ($line =~ /Copyright.*\d\d/);
51
        $hascopyright = 1 if ($line =~ /Copyright.*\d\d/);
52
        $hasgpl = 1 if ($line =~ /GNU General Public License/);
52
        $hasgpl = 1 if ($line =~ /GNU General Public License/);
53
        $hasv2 = 1 if ($line =~ /either version 2/);
53
        $hasv2 = 1 if ($line =~ /either version 2/);
Lines 55-60 sub has_gpl2plus_and_current_fsf_address { Link Here
55
                            $line =~ /at your option/);
55
                            $line =~ /at your option/);
56
        $hasfranklinst = 1 if ($line =~ /51 Franklin Street/);
56
        $hasfranklinst = 1 if ($line =~ /51 Franklin Street/);
57
    }
57
    }
58
    close($fh);
58
    return ! $hascopyright ||
59
    return ! $hascopyright ||
59
           ($hasgpl && $hasv2 && $hasorlater && $hasfranklinst);
60
           ($hasgpl && $hasv2 && $hasorlater && $hasfranklinst);
60
}
61
}
(-)a/xt/fix-old-fsf-address (-4 / +4 lines)
Lines 114-132 sub dashcomment { Link Here
114
114
115
sub readfile {
115
sub readfile {
116
    my ($filename) = @_;
116
    my ($filename) = @_;
117
    open(FILE, $filename) || die("Can't open $filename for reading");
117
    open(my $fh, '<', $filename) || die("Can't open $filename for reading");
118
    my @lines;
118
    my @lines;
119
    while (my $line = <FILE>) {
119
    while (my $line = <$fh>) {
120
        push @lines, $line;
120
        push @lines, $line;
121
    }
121
    }
122
    close(FILE);
122
    close($fh);
123
    return join '', @lines;
123
    return join '', @lines;
124
}
124
}
125
125
126
126
127
sub try_to_fix {
127
sub try_to_fix {
128
    my ($data, @patterns) = @_;
128
    my ($data, @patterns) = @_;
129
    return undef;
129
    return;
130
}
130
}
131
131
132
132
(-)a/xt/single_quotes.t (-2 / +1 lines)
Lines 42-48 close $dh; Link Here
42
my @files;
42
my @files;
43
find(
43
find(
44
    sub {
44
    sub {
45
        open my $fh, $_ or die "Could not open $_: $!";
45
        open my $fh, '<', $_ or die "Could not open $_: $!";
46
        my @lines = sort grep /\_\(\'/, <$fh>;
46
        my @lines = sort grep /\_\(\'/, <$fh>;
47
        push @files, { name => "$_", lines => \@lines } if @lines;
47
        push @files, { name => "$_", lines => \@lines } if @lines;
48
    },
48
    },
49
- 

Return to bug 21395