Attachment #79239 for bug #21395

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

Lines 10-12 equivalent_modules = Modern::Perl Link Here

(-)a/t/perlcriticrc (+2 lines)
10		10
11	[TestingAndDebugging::RequireUseWarnings]	11	[TestingAndDebugging::RequireUseWarnings]
12	equivalent_modules = Modern::Perl	12	equivalent_modules = Modern::Perl
		13
		14	[-Modules::RequireBarewordIncludes]

Lines 266-272 sub manualinvoice { Link Here

(-)a/C4/Accounts.pm (-1 lines)
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

Lines 2291-2297 sub GetHistory { Link Here

(-)a/C4/Acquisition.pm (-1 lines)
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;




    my $params = C4::Auth::_get_session_params();
    my $success = CGI::Session->find( $params->{dsn}, sub {delete_cas_session(@_, $ticket)}, $params->{dsn_args} );

    sub delete_cas_session {
        my $session = shift;
        my $ticket = shift;
        if ($session->param('cas_ticket') && $session->param('cas_ticket') eq $ticket ) {
            $session->delete;
            $session->flush;
        }
    }

    print $query->header;
    exit;
}

sub delete_cas_session {
    my $session = shift;
    my $ticket = shift;
    if ($session->param('cas_ticket') && $session->param('cas_ticket') eq $ticket ) {
        $session->delete;
        $session->flush;
    }
}

1;
__END__


Lines 119-125 sub SearchAuthorities { Link Here

(-)a/C4/AuthoritiesMarc.pm (-1 lines)
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;

Lines 19-24 Link Here

(-)a/C4/Barcodes/ValueBuilder.pm (+2 lines)
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




	$width = 4;
}

sub db_max {
	my $self = shift;
	my $query = "SELECT substring_index(barcode,'-',-1) AS chunk,barcode FROM items WHERE barcode LIKE ? ORDER BY chunk DESC LIMIT 1";
		# FIXME: unreasonably expensive query on large datasets (I think removal of group by does this?)

    return substr(output_pref({ dt => dt_from_string, dateformat => 'iso', dateonly => 1 }), 0, 4 ) .'-'. sprintf('%'."$width.$width".'d', 1);
}

sub parse {
	my $self = shift;
    my $barcode = (@_) ? shift : $self->value;
	unless ($barcode =~ /(\d{4}-)(\d+)$/) {    # non-greedy match in first part

	$debug and warn "Barcode '$barcode' parses into: '$1', '$2', ''";
	return ($1,$2,'');  # the third part is in anticipation of barcodes that include checkdigits
}
sub width {
	my $self = shift;
	(@_) and $width = shift;	# hitting the class variable.
	return $width;
}
sub process_head {
	my ($self,$head,$whole,$specific) = @_;
	$specific and return $head;	# if this is built off an existing barcode, just return the head unchanged.
    return substr(output_pref({ dt => dt_from_string, dateformat => 'iso', dateonly => 1 }), 0, 4 ) . '-'; # else get new YYYY-

Lines 2297-2303 sub TransformHtmlToXml { Link Here

(-)a/C4/Biblio.pm (-1 lines)
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;

Lines 551-558 sub Z3950SearchAuth { Link Here

(-)a/C4/Breeding.pm (-2 lines)
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;

Lines 2328-2334 sub _FixOverduesOnReturn { Link Here

(-)a/C4/Circulation.pm (-1 lines)
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

Lines 52-59 my @sort_routines = GetSortRoutineNames(); Link Here

(-)a/C4/ClassSortRoutine.pm (-2 / +2 lines)
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;

Lines 247-253 sub new { Link Here

(-)a/C4/Context.pm (-2 lines)
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;

Lines 17-22 package C4::Creators; Link Here

(-)a/C4/Creators.pm (+2 lines)
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);

Lines 513-519 be passed off as a template parameter and used to build an html table. Link Here

(-)a/C4/Creators/Lib.pm (-1 / +1 lines)
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 = ();




    my $marc_type = C4::Context->preference('marcflavour');
    $marc_type .= 'AUTH' if ($marc_type eq 'UNIMARC' && $record_type eq 'auth');

    open my $fh, '<', $input_file or die "$0: cannot open input file $input_file: $!\n";
    my @marc_records;
    $/ = "\035";
    while (<$fh>) {
        s/^\s+//;
        s/\s+$//;
        next unless $_; # skip if record has only whitespace, as might occur

                "Unexpected charset $charset_guessed, expecting $encoding";
        }
    }
    close $fh;
    return ( \@errors, \@marc_records );
}


    return \@return if !$input_file || !$plugin_class;

    # Read input file
    open my $fh, '<', $input_file or die "$0: cannot open input file $input_file: $!\n";
    $/ = "\035";
    while (<$fh>) {
        s/^\s+//;
        s/\s+$//;
        next unless $_;
        $text .= $_;
    }
    close $fh;

    # Convert to large MARC blob with plugin
    $text = Koha::Plugins::Handler->run({

Lines 271-277 sub checkauth { Link Here

(-)a/C4/InstallAuth.pm (-1 lines)
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

Lines 1-5 Link Here

(-)a/C4/Labels.pm (+2 lines)
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;

Lines 216-222 sub _get_barcode_data { Link Here

(-)a/C4/Labels/Label.pm (-3 / +2 lines)
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,

Lines 315-322 sub _build_languages_arrayref { Link Here

(-)a/C4/Languages.pm (-3 / +1 lines)
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

Lines 314-320 sub SendAlerts { Link Here

(-)a/C4/Letters.pm (-1 lines)
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;

Lines 165-171 sub fetch { Link Here

(-)a/C4/Matcher.pm (-1 / +1 lines)
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'};

Lines 88-94 END_SQL Link Here

(-)a/C4/Members/Messaging.pm (-1 lines)
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'};

Lines 1-5 Link Here

(-)a/C4/Patroncards.pm (+2 lines)
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);




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




        Year => $marc_rec_obj->publication_date,
        Abstract => $abstract,
    };
    my $endnote;
    my $style = new Biblio::EndnoteStyle();
    my $template;
    $template.= "DB - DB\n" if C4::Context->preference("LibraryName");

    }

    # Preprocessing
    eval $preprocess if ($preprocess); ## no critic (StringyEval)

    my $firstpass = 1;
    if ( @$itemnumbers ) {

    }

    # Postprocessing
    eval $postprocess if ($postprocess); ## no critic (StringyEval)

    return $output;
}

        if ( $content =~ m|\[\%.*\%\]| ) {
            my $tt = Template->new();
            my $template = $content;
            my $vars;
            # Replace 00X and 0XX with X or XX
            $content =~ s|fields.00(\d)|fields.$1|g;
            $content =~ s|fields.0(\d{2})|fields.$1|g;

                        # Field processing
                        my $marcfield = $tag->{fieldtag}; # This line fixes a retrocompatibility concern
                                                          # The "processing" could be based on the $marcfield variable.
                        eval $fieldprocessing if ($fieldprocessing); ## no critic (StringyEval)

                        push @loop_values, $value;
                    }

Lines 90-96 C<$record> - a MARC::Record object Link Here

(-)a/C4/Ris.pm (-1 lines)
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);




    my $result = TransformMarcToKoha( $record, '' );
    my $sth;
    my $query;
    my $search;
    my $type;
    my ( $biblionumber, $title );

    # search duplicate on ISBN, easy and fast..
    # ... normalize first

    $offset = 0 if $offset < 0;

    # Initialize variables for the ZOOM connection and results object
    my $zconn;
    my @zconns;
    my @results;
    my $results_hashref = ();

                }

                for ( my $j = $offset ; $j < $times ; $j++ ) {
                    my $records_hash;
                    my $record;

                    ## Check if it's an index scan

Lines 321-330 sub GetFullSubscription { Link Here

(-)a/C4/Serials.pm (-9 / +12 lines)
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

Lines 118-124 sub output { Link Here

(-)a/C4/Templates.pm (-1 / +1 lines)
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;

Lines 863-870 sub get_install_log_values { Link Here

(-)a/Makefile.PL (-3 / +3 lines)
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

Lines 33-39 The Proxy Ticket, needed for check_api_auth, that will try to make the CAS Serve Link Here

(-)a/docs/CAS/CASProxy/examples/koha_webservice.pl (-1 / +1 lines)
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;

Lines 49-57 if ($cgi->param('pgtId')) { Link Here

(-)a/docs/CAS/CASProxy/examples/proxy_cas_callback.pl (-3 / +3 lines)
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";

Lines 54-63 if ($cgi->param('PGTIOU')) { Link Here

(-)a/docs/CAS/CASProxy/examples/proxy_cas_data.pl (-3 / +3 lines)
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 );

Lines 77-84 sub fixshebang{ Link Here

(-)a/fix-perl-path.PL (-2 / +2 lines)
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)

Lines 1-5 Link Here

(-)a/install-CPAN.pl (+2 lines)
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

Lines 17-24 Link Here

(-)a/installer/data/mysql/labels_upgrade.pl (-2 / +1 lines)
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

Lines 17-24 Link Here

(-)a/installer/data/mysql/patroncards_upgrade.pl (-2 / +1 lines)
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




    $table,
    $column,
    $type, $null, $key, $default, $extra,
    $prefitem,          # preference item in systempreferences table
);

my $silent;

                             ],
    );

    foreach my $table ( keys %required_prereq_fields ) {
        print "Check table $table\n" if $debug and not $silent;
        $sth = $dbh->prepare("show columns from $table");
        $sth->execute();

    
    
    # Now add any missing tables
    foreach my $table ( keys %requiretables ) {
        unless ( $existingtables{$table} ) {
        print "Adding $table table...\n" unless $silent;
            my $sth = $dbh->prepare("create table $table $requiretables{$table} ENGINE=InnoDB DEFAULT CHARSET=utf8");

    #---------------------------------
    # Columns
    
    foreach my $table ( keys %requirefields ) {
        print "Check table $table\n" if $debug and not $silent;
        $sth = $dbh->prepare("show columns from $table");
        $sth->execute();

        {
            $types{$column} = $type;
        }    # while
        foreach my $column ( keys %{ $requirefields{$table} } ) {
            print "  Check column $column  [$types{$column}]\n" if $debug and not $silent;
            if ( !$types{$column} ) {
    

        }    # foreach column
    }    # foreach table
    
    foreach my $table ( sort keys %fielddefinitions ) {
        print "Check table $table\n" if $debug;
        $sth = $dbh->prepare("show columns from $table");
        $sth->execute();

        }
    }
    # now drop useless tables
    foreach my $table ( @TableToDelete ) {
        if ( $existingtables{$table} ) {
            print "Dropping unused table $table\n" if $debug and not $silent;
            $dbh->do("drop table $table");

    }
    
    # at last, remove useless fields
    foreach my $table ( keys %uselessfields ) {
        my @fields = split (/,/,$uselessfields{$table});
        my $fields;
        my $exists;
        foreach my $fieldtodrop (@fields) {
            $fieldtodrop =~ s/\t//g;




my $debug = 0;

my (
    $sth,
    $query,
    %existingtables,    # tables already in database
    %types,
    $table,
    $type,
    $type, $null, $key, $default, $extra,
    $prefitem,          # preference item in systempreferences table
);

my $schema = Koha::Database->new()->schema();

        my $rv = $installer->load_sql( $update_dir . $file ) ? 0 : 1;
    } elsif ( $file =~ /\.perl$/ ) {
        my $code = read_file( $update_dir . $file );
        eval $code; ## no critic (StringyEval)
        say "Atomic update generated errors: $@" if $@;
    }
}

Lines 13-21 qx(grep -r "^ *use" $dir \| grep -v "C4\\|strict\\|vars" >/tmp/modulesKoha.log); Link Here

(-)a/installer/externalmodules.pl (-3 / +3 lines)
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#(.)\:\suse\s+([A-Z][^\s;]+)# ){	19	if ( $line=~m#(.)\:\suse\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";

Lines 18-23 Link Here

(-)a/misc/admin/koha-preferences (+1 lines)
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;

Lines 18-24 use C4::Biblio; Link Here

(-)a/misc/batchRepairMissingBiblionumbers.pl (-1 lines)
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();

Lines 7-13 use IO::File; Link Here

(-)a/misc/batchdeletebiblios.pl (-1 / +1 lines)
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	);

Lines 132-137 sub parse_config { Link Here

(-)a/misc/bin/connexion_import_daemon.pl (+1 lines)
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";

Lines 21-28 sub check_sys_pref { Link Here

(-)a/misc/check_sysprefs.pl (-3 / +3 lines)
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();

Lines 21-27 use Getopt::Long; Link Here

(-)a/misc/cronjobs/build_browser_and_cloud.pl (-1 / +1 lines)
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,

Lines 24-30 use Koha::DateUtils; Link Here

(-)a/misc/cronjobs/gather_print_notices.pl (-2 / +1 lines)
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;

Lines 17-24 Link Here

(-)a/misc/cronjobs/holds/cancel_expired_holds.pl (-2 / +1 lines)
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




# In my opinion, this line is safe SQL to have outside the API. --atz
our $bounds_sth = C4::Context->dbh->prepare("SELECT DATE_SUB(CURDATE(), INTERVAL ? DAY)");

sub bounds {
    $bounds_sth->execute(shift);
    return $bounds_sth->fetchrow;
}

    $endrange = $startrange;
}

sub summarize {
    my $arg = shift;    # ref to array
    my $got_items = shift || 0;     # print "count" line for items
    my @report = @$arg or return;
    my $i = 0;
    for my $range (@report) {
        printf "\nRange %s\nDue %3s - %3s days ago (%s to %s), lost => %s\n", ++$i,

Lines 72-79 sub getConf { Link Here

(-)a/misc/cronjobs/rss/rss.pl (-3 / +3 lines)
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

Lines 76-81 if ( defined $infile ) { Link Here

(-)a/misc/cronjobs/thirdparty/TalkingTech_itiva_inbound.pl (+1 lines)
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 );

Lines 69-75 my $result = GetOptions( Link Here

(-)a/misc/cronjobs/update_totalissues.pl (-1 / +1 lines)
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";

Lines 189-195 sub update_database { Link Here

(-)a/misc/devel/populate_db.pl (-1 / +1 lines)
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 {

Lines 16-22 use C4::Context; Link Here

(-)a/misc/exportauth.pl (-3 / +3 lines)
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);

Lines 46-52 my $result = GetOptions( Link Here

(-)a/misc/link_bibs_to_authorities.pl (-1 / +1 lines)
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();

Lines 33-39 use Pod::Usage; Link Here

(-)a/misc/maintenance/cmp_sysprefs.pl (-1 / +1 lines)
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,

Lines 75-81 $query = Link Here

(-)a/misc/maintenance/fix_accountlines_rmdupfines_bug8253.pl (-1 lines)
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 );




}

# output log or STDOUT
my $fh;
if (defined $outfile) {
   open ($fh, '>', $outfile) || die ("Cannot open output file");
} else {
   open($fh, '>&', \*STDOUT) || die ("Couldn't duplicate STDOUT: $!");
}

my $sth1 = $dbh->prepare("SELECT biblionumber, frameworkcode FROM biblio $whereclause");


  if ($modok) {
     $goodcount++;
     print $fh "Touched biblio $biblionumber\n" if (defined $verbose);
  } else {
     $badcount++;
     print $fh "ERROR WITH BIBLIO $biblionumber !!!!\n";
  }

  $totalcount++;

}
close($fh);

# Benchmarking
my $endtime = time();




}

# output log or STDOUT
my $fh;
if (defined $outfile) {
   open ($fh, '>', $outfile) || die ("Cannot open output file");
} else {
   open($fh, '>&', \*STDOUT) || die ("Couldn't duplicate STDOUT: $!");
}

my $sth_fetch = $dbh->prepare("SELECT biblionumber, itemnumber, itemcallnumber FROM items $whereclause");


  if ($modok) {
     $goodcount++;
     print $fh "Touched item $itemnumber\n" if (defined $verbose);
  } else {
     $badcount++;
     print $fh "ERROR WITH ITEM $itemnumber !!!!\n";
  }

  $totalcount++;

}
close($fh);

# Benchmarking
my $endtime = time();

Lines 1-6 Link Here

(-)a/misc/migration_tools/22_to_30/export_Authorities.pl (-3 / +2 lines)
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");

Lines 1-6 Link Here

(-)a/misc/migration_tools/22_to_30/export_Authorities_xml.pl (-3 / +2 lines)
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");

Lines 1-6 Link Here

(-)a/misc/migration_tools/22_to_30/move_marc_to_biblioitems.pl (-2 / +1 lines)
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 {

Lines 13-19 use Time::HiRes qw(gettimeofday); Link Here

(-)a/misc/migration_tools/buildCOUNTRY.pl (-1 / +1 lines)
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,

Lines 66-72 my $starttime = gettimeofday; Link Here

(-)a/misc/migration_tools/buildEDITORS.pl (-1 lines)
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) {

Lines 13-19 use Time::HiRes qw(gettimeofday); Link Here

(-)a/misc/migration_tools/buildLANG.pl (-1 / +1 lines)
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,




my $dbh = C4::Context->dbh;
my $heading_fields=get_heading_fields();

my $idmapfh;
if (defined $idmapfl) {
  open($idmapfh, '>', $idmapfl) or die "cannot open $idmapfl \n";
}

if ((not defined $sourcesubfield) && (not defined $sourcetag)){

			 	if ($sourcetag < "010"){
					if ($record->field($sourcetag)){
					  my $source = $record->field($sourcetag)->data();
					  printf($idmapfh "%s|%s\n",$source,$biblionumber);
					}
			    } else {
					my $source=$record->subfield($sourcetag,$sourcesubfield);
					printf($idmapfh "%s|%s\n",$source,$biblionumber);
			  }
			}
					# create biblio, unless we already have it ( either match or isbn )

Lines 57-63 if ( $errZebraConnection == 10000 ) { Link Here

(-)a/misc/migration_tools/remove_unused_authorities.pl (-1 lines)
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;

Lines 2-8 Link Here

(-)a/misc/perlmodule_rm.pl (-1 / +1 lines)
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

Lines 552-558 sub get_all_langs { Link Here

(-)a/misc/translator/LangInstaller.pm (-1 / +1 lines)
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




sub parenleft  () { '(' }
sub parenright () { ')' }

sub _split_js {
    my ($s0) = @_;
    my @it = ();
    while (length $s0) {


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


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

sub string_canon {
  my $s = shift;
  # Fold all whitespace into single blanks
  $s =~ s/\s+/ /g;

}

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


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

sub _formalize{

                return $self->_parametrize_internal(@parts);
            }
            else {
                return;
            }
        }
        # if cformat mode is off, dont bother parametrizing, just return them as they come

                 push @tail, $3;
                $s0 = $2;
            }
            push @head, _split_js($s0);
            $next->set_js_data(_identify_js_translatables(@head, @tail) );
	    return $next unless @parts;	    
	    $self->{_parser}->unshift_token($next);


# function taken from old version
# used by tmpl_process3
sub parametrize {
    my($fmt_0, $cformat_p, $t, $f) = @_;
    my $it = '';
    if ($cformat_p) {

		    ;
		} elsif (defined $params[$i - 1]) {
		    my $param = $params[$i - 1];
		    warn_normal("$fmt_0: $&: Expected a TMPL_VAR, but found a "
			    . $param->type->to_string . "\n", undef)
			    if $param->type != C4::TmplTokenType::DIRECTIVE;
		    warn_normal("$fmt_0: $&: Unsupported "
				. "field width or precision\n", undef)
			    if defined $width || defined $prec;
		    warn_normal("$fmt_0: $&: Parameter $i not known", undef)
			    unless defined $param;
		    $it .= defined $f? &$f( $param ): $param->string;
		}


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

	    my $i  = $1;
	    $fmt = $';
	    my $anchor = $anchors[$i - 1];
	    warn_normal("$&: Anchor $1 not found for msgid \"$fmt_0\"", undef) #FIXME
		    unless defined $anchor;
	    $it .= $anchor->string;
	} else {


# Other simple functions (These are not methods)

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

sub trim {
    my($s0) = @_;
    my $l0 = length $s0;
    my $s = $s0;

    return wantarray? (substr($s0, 0, $l1), $s, substr($s0, $l0 - $l2)): $s;
}

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

    return "\"$s\"";
}

sub charset_canon {
    my($charset) = @_;
    $charset = uc($charset);
    $charset = "$1-$2" if $charset =~ /^(ISO|UTF)(\d.*)/i;

    "\303\270", "\303\271", "\303\272", "\303\273", "\303\274", "\303\275",
    "\303\276", "\303\277" );

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




use vars qw( $appName $input $input_abbr $pedantic_p $pedantic_tag $quiet);
use vars qw( $warned $erred );

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

sub application_name {
    return $appName;
}

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

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

sub pedantic_p {
    return $pedantic_p;
}

sub construct_warn_prefix {
    my($prefix, $lc) = @_;
    die "construct_warn_prefix called before set_application_name"
	    unless defined $appName;

    return "$appName: $prefix: " . (defined $lc? "$input_abbr: line $lc: ": defined $input_abbr? "$input_abbr: ": '');
}

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

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

sub warn_pedantic {
    my($msg, $lc, $flag) = @_;
    my $prefix = construct_warn_prefix("Warning$pedantic_tag", $lc);
    $msg .= "\n" unless $msg =~ /\n$/s;

    $warned += 1;
}

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

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

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


Lines 1-6 Link Here

(-)a/misc/translator/text-extract.pl (-2 / +1 lines)
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:");





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

sub underline { # for testing only
    my($s) = @_;
    join('', map {/[\0-\37]/? $_: "$_\b$_"} split(//, $s));
}

sub debug_dump { # for testing only
    my($h) = @_;
    print "re_tag_compat is /", TmplTokenizer::re_tag(1), "/\n";
    for (;;) {
	my $s = TmplTokenizer::next_token($h);
    last unless defined $s;
	printf "%s\n", ('-' x 79);
	my($kind, $t, $attr) = ($s->type, $s->string, $s->attributes);

	    printf "Attributes:\n";
	    for my $a (keys %$attr) {
		my($key, $val, $val_orig, $order) = @{$attr->{$a}};
		printf "%s = %dH%s -- %s\n", $a, length $val, underline($val),
		$val_orig;
	    }
	}
    if ($kind == TmplTokenType::TEXT_PARAMETRIZED()) {
	    printf "Form (c-format string):\n";
	    printf "%dH%s\n", length $s->form, underline($s->form);
	    printf "Parameters:\n";
	    my $i = 1;
	    for my $a ($s->parameters) {
		my $t = $a->string;
		printf "%%%d\$s = %dH%s\n", $i, length $t, underline($t);
		$i += 1;
	    }
	}
	if ($s->has_js_data) {
	    printf "JavaScript translatable strings:\n";
	    for my $t (@{$s->js_data}) {
		printf "%dH%s\n", length $t->[3], underline($t->[3]) if $t->[0]; # FIXME
	    }
	}
    }


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

sub text_extract {
    my($h) = @_;
    my %text = ();
    for (;;) {
	my $s = TmplTokenizer::next_token($h);
    last unless defined $s;
	my($kind, $t, $attr) = ($s->type, $s->string, $s->attributes);
    if ($kind == TmplTokenType::TEXT()) {
	    $t = TmplTokenizer::trim($t);
	    $text{$t} = 1 if $t =~ /\S/s;
    } elsif ($kind == TmplTokenType::TAG() && %$attr) {
	    # value [tag=input], meta
	    my $tag = ($t =~ /^<(\S+)/s) ? lc($1) : undef;
	    for my $a ('alt', 'content', 'title', 'value') {
		if ($attr->{$a}) {
		    next if $a eq 'content' && $tag ne 'meta';
		    next if $a eq 'value' && ($tag ne 'input'
			|| (ref $attr->{'type'} && $attr->{'type'}->[1] =~ /^(?:hidden|radio)$/)); # FIXME
		    my($key, $val, $val_orig, $order) = @{$attr->{$a}}; #FIXME
		    $val = TmplTokenizer::trim($val);
		    $text{$val} = 1 if $val =~ /\S/s;
		}
	    }


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

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


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

sub usage_error {
    print STDERR "$_[0]\n" if @_;
    print STDERR "Try `$0 --help' for more information.\n";
    exit(-1);

    'debug-dump-only'	=> \$debug_dump_only_p,
    'pedantic-warnings'	=> sub { $pedantic_p = 1 },
    'help'		=> sub { usage(0) },
) || usage_error();

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

usage_error('Missing mandatory option -f') unless defined $input;






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

sub find_translation {
    my($s) = @_;
    my $key = $s;
    if ($s =~ /\S/s) {

    }
}

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

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

    return $it;
}

sub text_replace {
    my($h, $output) = @_;
    for (;;) {
    my $s = TmplTokenizer::next_token($h);
    last unless defined $s;
    my($kind, $t, $attr) = ($s->type, $s->string, $s->attributes);
    if ($kind eq C4::TmplTokenType::TEXT) {

        for my $t (@{$s->js_data}) {
        # FIXME for this whole block
        if ($t->[0]) {
            printf $output "%s%s%s", $t->[2], find_translation($t->[3]),
                $t->[2];
        } else {
            print $output $t->[1];

            }
        }
    } else {
        warn_normal("$dir: $!", undef);
    }
    return @it;
}

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

sub mkdir_recursive {
    my($dir) = @_;
    local($`, $&, $', $1);
    $dir = $` if $dir ne /^\/+$/ && $dir =~ /\/+$/;

    if (!-d $dir) {
    print STDERR "Making directory $dir...\n" unless $quiet;
    # creates with rwxrwxr-x permissions
    mkdir($dir, 0775) || warn_normal("$dir: $!", undef);
    }
}

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

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


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

sub usage_error {
    for my $msg (split(/\n/, $_[0])) {
    print STDERR "$msg\n";
    }

    'quiet|q'               => \$quiet,
    'pedantic-warnings|pedantic'    => sub { $pedantic_p = 1 },
    'help'              => \&usage,
) || usage_error();

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

# keep the buggy Locale::PO quiet if it says stupid things
$SIG{__WARN__} = sub {

# guess the charsets. HTML::Templates defaults to iso-8859-1
if (defined $href) {
    die "$str_file: PO file is corrupted, or not a PO file\n" unless defined $href->{'""'};
    $charset_out = TmplTokenizer::charset_canon($2) if $href->{'""'}->msgstr =~ /\bcharset=(["']?)([^;\s"'\\]+)\1/;
    $charset_in = $charset_out;
#     for my $msgid (keys %$href) {
#   if ($msgid =~ /\bcharset=(["']?)([^;\s"'\\]+)\1/) {

        next if $id_count == $str_count ||
                $msg->{msgstr} eq '""' ||
                grep { /fuzzy/ } @{$msg->{_flags}};
        warn_normal(
            "unconsistent %s count: ($id_count/$str_count):\n" .
            "  line:   " . $msg->{loaded_line_number} . "\n" .
            "  msgid:  " . $msg->{msgid} . "\n" .
            "  msgstr: " . $msg->{msgstr} . "\n", undef);
    }
}

# set our charset in to UTF-8
if (!defined $charset_in) {
    $charset_in = TmplTokenizer::charset_canon('UTF-8');
    warn "Warning: Can't determine original templates' charset, defaulting to $charset_in\n";
}
# set our charset out to UTF-8
if (!defined $charset_out) {
    $charset_out = TmplTokenizer::charset_canon('UTF-8');
    warn "Warning: Charset Out defaulting to $charset_out\n";
}
my $xgettext = './xgettext.pl'; # actual text extractor script

    # FIXME: msgmerge(1) is a Unix dependency
    # FIXME: need to check the return value
    unless (-f $str_file) {
        open(my $infh, '<', $tmpfile2);
        open(my $outfh, '>', $str_file);
        while (<$infh>) {
        print $outfh;
        print OUTPUT;
        last if /^\n/s;
        }
        close $infh;
        close $outfh;
    }
    $st = system("msgmerge ".($quiet?'-q':'')." -s $str_file $tmpfile2 -o - | msgattrib --no-obsolete -o $str_file");
    } else {
    error_normal("Text extraction failed: $xgettext: $!\n", undef);
    error_additional("Will not run msgmerge\n", undef);
    }
    unlink $tmpfile1 || warn_normal("$tmpfile1: unlink failed: $!\n", undef);
    unlink $tmpfile2 || warn_normal("$tmpfile2: unlink failed: $!\n", undef);

} elsif ($action eq 'update') {
    my($tmph1, $tmpfile1) = tmpnam();

            $st = system("msgmerge ".($quiet?'-q':'')." -s $str_file $tmpfile2 -o - | msgattrib --no-obsolete -o $str_file");
        }
    } else {
        error_normal("Text extraction failed: $xgettext: $!\n", undef);
        error_additional("Will not run msgmerge\n", undef);
    }
    unlink $tmpfile1 || warn_normal("$tmpfile1: unlink failed: $!\n", undef);
    unlink $tmpfile2 || warn_normal("$tmpfile2: unlink failed: $!\n", undef);

} elsif ($action eq 'install') {
    if(!defined($out_dir)) {

    -d $out_dir || die "$out_dir: The directory does not exist\n";

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

    # creates the new tmpl file using the new translation
    for my $input (@in_files) {

            unless substr($input, 0, length($in_dir) + 1) eq "$in_dir/";

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

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




sub text_extract {
    my($h) = @_;
    for (;;) {
        my $s = TmplTokenizer::next_token($h);
        last unless defined $s;
        my($kind, $t, $attr) = ($s->type, $s->string, $s->attributes);
        if ($kind eq C4::TmplTokenType::TEXT) {

                    next if $a eq 'value' && ($tag ne 'input'
                        || (ref $attr->{'type'} && $attr->{'type'}->[1] =~ /^(?:hidden|radio|checkbox)$/)); # FIXME
                    my($key, $val, $val_orig, $order) = @{$attr->{$a}}; #FIXME
                    $val = TmplTokenizer::trim($val);
                    remember( $s, $val ) if $val =~ /\S/s;
                }
            }

sub generate_po_file {
    # We don't emit the Plural-Forms header; it's meaningless for us
    my $pot_charset = (defined $charset_out? $charset_out: 'CHARSET');
    $pot_charset = TmplTokenizer::charset_canon($pot_charset);
    # Time stamps aren't exactly right semantically. I don't know how to fix it.
    my $time = POSIX::strftime('%Y-%m-%d %H:%M%z', localtime(time));
    my $time_pot = $time;

	    $cformat_p = 1 if $token->type == C4::TmplTokenType::TEXT_PARAMETRIZED;
	}
        printf $OUTPUT "#, c-format\n" if $cformat_p;
        printf $OUTPUT "msgid %s\n", TmplTokenizer::quote_po(
            TmplTokenizer::string_canon(
                TmplTokenizer::charset_convert($t, $charset_in, $charset_out)
            )
        );
        printf $OUTPUT "msgstr %s\n\n", (defined $translation{$t}?
		TmplTokenizer::quote_po( $translation{$t} ): "\"\"");
    }


sub convert_translation_file {
    open(my $INPUT, '<', $convert_from) || die "$convert_from: $!\n";
    VerboseWarnings::set_input_file_name($convert_from);
    while (<$INPUT>) {
	chomp;
	my($msgid, $msgstr) = split(/\t/);

	$translation{$msgid} = $msgstr unless $msgstr eq '*****';

	if ($msgid  =~ /\bcharset=(["']?)([^;\s"']+)\1/s) {
	    my $candidate = TmplTokenizer::charset_canon($2);
	    die "Conflicting charsets in msgid: $candidate vs $charset_in\n"
		    if defined $charset_in && $charset_in ne $candidate;
	    $charset_in = $candidate;
	}
	if ($msgstr =~ /\bcharset=(["']?)([^;\s"']+)\1/s) {
	    my $candidate = TmplTokenizer::charset_canon($2);
	    die "Conflicting charsets in msgid: $candidate vs $charset_out\n"
		    if defined $charset_out && $charset_out ne $candidate;
	    $charset_out = $candidate;

    }
    # The following assumption is correct; that's what HTML::Template assumes
    if (!defined $charset_in) {
	$charset_in = $charset_out = TmplTokenizer::charset_canon('utf-8');
	warn "Warning: Can't determine original templates' charset, defaulting to $charset_in\n";
    }
}

    'help'				=> sub { usage(0) },
) || usage_error;

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

usage_error('Missing mandatory option -f')
	unless defined $files_from || defined $convert_from;

	my $input = /^\//? $_: "$directory/$_";
	my $h = TmplTokenizer->new( $input );
	$h->set_allow_cformat( 1 );
	VerboseWarnings::set_input_file_name($input);
	print STDERR "$0: Processing file \"$input\"\n" if $verbose_p;
	text_extract( $h );
    }

Lines 152-158 if (C4::Context->preference("RequestOnOpac")) { Link Here

(-)a/opac/opac-MARCdetail.pl (-1 lines)
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++ ) {

Lines 32-38 my $query = new CGI; Link Here

(-)a/opac/opac-alert-subscribe.pl (-1 lines)
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';

Lines 56-62 if ( $op eq "do_search" ) { Link Here

(-)a/opac/opac-authorities-home.pl (-1 lines)
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(

Lines 109-115 if ($show_marc) { Link Here

(-)a/opac/opac-authoritiesdetail.pl (-1 lines)
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();

Lines 89-95 foreach my $biblionumber ( @bibs ) { Link Here

(-)a/opac/opac-basket.pl (-1 lines)
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';




# Define some global variables
my ($error,$query,$simple_query,$query_cgi,$query_desc,$limit,$limit_cgi,$limit_desc,$query_type);

my @results;

my $suppress = 0;
if (C4::Context->preference('OpacSuppression')) {
    # OPAC suppression by IP address

## II. DO THE SEARCH AND GET THE RESULTS
my $total = 0; # the total results for the whole set
my $facets; # this object stores the faceted results that display on the left-hand of the results page
my @results_array;
my $results_hashref;
my @coins;

if ($tag) {
    $query_cgi = "tag=" .$tag . "&" . $query_cgi;

    # FIXME: can add support for other targets as needed here
    $template->param(           outer_sup_results_loop => \@sup_results_array);
} #/end of the for loop
#$template->param(FEDERATED_RESULTS => \@results_array);

for my $facet ( @$facets ) {
    for my $entry ( @{ $facet->{facets} } ) {

Lines 34-41 my $dbh = C4::Context->dbh; Link Here

(-)a/opac/opac-serial-issues.pl (-2 lines)
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');

Lines 85-91 my $reviews = Koha::Reviews->search( Link Here

(-)a/opac/opac-showreviews.pl (-1 lines)
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 );




                                                                     flagsrequired   => { tools => 'label_creator' },
                                                                     debug           => 1,
                                                                     });
my $batch_id    = $cgi->param('batch_id') || undef;
my $template_id = $cgi->param('template_id') || undef;
my $layout_id   = $cgi->param('layout_id') || undef;
my $layout_back_id   = $cgi->param('layout_back_id') || undef;
my $start_card = $cgi->param('start_card') || 1;
my @label_ids   = $cgi->multi_param('label_id');
my @borrower_numbers  = $cgi->multi_param('borrower_number');
my $patronlist_id = $cgi->param('patronlist_id');

my $items = undef; # items = cards

my $batch = C4::Patroncards::Batch->retrieve(batch_id => $batch_id);
my $pc_template = C4::Patroncards::Template->retrieve(template_id => $template_id, profile_id => 1);
my $layout = C4::Patroncards::Layout->retrieve(layout_id => $layout_id);
my $layout_back = $layout_back_id ? C4::Patroncards::Layout->retrieve(layout_id => $layout_back_id) : undef;

$| = 1;


}

my $layout_xml = XMLin($layout->get_attr('layout_xml'), ForceArray => 1);
my $layout_back_xml = defined $layout_back ? XMLin($layout_back->get_attr('layout_xml'), ForceArray => 1) : undef;

if ($layout_xml->{'page_side'} eq 'B') { # rearrange items on backside of page to swap columns
    my $even = 1;

Lines 28-34 my $file_name = $cgi->param('uploadfile') \|\| ''; Link Here

(-)a/patroncards/image-manage.pl (-1 / +1 lines)
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




);

my $op = $cgi->param('op') || 'none';
my @label_ids = $cgi->multi_param('label_id');   # this will handle individual card printing; we use label_id to maintain consistency with the column names in the creator_batches table
my @batch_ids = $cgi->multi_param('batch_id');
my $patronlist_id = $cgi->param('patronlist_id') || undef;
my $layout_id = $cgi->param('layout_id') || undef;
my $layout_back_id = $cgi->param('layout_back_id') || undef;
my $template_id = $cgi->param('template_id') || undef;
my $start_card = $cgi->param('start_card') || 1;
my @borrower_numbers = $cgi->multi_param('borrower_number');
my $output_format = $cgi->param('output_format') || 'pdf';
my $referer = $cgi->param('referer') || undef;


    # setup select menus for selecting layout and template for this run...
    $referer = $ENV{'HTTP_REFERER'};
    $referer =~ s/^.*?:\/\/.*?(\/.*)$/$1/m;
    @batch_ids = map { {batch_id => $_} } @batch_ids;
    @label_ids = map { {label_id => $_} } @label_ids;
    @borrower_numbers = map { {borrower_number => $_} } @borrower_numbers;
    $templates = get_all_templates( { fields => [qw( template_id template_code ) ], filters => { creator => "Patroncards" } });
    $layouts = get_all_layouts({ fields => [ qw( layout_id layout_name ) ], filters => { creator => "Patroncards" } });
    $output_formats = get_output_formats();

Lines 48-54 my $uploadfilename = $input->param('uploadfile'); Link Here

(-)a/plugins/plugins-upload.pl (-1 / +1 lines)
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

Lines 426-432 sub calculate { Link Here

(-)a/reports/acquisitions_stats.pl (-1 lines)
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.....





=cut

$debug and open my $debugfh, '>', '/tmp/bor_issues_top.debug.log';

my $input = new CGI;
my $fullreportname = "reports/bor_issues_top.tt";

}

my $dbh = C4::Context->dbh;
my @values;

# here each element returned by map is a hashref, get it?
my @mime  = ( map { {type =>$_} } (split /[;:]/, 'CSV') ); # FIXME translation

    my ($limit, $column, $filters) = @_;

    my @loopcol;
    my @loopline;
    my @looprow;
    my %globalline;
	my %columns;

        $strsth2 .=" GROUP BY $colfield";
        $strsth2 .=" ORDER BY $colorder";

        $debug and print $debugfh "bor_issues_top (old_issues) SQL: $strsth2\n";
        my $sth2 = $dbh->prepare($strsth2);
        $sth2->execute;
        print $debugfh "rows: ", $sth2->rows, "\n";
        while (my @row = $sth2->fetchrow) {
			$columns{($row[0] ||'NULL')}++;
            push @loopcol, { coltitle => $row[0] || 'NULL' };
        }

		$strsth2 =~ s/old_issues/issues/g;
        $debug and print $debugfh "bor_issues_top (issues) SQL: $strsth2\n";
		$sth2 = $dbh->prepare($strsth2);
        $sth2->execute;
        $debug and print $debugfh "rows: ", $sth2->rows, "\n";
        while (my @row = $sth2->fetchrow) {
			$columns{($row[0] ||'NULL')}++;
            push @loopcol, { coltitle => $row[0] || 'NULL' };
        }
		$debug and print $debugfh "full array: ", Dumper(\%columns), "\n";
    }else{
        $columns{''} = 1;
    }

    $strcalc .= ",$colfield " if ($colfield);
    $strcalc .= " LIMIT $limit" if ($limit);

    $debug and print $debugfh "(old_issues) SQL : $strcalc\n";
    my $dbcalc = $dbh->prepare($strcalc);
    $dbcalc->execute;
    $debug and print $debugfh "rows: ", $dbcalc->rows, "\n";
	my %patrons = ();
	# DATA STRUCTURE is going to look like this:
	# 	(2253=> {name=>"John Doe",

	use Data::Dumper;

	$strcalc =~ s/old_issues/issues/g;
    $debug and print $debugfh "(issues) SQL : $strcalc\n";
    $dbcalc = $dbh->prepare($strcalc);
    $dbcalc->execute;
    $debug and print $debugfh "rows: ", $dbcalc->rows, "\n";
    while (my @data = $dbcalc->fetchrow) {
        my ($row, $rank, $id, $col) = @data;
        $col = "zzEMPTY" if (!defined($col));

			$patrons{$id}->{total} += $count;
		}
	}
    $debug and print $debugfh "\n\npatrons: ", Dumper(\%patrons);
    
	my $i = 1;
	my @cols_in_order = sort keys %columns;		# if you want to order the columns, do something here

    return [\%globalline];	# reference to a 1 element array: that element is a hashref
}

$debug and close $debugfh;
1;
__END__




# Displaying choices
} else {
    my $dbh = C4::Context->dbh;

    my %labels;
    my %select;
    my $req;
    
    my $CGIextChoice = ( 'CSV' ); # FIXME translation
	my $CGIsepChoice = GetDelimiterChoices;


    my @mainloop;
    my @loopfooter;
    my @loopcol;
    my @loopline;
    my @looprow;
    my %globalline;
    my $grantotal =0;

Lines 66-73 output_html_with_http_headers $input, $cookie, $template->output; Link Here

(-)a/reports/catalogue_out.pl (-2 lines)
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;




    }
} else {
	my $dbh = C4::Context->dbh;
	my @values;
	my %labels;
	my $count=0;
	my $req;
	my @select;

    my $itemtypes = Koha::ItemTypes->search_with_localization;


    }

    my $i = 0;
    my @totalcol;
    my $hilighted = -1;

    #Initialization of cell values.....




#	warn "fin des titres colonnes";

    my $i=0;
    my @totalcol;
    my $hilighted=-1;
    
    #Initialization of cell values.....

    $dbcalc->execute;
# 	warn "filling table";
    my $issues_count=0;
    my $previous_row; 
    my $previous_col;
    my $loanlength; 
    my $err;
    my $emptycol;
    my $weightrow;

    while (my  @data = $dbcalc->fetchrow) {
        my ($row, $col, $issuedate, $returndate, $weight)=@data;






my $dbh = C4::Context->dbh;
my @values;
my %labels;
my %select;

    # location list
my @locations;

        or ( $colsource eq 'items' ) || @$filters[5] || @$filters[6] || @$filters[7] || @$filters[8] || @$filters[9] || @$filters[10] || @$filters[11] || @$filters[12] || @$filters[13] );

    $strcalc .= "WHERE 1=1 ";
    @$filters = map { my $f = $_; defined($f) and $f =~ s/\*/%/g; $f } @$filters;
    $strcalc .= " AND statistics.datetime >= '" . @$filters[0] . "'"       if ( @$filters[0] );
    $strcalc .= " AND statistics.datetime <= '" . @$filters[1] . " 23:59:59'"       if ( @$filters[1] );
    $strcalc .= " AND borrowers.categorycode LIKE '" . @$filters[2] . "'" if ( @$filters[2] );




}

my $dbh = C4::Context->dbh;
my @values;
my %labels;
my %select;

my $itemtypes = Koha::ItemTypes->search_with_localization;


	push @loopfilter, {crit=>'SQL =', sql=>1, filter=>$strcalc};
	@sqlparams=(@sqlparams,@sqlorparams);
	$dbcalc->execute(@sqlparams);
	my ($emptycol,$emptyrow); 
	my $data = $dbcalc->fetchall_hashref([qw(line col)]);
	my %cols_hash;
	foreach my $row (keys %$data){




# 
# 2007/11/12	Added DB_PORT and changed other keywords to reflect multi-dbms support.	-fbcit

use Modern::Perl;
use Sys::Hostname;
use Socket;


);

# Override configuration from the environment
foreach my $key (keys %configuration) {
  if (defined($ENV{$key})) {
    $configuration{$key} = $ENV{$key};
  }

# to make it writable.  Note that stat and chmod
# (the Perl functions) should work on Win32
my $old_perm;
$old_perm = (stat $fname)[2] & oct(7777);
my $new_perm = $old_perm | oct(200);
chmod $new_perm, $fname;

open(my $output, ">", $fname) || die "Can't open $fname for write: $!";
print $output $file;
close($output);

chmod $old_perm, $fname;

# Idea taken from perlfaq5
sub read_file {
  local $/;
  open(my $fh , '<', $_[0]) || die "Can't open $_[0] for read";
  my $file = <$fh>;
  close $fh;
  return $file;
}


Lines 67-73 my $holds_rs = Koha::Holds->search( Link Here

(-)a/svc/holds (-1 lines)
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();




#!/usr/bin/env perl

# This script can be used to run perlcritic on perl files in koha
# It calls its own custom perlcriticrc
# The script is purely optional requiring Test::Perl::Critic to be installed 
# and the environment variable TEST_QA to be set
# At present only the directories in @dirs will pass the tests in 'Gentle' mode

use Modern::Perl;
use File::Spec;
use Test::More;
use English qw(-no_match_vars);

my @dirs = qw(
    acqui
    admin
    authorities
    basket
    catalogue
    cataloguing
    circ
    debian
    errors
    labels
    members
    offline_circ
    reserve
    reviews
    rotating_collections
    serials
    sms
    virtualshelves
    Koha
    C4/SIP
);

if ( not $ENV{TEST_QA} ) {
    my $msg = 'Author test. Set $ENV{TEST_QA} to a true value to run';
    plan( skip_all => $msg );

    plan( skip_all => $msg );
}

Test::Perl::Critic->import( -profile => '.perlcriticrc');
all_critic_ok('.');
all_critic_ok(@dirs);


Lines 37-43 $module_context->mock( Link Here

(-)a/t/Languages.t (-1 / +1 lines)
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 {

Lines 42-49 fixtures_ok [ Link Here

(-)a/t/Prices.t (-2 / +2 lines)
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 ) ) {

Lines 13-19 BEGIN { Link Here

(-)a/t/SuggestionEngine.t (-1 / +1 lines)
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) {

Lines 61-67 $dbh->do(q\|DELETE FROM issues\|); Link Here

(-)a/t/db_dependent/Accounts.t (-1 lines)
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 {

Lines 31-37 my $bookseller = Koha::Acquisition::Bookseller->new( Link Here

(-)a/t/db_dependent/Acquisition/OrderFromSubscription.t (-2 / +1 lines)
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;

Lines 41-47 my $budgetid = C4::Budgets::AddBudget( Link Here

(-)a/t/db_dependent/Acquisition/OrderUsers.t (-1 lines)
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(

Lines 108-114 use C4::Serials::Frequency; Link Here

(-)a/t/db_dependent/AdditionalField.t (-1 lines)
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',

Lines 149-155 my %thash = ( Link Here

(-)a/t/db_dependent/Barcodes.t (-2 / +2 lines)
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') {

Lines 68-75 ok($config = $koha->{config}, 'Getting $koha->{config} '); Link Here

(-)a/t/db_dependent/Context.t (-2 lines)
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;

Lines 77-83 my $hold = Koha::Hold->new( Link Here

(-)a/t/db_dependent/Hold.t (-1 / +1 lines)
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");

Lines 46-52 sub hashup { Link Here

(-)a/t/db_dependent/LDAP/test_ldap_add.pl (-1 / +1 lines)
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/) {




ok (1, 'module compiled');

# open some files for testing
open my $MARC21MARC8, '<', WHEREAMI."/marc21_marc8.dat" or die $!;
my $marc21_marc8; # = scalar (MARC21MARC8);
foreach my $line (<$MARC21MARC8>) {
    $marc21_marc8 .= $line;
}
$marc21_marc8 =~ s/\n$//;
close $MARC21MARC8;

open (my $MARC21UTF8, '<:encoding(UTF-8)', WHEREAMI."/marc21_utf8.dat") or die $!;
my $marc21_utf8;
foreach my $line (<$MARC21UTF8>) {
	$marc21_utf8 .= $line;
}
$marc21_utf8 =~ s/\n$//;
close $MARC21UTF8;

open(my $MARC21MARC8COMBCHARS, '<', WHEREAMI."/marc21_marc8_combining_chars.dat" or die $!;
my $marc21_marc8_combining_chars;
foreach my $line(<$MARC21MARC8COMBCHARS>) {
	$marc21_marc8_combining_chars.=$line;
}
$marc21_marc8_combining_chars =~ s/\n$//; #FIXME: why is a newline ending up here?
close $MARC21MARC8COMBCHARS;

open (my $MARC21UTF8COMBCHARS, '<:encoding(UTF-8)', WHEREAMI."/marc21_utf8_combining_chars.dat") or die $!;
my $marc21_utf8_combining_chars;
foreach my $line(<$MARC21UTF8COMBCHARS>) {
	$marc21_utf8_combining_chars.=$line;
}
close $MARC21UTF8COMBCHARS;

open (my $MARCXMLUTF8, '<:encoding(UTF-8)', WHEREAMI."/marcxml_utf8.xml") or die $!;
my $marcxml_utf8;
foreach my $line (<$MARCXMLUTF8>) {
	$marcxml_utf8 .= $line;
}
close $MARCXMLUTF8;

$marcxml_utf8 =~ s/\n//g;

## The Tests:
my $error; my $marc; my $marcxml; # some scalars to store values
## MARC to MARCXML
print "\n1. Checking conversion of simple ISO-2709 (MARC21) records to MARCXML\n";
ok (($error,$marcxml) = marc2marcxml($marc21_marc8,'UTF-8','MARC21'), 'marc2marcxml - from MARC-8 to UTF-8 (MARC21)');




    cleanup();
}

sub matchesExplodedTerms {
    my ($message, $query, @terms) = @_;
    my $match = '(' . join ('|', map { " \@attr 1=Subject \@attr 4=1 \"$_\"" } @terms) . "){" . scalar(@terms) . "}";
    like($query, qr/$match/, $message);
}

our $QueryStemming = 0;
our $QueryAutoTruncate = 0;
our $QueryWeightFields = 0;

    matchesExplodedTerms("Simple search for related subjects and keyword 'history' searches related subjects", $query, 'Arizona', 'United States', 'Maricopa County', 'Navajo County', 'Pima County');
    like($query, qr/history/, "Simple search for related subjects and keyword 'history' searches for 'history'");

    sub matchesExplodedTerms {
        my ($message, $query, @terms) = @_;
        my $match = '(' . join ('|', map { " \@attr 1=Subject \@attr 4=1 \"$_\"" } @terms) . "){" . scalar(@terms) . "}";
        like($query, qr/$match/, $message);
    }

    # authority records
    use_ok('C4::AuthoritiesMarc');
    $UseQueryParser = 0;

Lines 49-55 my $bookseller = Koha::Acquisition::Bookseller->new( Link Here

(-)a/t/db_dependent/Serials.t (-1 lines)
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',

Lines 39-45 my ( $biblionumber, $biblioitemnumber ) = C4::Biblio::AddBiblio($record, ''); Link Here

(-)a/t/db_dependent/Serials_2.t (-1 lines)
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',

Lines 25-31 $dbh->{AutoCommit} = 0; Link Here

(-)a/t/db_dependent/XISBN.t (-1 lines)
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 ) =

Lines 57-63 my $dbh = C4::Context->dbh; Link Here

(-)a/t/db_dependent/www/auth_values_input_www.t (-1 lines)
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

Lines 1-3 Link Here

(-)a/t/dummy.t (+1 lines)
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";

Lines 36-42 use C4::Tags qw(get_tags get_approval_rows approval_counts whitelist blacklist i Link Here

(-)a/tags/review.pl (-3 / +3 lines)
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;

Lines 1-5 Link Here

(-)a/test/search.pl (+1 lines)
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 = (

Lines 81-87 $restrictededition = 0 if ($restrictededition != 0 && C4::Context->IsSuperLibrar Link Here

(-)a/tools/batchMod.pl (-2 / +1 lines)
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/"/"/g;	338	$value =~ s/"/"/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};

Lines 88-95 if ( $op eq "export" ) { Link Here

(-)a/tools/export.pl (-2 lines)
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;

Lines 57-63 use Text::CSV; Link Here

(-)a/tools/import_borrowers.pl (-3 lines)
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",

Lines 188-194 sub add_form { Link Here

(-)a/tools/letter.pl (-1 / +1 lines)
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 ) {

Lines 64-73 if ( $op eq 'show' ) { Link Here

(-)a/tools/modborrowers.pl (-2 / +1 lines)
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;

Lines 216-223 my $letters = C4::Letters::GetLettersAvailableForALibrary( Link Here

(-)a/tools/overduerules.pl (-2 lines)
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) {




              if ( $filename =~ m/datalink\.txt/i
                || $filename =~ m/idlink\.txt/i );
        }
        my $fh;
        unless ( open( $fh, '<', $file ) ) {
            warn "Opening $dir/$file failed!";
            $direrrors{'OPNLINK'} = $file;
            # This error is fatal to the import of this directory contents

            return \%direrrors;
        }

        while ( my $line = <$fh> ) {
            $debug and warn "Reading contents of $file";
            chomp $line;
            $debug and warn "Examining line: $line";

            $source = "$dir/$filename";
            %counts = handle_file( $cardnumber, $source, $template, %counts );
        }
        close $fh;
        closedir DIR;
    }
    else {

            return %count;
        }
        my ( $srcimage, $image );
        if ( open( my $fh, '<', $source ) ) {
            $srcimage = GD::Image->new($fh);
            close($fh);
            if ( defined $srcimage ) {
                my $imgfile;
                my $mimetype = 'image/png';

                    undef $srcimage; # This object can get big...
                }
                $debug and warn "Image is of mimetype $mimetype";
                my $dberror;
                if ($mimetype) {
                    my $patron = Koha::Patrons->find({ cardnumber => $cardnumber });
                    if ( $patron ) {

Lines 130-137 if ($fileID) { Link Here

(-)a/tools/upload-cover-image.pl (-3 / +3 lines)
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';





scalar(@ARGV) == 1 or die "Usage: $0 template-file\n";
my $file = $ARGV[0];
open my $fh, '<', $file or die "Failed to open template file $file: $!\n";

my %valid_tmpl_tags = (
    tmpl_var     => 1,

    print "  " x ( $level - 1 ), shift;
}

while (<$fh>) {
    $lineno++;

    # look for TMPL_IF, TMPL_ELSE, TMPL_UNLESS, and TMPL_LOOPs in HTML comments

    }
}

close $fh;

# anything left in the stack?
if (scalar @tag_stack > 0) {

Lines 69-75 sub test_string_extraction { Link Here

(-)a/xt/author/translatable-templates.t (-1 / +1 lines)
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;

Lines 46-53 sub has_gpl2plus_and_current_fsf_address { Link Here

(-)a/xt/find-license-problems (-2 / +3 lines)
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	}





sub readfile {
    my ($filename) = @_;
    open(my $fh, '<', $filename) || die("Can't open $filename for reading");
    my @lines;
    while (my $line = <$fh>) {
        push @lines, $line;
    }
    close($fh);
    return join '', @lines;
}


sub try_to_fix {
    my ($data, @patterns) = @_;
    return;
}



Lines 42-48 close $dh; Link Here

(-)a/xt/single_quotes.t (-2 / +1 lines)
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

Lines 1503-1512 sub RecordsFromISO2709File { Link Here

(-)a/C4/ImportBatch.pm (-6 / +6 lines)
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({

Lines 377-383 sub marc2endnote { Link Here

(-)a/C4/Record.pm (-5 / +3 lines)
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	}

Lines 36-42 my ( Link Here

(-)a/installer/data/mysql/update22to30.pl (-9 / +7 lines)
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;

Lines 257-275 sub logout_if_required { Link Here

(-)a/C4/Auth_with_cas.pm (-9 / +9 lines)
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

Lines 36-42 BEGIN { Link Here

(-)a/C4/Barcodes/annual.pm (-4 / +4 lines)
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-

Lines 227-237 sub draw_text { Link Here

(-)a/C4/Patroncards/Patroncard.pm (-3 / +5 lines)
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	}

Lines 88-96 sub FindDuplicate { Link Here

(-)a/C4/Search.pm (-5 lines)
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

Lines 54-67 use File::Slurp; Link Here

(-)a/installer/data/mysql/updatedatabase.pl (-7 / +3 lines)
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	}

Lines 233-239 cronlogaction(); Link Here

(-)a/misc/cronjobs/longoverdue.pl (-3 / +3 lines)
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,

Lines 67-76 if ($whereclause) { Link Here

(-)a/misc/maintenance/touch_all_biblios.pl (-4 / +6 lines)
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();

Lines 67-76 if ($whereclause) { Link Here

(-)a/misc/maintenance/touch_all_items.pl (-4 / +6 lines)
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();

Lines 146-153 if($marc_mod_template ne '') { Link Here

(-)a/misc/migration_tools/bulkmarcimport.pl (-3 / +4 lines)
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 )

Lines 139-145 BEGIN { Link Here

(-)a/misc/translator/TmplTokenizer.pm (-28 / +28 lines)
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	;

Lines 41-72 verbose warnings. Link Here

(-)a/misc/translator/VerboseWarnings.pm (-12 / +12 lines)
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

Lines 27-42 use vars qw( $allow_cformat_p ); # FOR TESTING PURPOSES ONLY!! Link Here

(-)a/misc/translator/text-extract2.pl (-18 / +18 lines)
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

Lines 32-38 use vars qw( $charset_in $charset_out ); Link Here

(-)a/misc/translator/tmpl_process3.pl (-41 / +40 lines)
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;

Lines 98-104 sub string_list { Link Here

(-)a/misc/translator/xgettext.pl (-13 / +15 lines)
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	}

Lines 531-538 my $expanded_facet = $params->{'expand'}; Link Here

(-)a/opac/opac-search.pl (-5 lines)
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} } ) {

Lines 44-56 my ( $template, $loggedinuser, $cookie ) = get_template_and_user({ Link Here

(-)a/patroncards/create-pdf.pl (-5 / +5 lines)
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;

Lines 40-53 my ( $template, $loggedinuser, $cookie ) = get_template_and_user( Link Here

(-)a/patroncards/print.pl (-6 / +6 lines)
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();

Lines 41-47 plugin that shows a stats on borrowers Link Here

(-)a/reports/bor_issues_top.pl (-14 / +12 lines)
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__

Lines 110-120 if ($do_it) { Link Here

(-)a/reports/borrowers_out.pl (-6 / +1 lines)
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;

Lines 114-124 if ($do_it) { Link Here

(-)a/reports/catalogue_stats.pl (-5 lines)
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.....

Lines 389-395 sub calculate { Link Here

(-)a/reports/issues_avg_stats.pl (-5 lines)
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;

Lines 148-156 if ($do_it) { Link Here

(-)a/reports/issues_stats.pl (-4 / +1 lines)
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] );

Lines 126-134 if ($do_it) { Link Here

(-)a/reports/reserves_stats.pl (-4 lines)
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){

Lines 19-24 Link Here

(-)a/rewrite-config.PL (-10 / +12 lines)
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

Lines 1-39 Link Here

(-)a/t/00-testcritic.t (-30 / +2 lines)
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

Lines 45-92 $ ./Record_test.pl Link Here

(-)a/t/db_dependent/Record/Record.t (-16 / +16 lines)
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)');

Lines 92-97 END { Link Here

(-)a/t/db_dependent/Search.t (-6 / +6 lines)
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;

Lines 211-217 sub handle_dir { Link Here

(-)a/tools/picture-upload.pl (-7 / +7 lines)
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 ) {

Lines 56-62 Output is sent to STDOUT. Link Here

(-)a/xt/author/show-template-structure.pl (-3 / +3 lines)
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) {

Lines 114-132 sub dashcomment { Link Here

(-)a/xt/fix-old-fsf-address (-4 / +4 lines)
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