[TestingAndDebugging::RequireUseWarnings]
equivalent_modules = Modern::Perl
+
+[-Modules::RequireBarewordIncludes]
my $manager_id = C4::Context->userenv ? C4::Context->userenv->{'number'} : undef;
my $dbh = C4::Context->dbh;
- my $insert;
my $amountleft = $amount;
my $branchcode = C4::Context->userenv ? C4::Context->userenv->{'branch'} : undef;
my $ordernumbers = $params{ordernumbers} || [];
my $additional_fields = $params{additional_fields} // [];
- my @order_loop;
my $total_qty = 0;
my $total_qtyreceived = 0;
my $total_price = 0;
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__
# the marclist may contain "mainentry". In this case, search the tag_to_report, that depends on
# the authtypecode. Then, search on $a of this tag_to_report
# also store main entry MARC tag, to extract it at end of search
- my $mainentrytag;
##first set the authtype search and may be multiple authorities
if ($authtypecode) {
my $n=0;
# along with Koha; if not, see <http://www.gnu.org/licenses>.
package C4::Barcodes::ValueBuilder::incremental;
+
+use Modern::Perl;
use C4::Context;
my $DEBUG = 0;
$width = 4;
}
-sub db_max ($;$) {
+sub db_max {
my $self = shift;
my $query = "SELECT substring_index(barcode,'-',-1) AS chunk,barcode FROM items WHERE barcode LIKE ? ORDER BY chunk DESC LIMIT 1";
# FIXME: unreasonably expensive query on large datasets (I think removal of group by does this?)
return substr(output_pref({ dt => dt_from_string, dateformat => 'iso', dateonly => 1 }), 0, 4 ) .'-'. sprintf('%'."$width.$width".'d', 1);
}
-sub parse ($;$) {
+sub parse {
my $self = shift;
my $barcode = (@_) ? shift : $self->value;
unless ($barcode =~ /(\d{4}-)(\d+)$/) { # non-greedy match in first part
$debug and warn "Barcode '$barcode' parses into: '$1', '$2', ''";
return ($1,$2,''); # the third part is in anticipation of barcodes that include checkdigits
}
-sub width ($;$) {
+sub width {
my $self = shift;
(@_) and $width = shift; # hitting the class variable.
return $width;
}
-sub process_head($$;$$) { # (self,head,whole,specific)
+sub process_head {
my ($self,$head,$whole,$specific) = @_;
$specific and return $head; # if this is built off an existing barcode, just return the head unchanged.
return substr(output_pref({ dt => dt_from_string, dateformat => 'iso', dateonly => 1 }), 0, 4 ) . '-'; # else get new YYYY-
# MARC::Record->new_from_xml will fail (and Koha will die)
my $unimarc_and_100_exist = 0;
$unimarc_and_100_exist = 1 if $auth_type eq 'ITEM'; # if we rebuild an item, no need of a 100 field
- my $prevvalue;
my $prevtag = -1;
my $first = 1;
my $j = -1;
foreach my $sort_routine (@sort_routines) {
if (eval "require C4::ClassSortRoutine::$sort_routine") {
my $ref;
- eval "\$ref = \\\&C4::ClassSortRoutine::${sort_routine}::get_class_sort_key";
- if (eval "\$ref->(\"a\", \"b\")") {
+ $ref = \&{"C4::ClassSortRoutine::${sort_routine}::get_class_sort_key"};
+ if (eval { $ref->("a", "b") }) {
$loaded_routines{$sort_routine} = $ref;
} else {
$loaded_routines{$sort_routine} = \&_get_class_sort_key;
my ($cn_item, $regexs) = @_;
for my $regex ( @$regexs ) {
- eval "\$cn_item =~ $regex";
+ eval "\$cn_item =~ $regex"; ## no critic (StringyEval)
}
my @lines = split "\n", $cn_item;
}
my $conf_cache = Koha::Caches->get_instance('config');
- my $config_from_cache;
if ( $conf_cache->cache ) {
$self = $conf_cache->get_from_cache('koha_conf');
}
{
my $self = shift;
my $params = shift;
- my $sth;
unless ( $params->{new} ) {
return Koha::Database->schema->storage->dbh;
warn whoami() . "( $course_id )" if $DEBUG;
my $course = Koha::Courses->find( $course_id );
- return undef unless $course;
+ return unless $course;
$course = $course->unblessed;
my $dbh = C4::Context->dbh;
# You should have received a copy of the GNU General Public License
# along with Koha; if not, see <http://www.gnu.org/licenses>.
+use Modern::Perl;
+
BEGIN {
use vars qw(@EXPORT @ISA);
@ISA = qw(Exporter);
sub html_table {
my $headers = shift;
my $data = shift;
- return undef if scalar(@$data) == 0; # no need to generate a table if there is not data to display
+ return if scalar(@$data) == 0; # no need to generate a table if there is not data to display
my $table = [];
my $fields = [];
my @table_columns = ();
my $marc_type = C4::Context->preference('marcflavour');
$marc_type .= 'AUTH' if ($marc_type eq 'UNIMARC' && $record_type eq 'auth');
- open IN, "<$input_file" or die "$0: cannot open input file $input_file: $!\n";
+ open my $fh, '<', $input_file or die "$0: cannot open input file $input_file: $!\n";
my @marc_records;
$/ = "\035";
- while (<IN>) {
+ while (<$fh>) {
s/^\s+//;
s/\s+$//;
next unless $_; # skip if record has only whitespace, as might occur
"Unexpected charset $charset_guessed, expecting $encoding";
}
}
- close IN;
+ close $fh;
return ( \@errors, \@marc_records );
}
return \@return if !$input_file || !$plugin_class;
# Read input file
- open IN, "<$input_file" or die "$0: cannot open input file $input_file: $!\n";
+ open my $fh, '<', $input_file or die "$0: cannot open input file $input_file: $!\n";
$/ = "\035";
- while (<IN>) {
+ while (<$fh>) {
s/^\s+//;
s/\s+$//;
next unless $_;
$text .= $_;
}
- close IN;
+ close $fh;
# Convert to large MARC blob with plugin
$text = Koha::Plugins::Handler->run({
$loggedin = 1;
$userid = $session->param('cardnumber');
}
- my ( $ip, $lasttime );
if ($logout) {
sub AddItemBatchFromMarc {
my ($record, $biblionumber, $biblioitemnumber, $frameworkcode) = @_;
- my $error;
my @itemnumbers = ();
my @errors = ();
my $dbh = C4::Context->dbh;
package C4::Labels;
+use Modern::Perl;
+
BEGIN {
use C4::Labels::Batch;
}
elsif ( $f =~ /^([0-9a-z]{3})(\w)(\W?).*?/ ) {
my ($field,$subf,$ws) = ($1,$2,$3);
- my $subf_data;
my ($itemtag, $itemsubfieldcode) = &GetMarcFromKohaField( "items.itemnumber" );
my @marcfield = $record->field($field);
if(@marcfield) {
my $label_text = '';
my ($text_llx, $text_lly, $line_spacer, $barcode_llx, $barcode_lly, $barcode_width, $barcode_y_scale_factor);
{
- no strict 'refs';
- ($text_llx, $text_lly, $line_spacer, $barcode_llx, $barcode_lly, $barcode_width, $barcode_y_scale_factor) = &{"_$self->{'printing_type'}"}($self); # an obfuscated call to the correct printing type sub
+ my $sub = \&{'_' . $self->{printing_type}};
+ ($text_llx, $text_lly, $line_spacer, $barcode_llx, $barcode_lly, $barcode_width, $barcode_y_scale_factor) = $sub->($self); # an obfuscated call to the correct printing type sub
}
if ($self->{'printing_type'} =~ /BIB/) {
$label_text = draw_label_text( $self,
my @languages_loop; # the final reference to an array of hashrefs
my @enabled_languages = @$enabled_languages;
# how many languages are enabled, if one, take note, some contexts won't need to display it
- my %seen_languages; # the language tags we've seen
- my %found_languages;
my $language_groups;
my $track_language_groups;
my $current_language_regex = regex_lang_subtags($current_language);
}
# No primary matches. Secondary? (ie, en-us requested and en supported)
return $secondaryMatch if $secondaryMatch;
- return undef; # else, we got nothing.
+ return; # else, we got nothing.
}
=head2 getlanguage
or warn( "No biblionumber for '$subscriptionid'" ),
return;
- my %letter;
# find the list of subscribers to notify
my $subscription = Koha::Subscriptions->find( $subscriptionid );
my $subscribers = $subscription->subscribers;
$sth->execute($id);
my $row = $sth->fetchrow_hashref;
$sth->finish();
- return undef unless defined $row;
+ return unless defined $row;
my $self = {};
$self->{'id'} = $row->{'matcher_id'};
my $sth = C4::Context->dbh->prepare($sql);
$sth->execute(@bind_params);
my $return;
- my %transports; # helps build a list of unique message_transport_types
ROW: while ( my $row = $sth->fetchrow_hashref() ) {
next ROW unless $row->{'message_attribute_id'};
$return->{'days_in_advance'} = $row->{'days_in_advance'} if defined $row->{'days_in_advance'};
package C4::Patroncards;
+use Modern::Perl;
+
BEGIN {
use vars qw(@EXPORT @ISA);
@ISA = qw(Exporter);
$parse_line = $2;
}
my $borrower_attributes = get_borrower_attributes($self->{'borrower_number'},@fields);
- grep{ # substitute data for db fields
- if ($_ =~ m/<([A-Za-z0-9_]+)>/) {
+ @orig_line = map { # substitute data for db fields
+ my $l = $_;
+ if ($l =~ m/<([A-Za-z0-9_]+)>/) {
my $field = $1;
- $_ =~ s/$_/$borrower_attributes->{$field}/;
+ $l =~ s/$l/$borrower_attributes->{$field}/;
}
+ $l;
} @orig_line;
$line = join(' ',@orig_line);
}
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);
+ eval $preprocess if ($preprocess); ## no critic (StringyEval)
my $firstpass = 1;
if ( @$itemnumbers ) {
}
# Postprocessing
- eval $postprocess if ($postprocess);
+ 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);
+ eval $fieldprocessing if ($fieldprocessing); ## no critic (StringyEval)
push @loop_values, $value;
}
sub marc2ris {
my ($record) = @_;
- my $output;
my $marcflavour = C4::Context->preference("marcflavour");
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
my $sth = $dbh->prepare($query);
$sth->execute($subscriptionid);
my $subscriptions = $sth->fetchall_arrayref( {} );
- my $cannotedit = not can_edit_subscription( $subscriptions->[0] ) if scalar @$subscriptions;
- for my $subscription ( @$subscriptions ) {
- $subscription->{cannotedit} = $cannotedit;
+ if (scalar @$subscriptions) {
+ my $cannotedit = not can_edit_subscription( $subscriptions->[0] );
+ for my $subscription ( @$subscriptions ) {
+ $subscription->{cannotedit} = $cannotedit;
+ }
}
+
return $subscriptions;
}
my $year;
my @res;
my $startdate;
- my $aqbooksellername;
- my $bibliotitle;
- my @loopissues;
my $first;
my $previousnote = "";
my $sth = $dbh->prepare($query);
$sth->execute($biblionumber);
my $subscriptions = $sth->fetchall_arrayref( {} );
- my $cannotedit = not can_edit_subscription( $subscriptions->[0] ) if scalar @$subscriptions;
- for my $subscription ( @$subscriptions ) {
- $subscription->{cannotedit} = $cannotedit;
+ if (scalar @$subscriptions) {
+ my $cannotedit = not can_edit_subscription( $subscriptions->[0] );
+ for my $subscription ( @$subscriptions ) {
+ $subscription->{cannotedit} = $cannotedit;
+ }
}
+
return $subscriptions;
}
$vars = { %$vars, %{ $self->{VARS} } };
my $data;
- binmode( STDOUT, ":utf8" );
+ binmode( STDOUT, ":encoding(UTF-8)" );
$template->process( $self->filename, $vars, \$data )
|| die "Template process failed: ", $template->error();
return $data;
my $install_log = shift;
my $values = shift;
- open LOG, "<$install_log" or die "Cannot open install log $install_log: $!\n";
- while (<LOG>) {
+ open my $log, '<', $install_log or die "Cannot open install log $install_log: $!\n";
+ while (<$log>) {
chomp;
next if /^#/ or /^\s*$/;
next if /^=/;
my ($key, $value) = split /=/, $_, 2;
$values->{$key} = $value;
}
- close LOG;
+ close $log;
print <<_EXPLAIN_INSTALL_LOG_;
Reading values from install log $install_log. You
use utf8;
use Modern::Perl;
-binmode(STDOUT, ":utf8");
+binmode(STDOUT, ":encoding(UTF-8)");
use C4::Auth qw(check_api_auth);
use C4::Output;
# Now we store the pgtIou and the pgtId in the application vars (in our case a storable object in a file),
# so that the page requesting the webservice can retrieve the pgtId matching it's PgtIou
- open FILE, ">", "casSession.tmp" or die "Unable to open file";
- nstore_fd({$pgtIou => $pgtId}, \*FILE);
- close FILE;
+ open my $fh, ">", "casSession.tmp" or die "Unable to open file";
+ nstore_fd({$pgtIou => $pgtId}, $fh);
+ close $fh;
} else {
warn "Failed to get a Proxy Ticket\n";
# At this point, we must retrieve the PgtId by matching the PgtIou we
# just received and the PgtIou given by the CAS Server to the callback URL
# The callback page stored it in the application vars (in our case a storable object in a file)
- open FILE, "casSession.tmp" or die "Unable to open file";
- my $hashref = fd_retrieve(\*FILE);
+ open my $fh, '<', "casSession.tmp" or die "Unable to open file";
+ my $hashref = fd_retrieve($fh);
my $pgtId = %{$hashref->{$cgi->param('PGTIOU')}};
- close FILE;
+ close $fh;
# Now that we have a PgtId, we can ask the cas server for a proxy ticket...
my $rp = $cas->proxy( $pgtId, $target_service );
# to make it writable. Note that stat and chmod
# (the Perl functions) should work on Win32
my $old_perm;
- $old_perm = (stat $pathfile)[2] & 07777;
- my $new_perm = $old_perm | 0200;
+ $old_perm = (stat $pathfile)[2] & oct(7777);
+ my $new_perm = $old_perm | oct(200);
chmod $new_perm, $pathfile;
# tie the file -- note that we're explicitly setting the line (record)
# You should have received a copy of the GNU General Public License
# along with Koha; if not, see <http://www.gnu.org/licenses>.
+use Modern::Perl;
+
use C4::Context;
my $sth = C4::Context->dbh;
# You should have received a copy of the GNU General Public License
# along with Koha; if not, see <http://www.gnu.org/licenses>.
+use Modern::Perl;
+
use C4::Context;
my $sth = C4::Context->dbh;
$table,
$column,
$type, $null, $key, $default, $extra,
- $prefitem, # preference item in systempreferences table
);
my $silent;
],
);
- foreach $table ( keys %required_prereq_fields ) {
+ foreach my $table ( keys %required_prereq_fields ) {
print "Check table $table\n" if $debug and not $silent;
$sth = $dbh->prepare("show columns from $table");
$sth->execute();
# Now add any missing tables
- foreach $table ( keys %requiretables ) {
+ foreach my $table ( keys %requiretables ) {
unless ( $existingtables{$table} ) {
print "Adding $table table...\n" unless $silent;
my $sth = $dbh->prepare("create table $table $requiretables{$table} ENGINE=InnoDB DEFAULT CHARSET=utf8");
#---------------------------------
# Columns
- foreach $table ( keys %requirefields ) {
+ foreach my $table ( keys %requirefields ) {
print "Check table $table\n" if $debug and not $silent;
$sth = $dbh->prepare("show columns from $table");
$sth->execute();
{
$types{$column} = $type;
} # while
- foreach $column ( keys %{ $requirefields{$table} } ) {
+ foreach my $column ( keys %{ $requirefields{$table} } ) {
print " Check column $column [$types{$column}]\n" if $debug and not $silent;
if ( !$types{$column} ) {
} # foreach column
} # foreach table
- foreach $table ( sort keys %fielddefinitions ) {
+ foreach my $table ( sort keys %fielddefinitions ) {
print "Check table $table\n" if $debug;
$sth = $dbh->prepare("show columns from $table");
$sth->execute();
}
}
# now drop useless tables
- foreach $table ( @TableToDelete ) {
+ foreach my $table ( @TableToDelete ) {
if ( $existingtables{$table} ) {
print "Dropping unused table $table\n" if $debug and not $silent;
$dbh->do("drop table $table");
}
# at last, remove useless fields
- foreach $table ( keys %uselessfields ) {
+ foreach my $table ( keys %uselessfields ) {
my @fields = split (/,/,$uselessfields{$table});
- my $fields;
my $exists;
foreach my $fieldtodrop (@fields) {
$fieldtodrop =~ s/\t//g;
my $debug = 0;
my (
- $sth, $sti,
+ $sth,
$query,
- %existingtables, # tables already in database
- %types,
$table,
- $column,
- $type, $null, $key, $default, $extra,
- $prefitem, # preference item in systempreferences table
+ $type,
);
my $schema = Koha::Database->new()->schema();
my $rv = $installer->load_sql( $update_dir . $file ) ? 0 : 1;
} elsif ( $file =~ /\.perl$/ ) {
my $code = read_file( $update_dir . $file );
- eval $code;
+ eval $code; ## no critic (StringyEval)
say "Atomic update generated errors: $@" if $@;
}
}
$dir=C4::Context->config('opacdir');
qx(grep -r "^ *use" $dir | grep -v "C4\|strict\|vars" >>/tmp/modulesKoha.log);
-open FILE, "< /tmp/modulesKoha.log" ||die "unable to open file /tmp/modulesKoha.log";
+open my $fh, '<', '/tmp/modulesKoha.log' ||die "unable to open file /tmp/modulesKoha.log";
my %modulehash;
-while (my $line=<FILE>){
+while (my $line=<$fh>){
if ( $line=~m#(.*)\:\s*use\s+([A-Z][^\s;]+)# ){
my ($file,$module)=($1,$2);
my @filename = split /\//, $file;
}
print "external modules used in Koha ARE :\n";
map {print "* $_ \t in files ",join (",",@{$modulehash{$_}}),"\n" } sort keys %modulehash;
-close FILE;
+close $fh;
unlink "/tmp/modulesKoha.log";
close $fh;
if (@report) {
$template->param( update_report =>
- [ map { local $_ = $_; $_ =~ s/\t/  /g; { line => $_ } } split( /\n/, join( '', @report ) ) ]
+ [ map { { line => $_ =~ s/\t/  /gr } } split( /\n/, join( '', @report ) ) ]
);
$template->param( has_update_succeeds => 1 );
}
# along with Koha; if not, see <http://www.gnu.org/licenses>.
#
+use Modern::Perl;
use Koha::Script;
use C4::Boolean;
use C4::Context;
my $dbh = C4::Context->dbh;
-my %kohafields;
my $sth=$dbh->prepare("SELECT biblio.biblionumber, biblioitemnumber, frameworkcode FROM biblio JOIN biblioitems USING (biblionumber)");
$sth->execute();
use Koha::Script;
use C4::Biblio;
-my ($help, $files);
+my $help;
GetOptions(
'h|help' => \$help,
);
die "Invalid config line $line: $_" unless defined $v;
$param{$p} = $v;
}
+ close($conf_fh);
$self->{koha} = delete( $param{koha} )
or die "No koha base url in config file";
if ( !-d _ ) {
my $name = $File::Find::name;
if ( $name =~ /(\.pl|\.pm)$/ ) {
- open( FILE, "$_" ) || die "can't open $name";
- while ( my $inp = <FILE> ) {
+ open( my $fh, '<', $_ ) || die "can't open $name";
+ while ( my $inp = <$fh> ) {
if ( $inp =~ /C4::Context->preference\((.*?)\)/ ) {
my $variable = $1;
$variable =~ s /\'|\"//g;
"$name has a reference to $variable, this does not exist in the database\n";
}
}
- close FILE;
+ close $fh;
}
}
$sth->finish();
use C4::Log;
my ( $input_marc_file, $number) = ('',0);
-my ($version, $confirm,$test_parameter,$field,$batch,$max_digits,$cloud_tag);
+my ($version, $confirm,$field,$batch,$max_digits,$cloud_tag);
GetOptions(
'c' => \$confirm,
'h' => \$version,
use MIME::Lite;
my (
- $stylesheet,
$help,
$split,
$html,
open my $OUTPUT, '>encoding(utf-8)', $filepath
or die "Could not open $filepath: $!";
- my ( @csv_lines, $headers );
+ my $headers;
foreach my $message ( @$messages ) {
my @lines = split /\n/, $message->{content};
chomp for @lines;
# You should have received a copy of the GNU General Public License
# along with Koha; if not, see <http://www.gnu.org/licenses>.
-#use strict;
-#use warnings; FIXME - Bug 2505
+use Modern::Perl;
BEGIN {
# find Koha's Perl modules
# In my opinion, this line is safe SQL to have outside the API. --atz
our $bounds_sth = C4::Context->dbh->prepare("SELECT DATE_SUB(CURDATE(), INTERVAL ? DAY)");
-sub bounds ($) {
+sub bounds {
$bounds_sth->execute(shift);
return $bounds_sth->fetchrow;
}
$endrange = $startrange;
}
-sub summarize ($$) {
+sub summarize {
my $arg = shift; # ref to array
my $got_items = shift || 0; # print "count" line for items
- my @report = @$arg or return undef;
+ my @report = @$arg or return;
my $i = 0;
for my $range (@report) {
printf "\nRange %s\nDue %3s - %3s days ago (%s to %s), lost => %s\n", ++$i,
my %return;
my $inSection = 0;
- open( FILE, $file ) or die "can't open $file";
- while (<FILE>) {
+ open( my $fh, '<', $file ) or die "can't open $file";
+ while (<$fh>) {
if ($inSection) {
my @line = split( /=/, $_, 2 );
unless ( $line[1] ) {
if ( $_ eq "$section\n" ) { $inSection = 1 }
}
}
- close FILE;
+ close $fh;
return %return;
}
$updated += $result;
$total++;
}
+ close($IN);
}
else {
die pod2usage( -verbose => 1 );
'h|help' => \$want_help
);
-binmode( STDOUT, ":utf8" );
+binmode( STDOUT, ":encoding(UTF-8)" );
if ( defined $since && defined $interval ) {
print "The --since and --interval options are mutually exclusive.\n\n";
use C4::Biblio;
use C4::Auth;
my $outfile = $ARGV[0];
-open(OUT,">$outfile") or die $!;
+open(my $fh, '>', $outfile) or die $!;
my $dbh=C4::Context->dbh;
#$dbh->do("set character_set_client='latin5'");
$dbh->do("set character_set_connection='utf8'");
my $sth=$dbh->prepare("select marc from auth_header order by authid");
$sth->execute();
while (my ($marc) = $sth->fetchrow) {
- print OUT $marc;
+ print $fh $marc;
}
-close(OUT);
+close($fh);
'h|help' => \$want_help
);
-binmode( STDOUT, ":utf8" );
+binmode( STDOUT, ":encoding(UTF-8)" );
if ( not $result or $want_help ) {
usage();
use C4::Context;
my $dbh = C4::Context->dbh;
-my ( $help, $cmd, $filename, $override, $compare_add, $compare_del, $compare_upd, $ignore_opt, $partial );
+my ( $help, $cmd, $filename, $compare_add, $compare_del, $compare_upd, $ignore_opt, $partial );
GetOptions(
'help' => \$help,
'cmd:s' => \$cmd,
"SELECT * FROM accountlines WHERE description LIKE ? AND description NOT LIKE ?";
$sth = $dbh->prepare($query);
-my @fines;
foreach my $keeper (@$results) {
warn "WORKING ON KEEPER: " . Data::Dumper::Dumper( $keeper );
}
# output log or STDOUT
+my $fh;
if (defined $outfile) {
- open (OUT, ">$outfile") || die ("Cannot open output file");
+ open ($fh, '>', $outfile) || die ("Cannot open output file");
} else {
- open(OUT, ">&STDOUT") || die ("Couldn't duplicate STDOUT: $!");
+ open($fh, '>&', \*STDOUT) || die ("Couldn't duplicate STDOUT: $!");
}
my $sth1 = $dbh->prepare("SELECT biblionumber, frameworkcode FROM biblio $whereclause");
if ($modok) {
$goodcount++;
- print OUT "Touched biblio $biblionumber\n" if (defined $verbose);
+ print $fh "Touched biblio $biblionumber\n" if (defined $verbose);
} else {
$badcount++;
- print OUT "ERROR WITH BIBLIO $biblionumber !!!!\n";
+ print $fh "ERROR WITH BIBLIO $biblionumber !!!!\n";
}
$totalcount++;
}
+close($fh);
# Benchmarking
my $endtime = time();
}
# output log or STDOUT
+my $fh;
if (defined $outfile) {
- open (OUT, ">$outfile") || die ("Cannot open output file");
+ open ($fh, '>', $outfile) || die ("Cannot open output file");
} else {
- open(OUT, ">&STDOUT") || die ("Couldn't duplicate STDOUT: $!");
+ open($fh, '>&', \*STDOUT) || die ("Couldn't duplicate STDOUT: $!");
}
# FIXME Would be better to call Koha::Items->search here
if ($modok) {
$goodcount++;
- print OUT "Touched item $itemnumber\n" if (defined $verbose);
+ print $fh "Touched item $itemnumber\n" if (defined $verbose);
} else {
$badcount++;
- print OUT "ERROR WITH ITEM $itemnumber !!!!\n";
+ print $fh "ERROR WITH ITEM $itemnumber !!!!\n";
}
$totalcount++;
}
+close($fh);
# Benchmarking
my $endtime = time();
#!/usr/bin/perl
-#use strict;
-#use warnings; FIXME - Bug 2505
+use Modern::Perl;
BEGIN {
# find Koha's Perl modules
# test carefully before changing this
if (C4::Context->preference('marcflavour') eq "UNIMARC"){
$record->leader(' nac 22 1u 4500');
- my $string=$1 if $time=~m/([0-9\-]+)/;
+ my $string= ($time=~m/([0-9\-]+)/) ? $1 : undef
$string=~s/\-//g;
$string = sprintf("%-*s",26, $string);
substr($string,9,6,"frey50");
#!/usr/bin/perl
-#use strict;
-#use warnings; FIXME - Bug 2505
+use Modern::Perl;
BEGIN {
# find Koha's Perl modules
# test carefully before changing this
# if (C4::Context->preference('marcflavour') eq "UNIMARC"){
$record->leader(' nac 22 1u 4500');
- my $string=$1 if $time=~m/([0-9\-]+)/;
+ my $string = ($time=~m/([0-9\-]+)/) ? $1 : undef
$string=~s/\-//g;
$string = sprintf("%-*s",26, $string);
substr($string,9,6,"frey50");
#!/usr/bin/perl
-#use strict;
-#use warnings; FIXME - Bug 2505
+use Modern::Perl;
# script to shift marc to biblioitems
# scraped from updatedatabase for dev week by chris@katipo.co.nz
BEGIN {
use Getopt::Long;
my ( $fields, $number,$language) = ('',0);
-my ($version, $verbose, $test_parameter, $field,$delete,$subfields);
+my ($version, $verbose, $test_parameter, $delete);
GetOptions(
'h' => \$version,
'd' => \$delete,
my $sth = $dbh->prepare("select bibid from marc_biblio");
$sth->execute;
my $i=1;
-my %alreadydone;
my $counter;
my %hash;
while (my ($bibid) = $sth->fetchrow) {
use Getopt::Long;
my ( $fields, $number,$language) = ('',0);
-my ($version, $verbose, $test_parameter, $field,$delete,$subfields);
+my ($version, $verbose, $test_parameter, $delete);
GetOptions(
'h' => \$version,
'd' => \$delete,
my $dbh = C4::Context->dbh;
my $heading_fields=get_heading_fields();
+my $idmapfh;
if (defined $idmapfl) {
- open(IDMAP,">$idmapfl") or die "cannot open $idmapfl \n";
+ open($idmapfh, '>', $idmapfl) or die "cannot open $idmapfl \n";
}
if ((not defined $sourcesubfield) && (not defined $sourcetag)){
if ($sourcetag < "010"){
if ($record->field($sourcetag)){
my $source = $record->field($sourcetag)->data();
- printf(IDMAP "%s|%s\n",$source,$biblionumber);
+ printf($idmapfh "%s|%s\n",$source,$biblionumber);
}
} else {
my $source=$record->subfield($sourcetag,$sourcesubfield);
- printf(IDMAP "%s|%s\n",$source,$biblionumber);
+ printf($idmapfh "%s|%s\n",$source,$biblionumber);
}
}
# create biblio, unless we already have it ( either match or isbn )
}
my $dbh=C4::Context->dbh;
-my @results;
# prepare the request to retrieve all authorities of the requested types
my $rqsql = q{ SELECT authid,authtypecode FROM auth_header };
$rqsql .= q{ WHERE authtypecode IN (}.join(',',map{ '?' }@authtypes).')' if @authtypes;
# Remove a perl module
-use warnings;
+use Modern::Perl;
use ExtUtils::Packlist;
use ExtUtils::Installed;
opendir( my $dh, $self->{path_po} );
my @files = grep { $_ =~ /-pref.(po|po.gz)$/ }
readdir $dh;
- @files = map { $_ =~ s/-pref.(po|po.gz)$//; $_ } @files;
+ @files = map { $_ =~ s/-pref.(po|po.gz)$//r } @files;
}
sub parenleft () { '(' }
sub parenright () { ')' }
-sub _split_js ($) {
+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 (@) {
+sub _identify_js_translatables {
my @input = @_;
my @output = ();
# We mark a JavaScript translatable string as in C, i.e., _("literal")
###############################################################################
-sub string_canon ($) {
+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 ($) {
+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 );
+ return _quote_cformat( string_canon_safe($s) );
}
sub _formalize{
return $self->_parametrize_internal(@parts);
}
else {
- return undef;
+ 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;
+ 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 ($$$$) {
+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
+ warn_normal("$fmt_0: $&: Expected a TMPL_VAR, but found a "
+ . $param->type->to_string . "\n", undef)
if $param->type != C4::TmplTokenType::DIRECTIVE;
- warn_normal "$fmt_0: $&: Unsupported "
- . "field width or precision\n", undef
+ warn_normal("$fmt_0: $&: Unsupported "
+ . "field width or precision\n", undef)
if defined $width || defined $prec;
- warn_normal "$fmt_0: $&: Parameter $i not known", undef
+ warn_normal("$fmt_0: $&: Parameter $i not known", undef)
unless defined $param;
$it .= defined $f? &$f( $param ): $param->string;
}
my $param = $params[$i - 1];
if (!defined $param) {
- warn_normal "$fmt_0: $&: Parameter $i not known", undef;
+ warn_normal("$fmt_0: $&: Parameter $i not known", undef);
} else {
if ($param->type == C4::TmplTokenType::TAG
&& $param->string =~ /^<input\b/is) {
my $type = defined $param->attributes?
lc($param->attributes->{'type'}->[1]): undef;
if ($conv eq 'S') {
- warn_normal "$fmt_0: $&: Expected type=text, "
- . "but found type=$type", undef
+ warn_normal("$fmt_0: $&: Expected type=text, "
+ . "but found type=$type", undef)
unless $type eq 'text';
} elsif ($conv eq 'p') {
- warn_normal "$fmt_0: $&: Expected type=radio, "
- . "but found type=$type", undef
+ warn_normal("$fmt_0: $&: Expected type=radio, "
+ . "but found type=$type", undef)
unless $type eq 'radio';
}
} else {
- warn_normal "$&: Expected an INPUT, but found a "
- . $param->type->to_string . "\n", undef
+ warn_normal("$&: Expected an INPUT, but found a "
+ . $param->type->to_string . "\n", undef)
}
- warn_normal "$fmt_0: $&: Unsupported "
- . "field width or precision\n", undef
+ warn_normal("$fmt_0: $&: Unsupported "
+ . "field width or precision\n", undef)
if defined $width || defined $prec;
$it .= defined $f? &$f( $param ): $param->string;
}
my $i = $1;
$fmt = $';
my $anchor = $anchors[$i - 1];
- warn_normal "$&: Anchor $1 not found for msgid \"$fmt_0\"", undef #FIXME
+ warn_normal("$&: Anchor $1 not found for msgid \"$fmt_0\"", undef) #FIXME
unless defined $anchor;
$it .= $anchor->string;
} else {
# Other simple functions (These are not methods)
-sub blank_p ($) {
+sub blank_p {
my($s) = @_;
return $s =~ /^(?:\s|\ $re_end_entity|$re_tmpl_var|$re_xsl)*$/osi;
}
-sub trim ($) {
+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 ($) {
+sub quote_po {
my($s) = @_;
# Locale::PO->quote is buggy, it doesn't quote newlines :-/
$s =~ s/([\\"])/\\$1/gs;
return "\"$s\"";
}
-sub charset_canon ($) {
+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 ($$$) {
+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 ($) {
+sub set_application_name {
my($s) = @_;
$appName = $& if !defined $appName && $s =~ /[^\/]+$/;
}
-sub application_name () {
+sub application_name {
return $appName;
}
-sub set_input_file_name ($) {
+sub set_input_file_name {
my($s) = @_;
$input = $s;
$input_abbr = $& if defined $s && $s =~ /[^\/]+$/;
}
-sub set_pedantic_mode ($) {
+sub set_pedantic_mode {
my($p) = @_;
$pedantic_p = $p;
$pedantic_tag = $pedantic_p? '': ' (negligible)';
}
-sub pedantic_p () {
+sub pedantic_p {
return $pedantic_p;
}
-sub construct_warn_prefix ($$) {
+sub construct_warn_prefix {
my($prefix, $lc) = @_;
die "construct_warn_prefix called before set_application_name"
unless defined $appName;
return "$appName: $prefix: " . (defined $lc? "$input_abbr: line $lc: ": defined $input_abbr? "$input_abbr: ": '');
}
-sub warn_additional ($$) {
+sub warn_additional {
my($msg, $lc) = @_;
my $prefix = construct_warn_prefix('Warning', $lc);
$msg .= "\n" unless $msg =~ /\n$/s;
warn "$prefix$msg";
}
-sub warn_normal ($$) {
+sub warn_normal {
my($msg, $lc) = @_;
$warned += 1;
warn_additional($msg, $lc);
}
-sub warn_pedantic ($$$) {
+sub warn_pedantic {
my($msg, $lc, $flag) = @_;
my $prefix = construct_warn_prefix("Warning$pedantic_tag", $lc);
$msg .= "\n" unless $msg =~ /\n$/s;
$warned += 1;
}
-sub error_additional ($$) {
+sub error_additional {
my($msg, $lc) = @_;
my $prefix = construct_warn_prefix('ERROR', $lc);
$msg .= "\n" unless $msg =~ /\n$/s;
warn "$prefix$msg";
}
-sub error_normal ($$) {
+sub error_normal {
my($msg, $lc) = @_;
$erred += 1;
error_additional($msg, $lc);
}
-sub warned () {
+sub warned {
return $warned; # number of times warned
}
sub main
{
- my ($src_fh, $src);
+ my $src;
my $pretty = 0;
if ($ARGV[0] =~ /^--?p$/) {
# on a normal msgid
} else {
my $qmsgctxt = $po->msgctxt;
- my $msgctxt = $po->dequote($qmsgctxt) if $qmsgctxt;
+ my $msgctxt;
+ $msgctxt = $po->dequote($qmsgctxt) if $qmsgctxt;
# build the new msgid key
my $msg_ctxt_id = defined($msgctxt) ? join($gettext_context_glue, ($msgctxt, $msgid1)) : $msgid1;
# msgid plural side
my $qmsgid_plural = $po->msgid_plural;
- my $msgid2 = $po->dequote( $qmsgid_plural ) if $qmsgid_plural;
+ my $msgid2;
+ $msgid2 = $po->dequote( $qmsgid_plural ) if $qmsgid_plural;
push(@trans, $msgid2);
# translated string
for (my $i=0; $i<$plural_form_count; $i++)
{
my $qstr = ref($plurals) ? $$plurals{$i} : undef;
- my $str = $po->dequote( $qstr ) if $qstr;
+ my $str;
+ $str = $po->dequote( $qstr ) if $qstr;
push(@trans, $str);
}
# singular
} else {
my $qmsgstr = $po->msgstr;
- my $msgstr = $po->dequote( $qmsgstr ) if $qmsgstr;
+ my $msgstr;
+ $msgstr = $po->dequote( $qmsgstr ) if $qmsgstr;
push(@trans, $msgstr);
}
###############################################################################
-sub find_translation ($) {
+sub find_translation {
my($s) = @_;
my $key = $s;
if ($s =~ /\S/s) {
}
}
-sub text_replace_tag ($$) {
+sub text_replace_tag {
my($t, $attr) = @_;
my $it;
my @ttvar;
# value [tag=input], meta
- my $tag = lc($1) if $t =~ /^<(\S+)/s;
+ my $tag = ($t =~ /^<(\S+)/s) ? lc($1) : undef;
my $translated_p = 0;
for my $a ('alt', 'content', 'title', 'value', 'label', 'placeholder') {
if ($attr->{$a}) {
return $it;
}
-sub text_replace (**) {
+sub text_replace {
my($h, $output) = @_;
for (;;) {
- my $s = TmplTokenizer::next_token $h;
+ my $s = TmplTokenizer::next_token($h);
last unless defined $s;
my($kind, $t, $attr) = ($s->type, $s->string, $s->attributes);
if ($kind eq C4::TmplTokenType::TEXT) {
for my $t (@{$s->js_data}) {
# FIXME for this whole block
if ($t->[0]) {
- printf $output "%s%s%s", $t->[2], find_translation $t->[3],
+ printf $output "%s%s%s", $t->[2], find_translation($t->[3]),
$t->[2];
} else {
print $output $t->[1];
}
}
} else {
- warn_normal "$dir: $!", undef;
+ warn_normal("$dir: $!", undef);
}
return @it;
}
###############################################################################
-sub mkdir_recursive ($) {
+sub mkdir_recursive {
my($dir) = @_;
local($`, $&, $', $1);
$dir = $` if $dir ne /^\/+$/ && $dir =~ /\/+$/;
if (!-d $dir) {
print STDERR "Making directory $dir...\n" unless $quiet;
# creates with rwxrwxr-x permissions
- mkdir($dir, 0775) || warn_normal "$dir: $!", undef;
+ mkdir($dir, 0775) || warn_normal("$dir: $!", undef);
}
}
###############################################################################
-sub usage ($) {
+sub usage {
my($exitcode) = @_;
my $h = $exitcode? *STDERR: *STDOUT;
print $h <<EOF;
###############################################################################
-sub usage_error (;$) {
+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;
+) || usage_error();
-VerboseWarnings::set_application_name $0;
-VerboseWarnings::set_pedantic_mode $pedantic_p;
+VerboseWarnings::set_application_name($0);
+VerboseWarnings::set_pedantic_mode($pedantic_p);
# keep the buggy Locale::PO quiet if it says stupid things
$SIG{__WARN__} = sub {
# guess the charsets. HTML::Templates defaults to iso-8859-1
if (defined $href) {
die "$str_file: PO file is corrupted, or not a PO file\n" unless defined $href->{'""'};
- $charset_out = TmplTokenizer::charset_canon $2 if $href->{'""'}->msgstr =~ /\bcharset=(["']?)([^;\s"'\\]+)\1/;
+ $charset_out = TmplTokenizer::charset_canon($2) if $href->{'""'}->msgstr =~ /\bcharset=(["']?)([^;\s"'\\]+)\1/;
$charset_in = $charset_out;
# for my $msgid (keys %$href) {
# if ($msgid =~ /\bcharset=(["']?)([^;\s"'\\]+)\1/) {
next if $id_count == $str_count ||
$msg->{msgstr} eq '""' ||
grep { /fuzzy/ } @{$msg->{_flags}};
- warn_normal
+ warn_normal(
"unconsistent %s count: ($id_count/$str_count):\n" .
" line: " . $msg->{loaded_line_number} . "\n" .
" msgid: " . $msg->{msgid} . "\n" .
- " msgstr: " . $msg->{msgstr} . "\n", undef;
+ " msgstr: " . $msg->{msgstr} . "\n", undef);
}
}
# set our charset in to UTF-8
if (!defined $charset_in) {
- $charset_in = TmplTokenizer::charset_canon 'UTF-8';
+ $charset_in = TmplTokenizer::charset_canon('UTF-8');
warn "Warning: Can't determine original templates' charset, defaulting to $charset_in\n" unless ( $quiet );
}
# set our charset out to UTF-8
if (!defined $charset_out) {
- $charset_out = TmplTokenizer::charset_canon 'UTF-8';
+ $charset_out = TmplTokenizer::charset_canon('UTF-8');
warn "Warning: Charset Out defaulting to $charset_out\n" unless ( $quiet );
}
my $xgettext = './xgettext.pl'; # actual text extractor script
# FIXME: msgmerge(1) is a Unix dependency
# FIXME: need to check the return value
unless (-f $str_file) {
- local(*INPUT, *OUTPUT);
- open(INPUT, "<$tmpfile2");
- open(OUTPUT, ">$str_file");
- while (<INPUT>) {
- print OUTPUT;
+ open(my $infh, '<', $tmpfile2);
+ open(my $outfh, '>', $str_file);
+ while (<$infh>) {
+ print $outfh;
last if /^\n/s;
}
- close INPUT;
- close OUTPUT;
+ close $infh;
+ close $outfh;
}
$st = system("msgmerge ".($quiet?'-q':'')." -s $str_file $tmpfile2 -o - | msgattrib --no-obsolete -o $str_file");
} else {
- error_normal "Text extraction failed: $xgettext: $!\n", undef;
- error_additional "Will not run msgmerge\n", undef;
+ error_normal("Text extraction failed: $xgettext: $!\n", undef);
+ error_additional("Will not run msgmerge\n", undef);
}
- unlink $tmpfile1 || warn_normal "$tmpfile1: unlink failed: $!\n", undef;
- unlink $tmpfile2 || warn_normal "$tmpfile2: unlink failed: $!\n", undef;
+ unlink $tmpfile1 || warn_normal("$tmpfile1: unlink failed: $!\n", undef);
+ unlink $tmpfile2 || warn_normal("$tmpfile2: unlink failed: $!\n", undef);
} elsif ($action eq 'update') {
my($tmph1, $tmpfile1) = tmpnam();
$st = system("msgmerge ".($quiet?'-q':'')." -s $str_file $tmpfile2 -o - | msgattrib --no-obsolete -o $str_file");
}
} else {
- error_normal "Text extraction failed: $xgettext: $!\n", undef;
- error_additional "Will not run msgmerge\n", undef;
+ error_normal("Text extraction failed: $xgettext: $!\n", undef);
+ error_additional("Will not run msgmerge\n", undef);
}
- unlink $tmpfile1 || warn_normal "$tmpfile1: unlink failed: $!\n", undef;
- unlink $tmpfile2 || warn_normal "$tmpfile2: unlink failed: $!\n", undef;
+ unlink $tmpfile1 || warn_normal("$tmpfile1: unlink failed: $!\n", undef);
+ unlink $tmpfile2 || warn_normal("$tmpfile2: unlink failed: $!\n", undef);
} elsif ($action eq 'install') {
if(!defined($out_dir)) {
-d $out_dir || die "$out_dir: The directory does not exist\n";
# Try to open the file, because Locale::PO doesn't check :-/
- open(INPUT, "<$str_file") || die "$str_file: $!\n";
- close INPUT;
+ open(my $fh, '<', $str_file) || die "$str_file: $!\n";
+ close $fh;
# creates the new tmpl file using the new translation
for my $input (@in_files) {
unless substr($input, 0, length($in_dir) + 1) eq "$in_dir/";
my $target = $out_dir . substr($input, length($in_dir));
- my $targetdir = $` if $target =~ /[^\/]+$/s;
+ my $targetdir = ($target =~ /[^\/]+$/s) ? $` : undef;
if (!defined $type || $input =~ /\.(?:$type)$/) {
my $h = TmplTokenizer->new( $input );
$h->set_allow_cformat( 1 );
- VerboseWarnings::set_input_file_name $input;
+ VerboseWarnings::set_input_file_name($input);
mkdir_recursive($targetdir) unless -d $targetdir;
print STDERR "Creating $target...\n" unless $quiet;
- open( OUTPUT, ">:encoding(UTF-8)", "$target" ) || die "$target: $!\n";
- text_replace( $h, *OUTPUT );
- close OUTPUT;
+ open( my $fh, ">:encoding(UTF-8)", "$target" ) || die "$target: $!\n";
+ text_replace( $h, $fh );
+ close $fh;
} else {
# just copying the file
mkdir_recursive($targetdir) unless -d $targetdir;
sub text_extract {
my($h) = @_;
for (;;) {
- my $s = TmplTokenizer::next_token $h;
+ my $s = TmplTokenizer::next_token($h);
last unless defined $s;
my($kind, $t, $attr) = ($s->type, $s->string, $s->attributes);
if ($kind eq C4::TmplTokenType::TEXT) {
next if $a eq 'value' && ($tag ne 'input'
|| (ref $attr->{'type'} && $attr->{'type'}->[1] =~ /^(?:hidden|radio|checkbox)$/)); # FIXME
my($key, $val, $val_orig, $order) = @{$attr->{$a}}; #FIXME
- $val = TmplTokenizer::trim $val;
+ $val = TmplTokenizer::trim($val);
# for selected attributes replace '[%..%]' with '%s' globally
if ( $a =~ /title|value|alt|content|placeholder/ ) {
$val =~ s/\[\%.*?\%\]/\%s/g;
sub generate_po_file {
# We don't emit the Plural-Forms header; it's meaningless for us
my $pot_charset = (defined $charset_out? $charset_out: 'CHARSET');
- $pot_charset = TmplTokenizer::charset_canon $pot_charset;
+ $pot_charset = TmplTokenizer::charset_canon($pot_charset);
# Time stamps aren't exactly right semantically. I don't know how to fix it.
my $time = POSIX::strftime('%Y-%m-%d %H:%M%z', localtime(time));
my $time_pot = $time;
$cformat_p = 1 if $token->type == C4::TmplTokenType::TEXT_PARAMETRIZED;
}
printf $OUTPUT "#, c-format\n" if $cformat_p;
- printf $OUTPUT "msgid %s\n", TmplTokenizer::quote_po
- TmplTokenizer::string_canon
- TmplTokenizer::charset_convert $t, $charset_in, $charset_out;
+ printf $OUTPUT "msgid %s\n", TmplTokenizer::quote_po(
+ TmplTokenizer::string_canon(
+ TmplTokenizer::charset_convert($t, $charset_in, $charset_out)
+ )
+ );
printf $OUTPUT "msgstr %s\n\n", (defined $translation{$t}?
TmplTokenizer::quote_po( $translation{$t} ): "\"\"");
}
sub convert_translation_file {
open(my $INPUT, '<:encoding(utf-8)', $convert_from) || die "$convert_from: $!\n";
- VerboseWarnings::set_input_file_name $convert_from;
+ VerboseWarnings::set_input_file_name($convert_from);
while (<$INPUT>) {
chomp;
my($msgid, $msgstr) = split(/\t/);
$translation{$msgid} = $msgstr unless $msgstr eq '*****';
if ($msgid =~ /\bcharset=(["']?)([^;\s"']+)\1/s) {
- my $candidate = TmplTokenizer::charset_canon $2;
+ my $candidate = TmplTokenizer::charset_canon($2);
die "Conflicting charsets in msgid: $candidate vs $charset_in\n"
if defined $charset_in && $charset_in ne $candidate;
$charset_in = $candidate;
}
if ($msgstr =~ /\bcharset=(["']?)([^;\s"']+)\1/s) {
- my $candidate = TmplTokenizer::charset_canon $2;
+ my $candidate = TmplTokenizer::charset_canon($2);
die "Conflicting charsets in msgid: $candidate vs $charset_out\n"
if defined $charset_out && $charset_out ne $candidate;
$charset_out = $candidate;
}
# The following assumption is correct; that's what HTML::Template assumes
if (!defined $charset_in) {
- $charset_in = $charset_out = TmplTokenizer::charset_canon 'utf-8';
+ $charset_in = $charset_out = TmplTokenizer::charset_canon('utf-8');
warn "Warning: Can't determine original templates' charset, defaulting to $charset_in\n";
}
}
'help' => sub { usage(0) },
) || usage_error;
-VerboseWarnings::set_application_name $0;
-VerboseWarnings::set_pedantic_mode $pedantic_p;
+VerboseWarnings::set_application_name($0);
+VerboseWarnings::set_pedantic_mode($pedantic_p);
usage_error('Missing mandatory option -f')
unless defined $files_from || defined $convert_from;
my $input = /^\//? $_: "$directory/$_";
my $h = TmplTokenizer->new( $input );
$h->set_allow_cformat( 1 );
- VerboseWarnings::set_input_file_name $input;
+ VerboseWarnings::set_input_file_name($input);
print STDERR "$0: Processing file \"$input\"\n" if $verbose_p;
text_extract( $h );
}
# fill arrays
my @loop_data = ();
-my $tag;
# loop through each tab 0 through 9
for ( my $tabloop = 0 ; $tabloop <= 9 ; $tabloop++ ) {
my $op = $query->param('op') || '';
my $dbh = C4::Context->dbh;
-my $sth;
my ( $template, $loggedinuser, $cookie );
my $subscriptionid = $query->param('subscriptionid');
my $referer = $query->param('referer') || 'detail';
my @value = $query->multi_param('value');
$value[0] ||= q||;
- my @tags;
my $builder = Koha::SearchEngine::QueryBuilder->new(
{ index => $Koha::SearchEngine::AUTHORITIES_INDEX } );
my $searcher = Koha::SearchEngine::Search->new(
# fill arrays
my @loop_data = ();
- my $tag;
# loop through each tag
my @fields = $record->fields();
{ map { $_->{authorised_value} => $_->{opac_description} } Koha::AuthorisedValues->get_descriptions_by_koha_field( { frameworkcode => $dat->{frameworkcode}, kohafield => 'items.location' } ) };
# COinS format FIXME: for books Only
- my $coins_format;
my $fmt = substr $record->leader(), 6,2;
my $fmts;
$fmts->{'am'} = 'book';
# 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=" . uri_escape_utf8( $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} } ) {
my $selectview = $query->param('selectview');
$selectview = C4::Context->preference("SubscriptionHistory") unless $selectview;
-my $sth;
-
# my $id;
my ( $template, $loggedinuser, $cookie );
my $biblionumber = $query->param('biblionumber');
my $marcflavour = C4::Context->preference("marcflavour");
my $hits = Koha::Reviews->search({ approved => 1 })->count;
my $i = 0;
-my $latest_comment_date;
for my $result (@$reviews){
my $biblionumber = $result->{biblionumber};
my $biblio = Koha::Biblios->find( $biblionumber );
flagsrequired => { tools => 'label_creator' },
debug => 1,
});
-my $batch_id = $cgi->param('batch_id') if $cgi->param('batch_id');
+my $batch_id = $cgi->param('batch_id') || undef;
my $template_id = $cgi->param('template_id') || undef;
my $layout_id = $cgi->param('layout_id') || undef;
my $layout_back_id = $cgi->param('layout_back_id') || undef;
my $start_card = $cgi->param('start_card') || 1;
-my @label_ids = $cgi->multi_param('label_id') if $cgi->param('label_id');
-my @borrower_numbers = $cgi->multi_param('borrower_number') if $cgi->param('borrower_number');
+my @label_ids = $cgi->multi_param('label_id');
+my @borrower_numbers = $cgi->multi_param('borrower_number');
my $patronlist_id = $cgi->param('patronlist_id');
my $items = undef; # items = cards
my $batch = C4::Patroncards::Batch->retrieve(batch_id => $batch_id);
my $pc_template = C4::Patroncards::Template->retrieve(template_id => $template_id, profile_id => 1);
my $layout = C4::Patroncards::Layout->retrieve(layout_id => $layout_id);
-my $layout_back = C4::Patroncards::Layout->retrieve(layout_id => $layout_back_id) if ( $layout_back_id );
+my $layout_back = $layout_back_id ? C4::Patroncards::Layout->retrieve(layout_id => $layout_back_id) : undef;
$| = 1;
}
my $layout_xml = XMLin($layout->get_attr('layout_xml'), ForceArray => 1);
-my $layout_back_xml = XMLin($layout_back->get_attr('layout_xml'), ForceArray => 1) if ( defined $layout_back );
+my $layout_back_xml = defined $layout_back ? XMLin($layout_back->get_attr('layout_xml'), ForceArray => 1) : undef;
if ($layout_xml->{'page_side'} eq 'B') { # rearrange items on backside of page to swap columns
my $even = 1;
my $image_name = $cgi->param('image_name') || $file_name;
my $upload_file = $cgi->upload('uploadfile') || '';
my $op = $cgi->param('op') || 'none';
-my @image_ids = $cgi->multi_param('image_id') if $cgi->param('image_id');
+my @image_ids = $cgi->multi_param('image_id');
my $source_file = "$file_name"; # otherwise we end up with what amounts to a pointer to a filehandle rather than a user-friendly filename
);
my $op = $cgi->param('op') || 'none';
-my @label_ids = $cgi->multi_param('label_id') if $cgi->param('label_id'); # this will handle individual card printing; we use label_id to maintain consistency with the column names in the creator_batches table
-my @batch_ids = $cgi->multi_param('batch_id') if $cgi->param('batch_id');
+my @label_ids = $cgi->multi_param('label_id'); # this will handle individual card printing; we use label_id to maintain consistency with the column names in the creator_batches table
+my @batch_ids = $cgi->multi_param('batch_id');
my $patronlist_id = $cgi->param('patronlist_id') || undef;
my $layout_id = $cgi->param('layout_id') || undef;
my $layout_back_id = $cgi->param('layout_back_id') || undef;
my $template_id = $cgi->param('template_id') || undef;
my $start_card = $cgi->param('start_card') || 1;
-my @borrower_numbers = $cgi->multi_param('borrower_number') if $cgi->param('borrower_number');
+my @borrower_numbers = $cgi->multi_param('borrower_number');
my $output_format = $cgi->param('output_format') || 'pdf';
my $referer = $cgi->param('referer') || undef;
# setup select menus for selecting layout and template for this run...
$referer = $ENV{'HTTP_REFERER'};
$referer =~ s/^.*?:\/\/.*?(\/.*)$/$1/m;
- @batch_ids = grep{$_ = {batch_id => $_}} @batch_ids;
- @label_ids = grep{$_ = {label_id => $_}} @label_ids;
- @borrower_numbers = grep{$_ = {borrower_number => $_}} @borrower_numbers;
+ @batch_ids = map { {batch_id => $_} } @batch_ids;
+ @label_ids = map { {label_id => $_} } @label_ids;
+ @borrower_numbers = map { {borrower_number => $_} } @borrower_numbers;
$templates = get_all_templates( { fields => [qw( template_id template_code ) ], filters => { creator => "Patroncards" } });
$layouts = get_all_layouts({ fields => [ qw( layout_id layout_name ) ], filters => { creator => "Patroncards" } });
$output_formats = get_output_formats();
my $uploadlocation = $input->param('uploadlocation');
my $op = $input->param('op') || q{};
-my ( $total, $handled, @counts, $tempfile, $tfh );
+my ( $tempfile, $tfh );
my %errors;
}
my $i = 0;
- my @totalcol;
my $hilighted = -1;
#Initialization of cell values.....
=cut
-$debug and open DEBUG, ">/tmp/bor_issues_top.debug.log";
+$debug and open my $debugfh, '>', '/tmp/bor_issues_top.debug.log';
my $input = new CGI;
my $fullreportname = "reports/bor_issues_top.tt";
}
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 DEBUG "bor_issues_top (old_issues) SQL: $strsth2\n";
+ $debug and print $debugfh "bor_issues_top (old_issues) SQL: $strsth2\n";
my $sth2 = $dbh->prepare($strsth2);
$sth2->execute;
- print DEBUG "rows: ", $sth2->rows, "\n";
+ print $debugfh "rows: ", $sth2->rows, "\n";
while (my @row = $sth2->fetchrow) {
$columns{($row[0] ||'NULL')}++;
push @loopcol, { coltitle => $row[0] || 'NULL' };
}
$strsth2 =~ s/old_issues/issues/g;
- $debug and print DEBUG "bor_issues_top (issues) SQL: $strsth2\n";
+ $debug and print $debugfh "bor_issues_top (issues) SQL: $strsth2\n";
$sth2 = $dbh->prepare($strsth2);
$sth2->execute;
- $debug and print DEBUG "rows: ", $sth2->rows, "\n";
+ $debug and print $debugfh "rows: ", $sth2->rows, "\n";
while (my @row = $sth2->fetchrow) {
$columns{($row[0] ||'NULL')}++;
push @loopcol, { coltitle => $row[0] || 'NULL' };
}
- $debug and print DEBUG "full array: ", Dumper(\%columns), "\n";
+ $debug and print $debugfh "full array: ", Dumper(\%columns), "\n";
}else{
$columns{''} = 1;
}
$strcalc .= ",$colfield " if ($colfield);
$strcalc .= " LIMIT $limit" if ($limit);
- $debug and print DEBUG "(old_issues) SQL : $strcalc\n";
+ $debug and print $debugfh "(old_issues) SQL : $strcalc\n";
my $dbcalc = $dbh->prepare($strcalc);
$dbcalc->execute;
- $debug and print DEBUG "rows: ", $dbcalc->rows, "\n";
+ $debug and print $debugfh "rows: ", $dbcalc->rows, "\n";
my %patrons = ();
# DATA STRUCTURE is going to look like this:
# (2253=> {name=>"John Doe",
use Data::Dumper;
$strcalc =~ s/old_issues/issues/g;
- $debug and print DEBUG "(issues) SQL : $strcalc\n";
+ $debug and print $debugfh "(issues) SQL : $strcalc\n";
$dbcalc = $dbh->prepare($strcalc);
$dbcalc->execute;
- $debug and print DEBUG "rows: ", $dbcalc->rows, "\n";
+ $debug and print $debugfh "rows: ", $dbcalc->rows, "\n";
while (my @data = $dbcalc->fetchrow) {
my ($row, $rank, $id, $col) = @data;
$col = "zzEMPTY" if (!defined($col));
$patrons{$id}->{total} += $count;
}
}
- $debug and print DEBUG "\n\npatrons: ", Dumper(\%patrons);
+ $debug and print $debugfh "\n\npatrons: ", Dumper(\%patrons);
my $i = 1;
my @cols_in_order = sort keys %columns; # if you want to order the columns, do something here
return [\%globalline]; # reference to a 1 element array: that element is a hashref
}
-$debug and close DEBUG;
+$debug and close $debugfh;
1;
__END__
# Displaying choices
} else {
my $dbh = C4::Context->dbh;
- my @values;
- 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;
sub calculate {
my ( $limit, $column, $filters ) = @_;
- my @loopline;
- my @looprow;
my %globalline;
my %columns = ();
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 { defined($_) and s/\*/%/g; $_ } @$filters;
+ @$filters = map { my $f = $_; defined($f) and $f =~ s/\*/%/g; $f } @$filters;
$strcalc .= " AND statistics.datetime >= '" . @$filters[0] . "'" if ( @$filters[0] );
$strcalc .= " AND statistics.datetime <= '" . @$filters[1] . " 23:59:59'" if ( @$filters[1] );
$strcalc .= " AND borrowers.categorycode LIKE '" . @$filters[2] . "'" if ( @$filters[2] );
}
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 $key (keys %configuration) {
+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] & 07777;
-my $new_perm = $old_perm | 0200;
+$old_perm = (stat $fname)[2] & oct(7777);
+my $new_perm = $old_perm | oct(200);
chmod $new_perm, $fname;
-open(OUTPUT,">$fname") || die "Can't open $fname for write: $!";
-print OUTPUT $file;
-close(OUTPUT);
+open(my $output, ">", $fname) || die "Can't open $fname for write: $!";
+print $output $file;
+close($output);
chmod $old_perm, $fname;
# Idea taken from perlfaq5
-sub read_file($) {
- local(*INPUT,$/);
- open(INPUT,$_[0]) || die "Can't open $_[0] for read";
- my $file = <INPUT>;
+sub read_file {
+ local $/;
+ open(my $fh , '<', $_[0]) || die "Can't open $_[0] for read";
+ my $file = <$fh>;
+ close $fh;
return $file;
}
}
);
-my $borrower;
my @holds;
while ( my $h = $holds_rs->next() ) {
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 );
}
-my $rcfile = File::Spec->catfile( 't', 'perlcriticrc' );
-Test::Perl::Critic->import( -profile => $rcfile);
-all_critic_ok(@dirs);
-
+Test::Perl::Critic->import( -profile => '.perlcriticrc');
+all_critic_ok('.');
preference => sub {
my ($self, $pref) = @_;
if ($return_undef) {
- return undef;
+ return;
} elsif ($pref =~ /language/) {
return join ',', @languages;
} else {
my $bookseller_module = Test::MockModule->new('Koha::Acquisition::Bookseller');
-my ( $basketno_0_0, $basketno_1_1, $basketno_1_0, $basketno_0_1 );
-my ( $invoiceid_0_0, $invoiceid_1_1, $invoiceid_1_0, $invoiceid_0_1 );
+my ( $basketno_0_0, $basketno_1_1 );
+my ( $invoiceid_0_0, $invoiceid_1_1 );
my $today;
for my $currency_format ( qw( US FR ) ) {
my $plugindir = File::Spec->rel2abs('Koha/SuggestionEngine/Plugin');
opendir(my $dh, $plugindir);
-my @installed_plugins = map { ( /\.pm$/ && -f "$plugindir/$_" && s/\.pm$// ) ? "Koha::SuggestionEngine::Plugin::$_" : () } readdir($dh);
+my @installed_plugins = map { my $p = $_; ( $p =~ /\.pm$/ && -f "$plugindir/$p" && $p =~ s/\.pm$// ) ? "Koha::SuggestionEngine::Plugin::$p" : () } readdir($dh);
my @available_plugins = Koha::SuggestionEngine::AvailablePlugins();
foreach my $plugin (@installed_plugins) {
$dbh->do(q|DELETE FROM borrowers|);
my $branchcode = $library->{branchcode};
-my $borrower_number;
my $context = new Test::MockModule('C4::Context');
$context->mock( 'userenv', sub {
)->store;
my ($biblionumber, $biblioitemnumber) = AddBiblio(MARC::Record->new, '');
-my $budgetid;
my $bpid = AddBudgetPeriod({
budget_period_startdate => '2015-01-01',
budget_period_enddate => '2015-12-31',
);
die unless $subscriptionid;
-my ($basket, $basketno);
+my $basketno;
ok($basketno = NewBasket($bookseller->id, 1), "NewBasket( " . $bookseller->id . ", 1 ) returns $basketno");
my $cost = 42.00;
);
my $budget = C4::Budgets::GetBudget($budgetid);
-my @ordernumbers;
my ( $biblionumber, $biblioitemnumber ) = C4::Biblio::AddBiblio( MARC::Record->new, '' );
my $order = Koha::Acquisition::Order->new(
EAN13 => ['0000000695152','892685001928'],
);
-my ($obj1,$obj2,$format,$value,$initial,$serial,$re,$next,$previous,$temp);
+my ($obj1,$obj2,$format,$value,$initial,$serial,$next,$previous,$temp);
my @formats = sort keys %thash;
foreach (@formats) {
my $pre = sprintf '(%-12s)', $_;
}
}
-foreach $format (@formats) {
+foreach my $format (@formats) {
my $pre = sprintf '(%-12s)', $format;
foreach my $testval (@{$thash{ $format }}) {
if ($format eq 'hbyymmincr') {
# Testing syspref caching
use Test::DBIx::Class;
-my $history;
-
my $schema = Koha::Database->new()->schema();
$schema->storage->debug(1);
my $trace_read;
$hold->store();
my $b1_cal = C4::Calendar->new( branchcode => $branches[1]->{branchcode} );
-$b1_cal->insert_single_holiday( day => 02, month => 01, year => 2017, title => "Morty Day", description => "Rick" ); #Add a holiday
+$b1_cal->insert_single_holiday( day => 2, month => 1, year => 2017, title => "Morty Day", description => "Rick" ); #Add a holiday
my $today = dt_from_string;
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");
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");
}
sub recursive_breakdown {
- my $dse = shift or return undef;
+ my $dse = shift or return;
if (ref($dse) =~ /HASH/) {
return join "\n", map {"$_\t=> " . recursive_breakdown($dse->{$_})} keys %$dse;
} elsif (ref($dse) =~ /ARRAY/) {
ok (1, 'module compiled');
# open some files for testing
-open MARC21MARC8,WHEREAMI."/marc21_marc8.dat" or die $!;
+open my $MARC21MARC8, '<', WHEREAMI."/marc21_marc8.dat" or die $!;
my $marc21_marc8; # = scalar (MARC21MARC8);
-foreach my $line (<MARC21MARC8>) {
+foreach my $line (<$MARC21MARC8>) {
$marc21_marc8 .= $line;
}
$marc21_marc8 =~ s/\n$//;
-close MARC21MARC8;
+close $MARC21MARC8;
-open (MARC21UTF8,"<:utf8",WHEREAMI."/marc21_utf8.dat") or die $!;
+open (my $MARC21UTF8, '<:encoding(UTF-8)', WHEREAMI."/marc21_utf8.dat") or die $!;
my $marc21_utf8;
-foreach my $line (<MARC21UTF8>) {
+foreach my $line (<$MARC21UTF8>) {
$marc21_utf8 .= $line;
}
$marc21_utf8 =~ s/\n$//;
-close MARC21UTF8;
+close $MARC21UTF8;
-open MARC21MARC8COMBCHARS,WHEREAMI."/marc21_marc8_combining_chars.dat" or die $!;
+open(my $MARC21MARC8COMBCHARS, '<', WHEREAMI."/marc21_marc8_combining_chars.dat" or die $!;
my $marc21_marc8_combining_chars;
-foreach my $line(<MARC21MARC8COMBCHARS>) {
+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;
+close $MARC21MARC8COMBCHARS;
-open (MARC21UTF8COMBCHARS,"<:utf8",WHEREAMI."/marc21_utf8_combining_chars.dat") or die $!;
+open (my $MARC21UTF8COMBCHARS, '<:encoding(UTF-8)', WHEREAMI."/marc21_utf8_combining_chars.dat") or die $!;
my $marc21_utf8_combining_chars;
-foreach my $line(<MARC21UTF8COMBCHARS>) {
+foreach my $line(<$MARC21UTF8COMBCHARS>) {
$marc21_utf8_combining_chars.=$line;
}
-close MARC21UTF8COMBCHARS;
+close $MARC21UTF8COMBCHARS;
-open (MARCXMLUTF8,"<:utf8",WHEREAMI."/marcxml_utf8.xml") or die $!;
+open (my $MARCXMLUTF8, '<:encoding(UTF-8)', WHEREAMI."/marcxml_utf8.xml") or die $!;
my $marcxml_utf8;
-foreach my $line (<MARCXMLUTF8>) {
+foreach my $line (<$MARCXMLUTF8>) {
$marcxml_utf8 .= $line;
}
-close MARCXMLUTF8;
+close $MARCXMLUTF8;
$marcxml_utf8 =~ s/\n//g;
## The Tests:
-my $error; my $marc; my $marcxml; my $dcxml; # some scalars to store values
+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;
my ($biblionumber, $biblioitemnumber) = AddBiblio(MARC::Record->new, '');
-my $budgetid;
my $bpid = AddBudgetPeriod({
budget_period_startdate => '2015-01-01',
budget_period_enddate => '2015-12-31',
my $my_branch = $library1->{branchcode};
my $another_branch = $library2->{branchcode};
-my $budgetid;
my $bpid = AddBudgetPeriod({
budget_period_startdate => '2015-01-01',
budget_period_enddate => '2015-12-31',
$search_module->mock('simple_search_compat', \&Mock_simple_search_compat );
-my $errors;
my $context = C4::Context->new;
my ( $biblionumber_tag, $biblionumber_subfield ) =
my $script = shift;
local @ARGV = @_;
- ## no critic
-
# We simulate script execution by evaluating the script code in the context
# of this unit test.
- eval $script; #Violates 'ProhibitStringyEval'
-
- ## use critic
+ eval $script; ## no critic (StringyEval)
die $@ if $@;
}
$intranet =~ s#/$##;
my $agent = Test::WWW::Mechanize->new( autocheck => 1 );
-my $jsonresponse;
my ($category, $expected_base, $add_form_link_exists, $delete_form_link_exists);
# -------------------------------------------------- LOGIN
# Dummy test until Test::Harness or similar
# is used by the other tests to check deps.
+use Modern::Perl;
print "1..1\nok 1\n";
my $script_name = "/cgi-bin/koha/tags/review.pl";
my $needed_flags = { tools => 'moderate_tags' }; # FIXME: replace when more specific permission is created.
-sub ajax_auth_cgi ($) { # returns CGI object
+sub ajax_auth_cgi { # returns CGI object
my $needed_flags = shift;
my %cookies = CGI::Cookie->fetch;
my $input = CGI->new;
$template->param($_ => $counts->{$_});
}
-sub pagination_calc ($;$) {
- my $query = shift or return undef;
+sub pagination_calc {
+ my $query = shift or return;
my $hardlimit = (@_) ? shift : 100; # hardcoded, could be another syspref
my $pagesize = $query->param('limit' ) || $hardlimit;
my $page = $query->param('page' ) || 1;
$template->param(del => $del);
-my $itemrecord;
my $nextop="";
my @errors; # store errors found while checking data BEFORE saving item.
my $items_display_hashref;
$subfield_data{marc_lib} ="<span id=\"error$i\" title=\"".$tagslib->{$tag}->{$subfield}->{lib}."\">".$tagslib->{$tag}->{$subfield}->{lib}."</span>";
$subfield_data{mandatory} = $tagslib->{$tag}->{$subfield}->{mandatory};
$subfield_data{repeatable} = $tagslib->{$tag}->{$subfield}->{repeatable};
- my ($x,$value);
+ my $value;
if ( $use_default_values) {
$value = $tagslib->{$tag}->{$subfield}->{defaultvalue};
# get today date & replace YYYY, MM, DD if provided in the default value
my @biblionumbers = $query->multi_param("biblionumbers");
my @itemnumbers = $query->multi_param("itemnumbers");
my $strip_items_not_from_libraries = $query->param('strip_items_not_from_libraries');
- my @sql_params;
- my $sql_query;
my $libraries = Koha::Libraries->search_filtered->unblessed;
my $only_export_items_for_branches = $strip_items_not_from_libraries ? \@branch : undef;
use CGI qw ( -utf8 );
-my ( @errors, @feedback );
my $extended = C4::Context->preference('ExtendedPatronAttributes');
my @columnkeys = map { $_ ne 'borrowernumber' ? $_ : () } Koha::Patrons->columns();
my $input = CGI->new();
-#push @feedback, {feedback=>1, name=>'backend', value=>$csv->backend, backend=>$csv->backend}; #XXX
-
my ( $template, $loggedinuser, $cookie ) = get_template_and_user(
{
template_name => "tools/import_borrowers.tt",
code => $code,
);
my $first_flag_name = 1;
- my ( $lang, @templates );
+ my $lang;
# The letter name is contained into each mtt row.
# So we can only sent the first one to the template.
for my $letter ( @$letters ) {
my $patron_list_id = $input->param('patron_list_id');
my @borrowers;
my @cardnumbers;
- my ( @notfoundcardnumbers, @from_another_group_of_libraries );
+ my @notfoundcardnumbers;
# Get cardnumbers from a file or the input area
- my @contentlist;
if ($filefh) {
while ( my $content = <$filefh> ) {
$content =~ s/[\r\n]*$//g;
}
);
-my @line_loop;
-
my $message_transport_types = C4::Letters::GetMessageTransportTypes();
my ( @first, @second, @third );
for my $patron_category (@patron_categories) {
if ( $filename =~ m/datalink\.txt/i
|| $filename =~ m/idlink\.txt/i );
}
- unless ( open( FILE, $file ) ) {
+ 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 = <FILE> ) {
+ 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 FILE;
+ close $fh;
closedir DIR;
}
else {
return %count;
}
my ( $srcimage, $image );
- if ( open( IMG, "$source" ) ) {
- $srcimage = GD::Image->new(*IMG);
- close(IMG);
+ 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 ) {
else {
next;
}
- if ( open( FILE, $file ) ) {
- while ( my $line = <FILE> ) {
+ if ( open( my $fh, '<', $file ) ) {
+ while ( my $line = <$fh> ) {
my $delim =
( $line =~ /\t/ ) ? "\t"
: ( $line =~ /,/ ) ? ","
undef $srcimage;
}
}
- close(FILE);
+ close($fh);
}
else {
$error = 'OPNLINK';
scalar(@ARGV) == 1 or die "Usage: $0 template-file\n";
my $file = $ARGV[0];
-open IN, $file or die "Failed to open template file $file: $!\n";
+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 (<IN>) {
+while (<$fh>) {
$lineno++;
# look for TMPL_IF, TMPL_ELSE, TMPL_UNLESS, and TMPL_LOOPs in HTML comments
}
}
-close IN;
+close $fh;
# anything left in the stack?
if (scalar @tag_stack > 0) {
my $command = "PERL5LIB=\$PERL5LIB:$misc_translator_dir ./tmpl_process3.pl create -i $template_dir -s $po_dir/$module.po -r --pedantic-warnings";
- open (NULL, ">", File::Spec->devnull);
+ open (NULL, ">", File::Spec->devnull); ## no critic (BarewordFileHandles)
print NULL "foo"; # avoid warning;
my $pid = open3(gensym, ">&NULL", \*PH, $command);
my @warnings;
find({ wanted => \&wanted, no_chdir => 1 }, File::Spec->curdir());
foreach my $name (@files) {
- open( FILE, $name ) || die "cannot open file $name $!";
+ open( my $fh, '<', $name ) || die "cannot open file $name $!";
my ( $hascopyright, $hasgpl, $hasv3, $hasorlater, $haslinktolicense,
$hasfranklinst, $is_not_us ) = (0)x7;
- while ( my $line = <FILE> ) {
+ while ( my $line = <$fh> ) {
$hascopyright = 1 if ( $line =~ /^(#|--)?\s*Copyright.*\d\d/ );
$hasgpl = 1 if ( $line =~ /GNU General Public License/ );
$hasv3 = 1 if ( $line =~ /either version 3/ );
$hasfranklinst = 1 if ( $line =~ /51 Franklin Street/ );
$is_not_us = 1 if $line =~ m|This file is part of the Zebra server|;
}
+ close $fh;
next unless $hascopyright;
next if $is_not_us;
is( $hasgpl
sub readfile {
my ($filename) = @_;
- open(FILE, $filename) || die("Can't open $filename for reading");
+ open(my $fh, '<', $filename) || die("Can't open $filename for reading");
my @lines;
- while (my $line = <FILE>) {
+ while (my $line = <$fh>) {
push @lines, $line;
}
- close(FILE);
+ close($fh);
return join '', @lines;
}
sub try_to_fix {
my ($data, @patterns) = @_;
- return undef;
+ return;
}
my @files;
find(
sub {
- open my $fh, $_ or die "Could not open $_: $!";
+ open my $fh, '<', $_ or die "Could not open $_: $!";
my @lines = sort grep /\_\(\'/, <$fh>;
push @files, { name => "$_", lines => \@lines } if @lines;
},
projects / koha-equinox.git / commitdiff