[libcatmandu-marc-perl] 184/208: Fixing double Fix execution bug
Jonas Smedegaard
dr at jones.dk
Sat Oct 28 03:42:48 UTC 2017
This is an automated email from the git hooks/post-receive script.
js pushed a commit to annotated tag upstream/1.19
in repository libcatmandu-marc-perl.
commit 99be23a42e2c5980e547d976935d5ca39fc2cd45
Author: Patrick Hochstenbach <patrick.hochstenbach at ugent.be>
Date: Wed Jul 12 10:55:28 2017 +0200
Fixing double Fix execution bug
---
Build.PL | 2 +-
Changes | 1 +
cpanfile | 2 +-
lib/Catmandu/Fix/marc_cut.pm | 137 ++++++++++++
lib/Catmandu/Importer/MARC.pm | 37 ++--
lib/Catmandu/Importer/MARC/XML.pm | 2 +-
lib/Catmandu/MARC.pm | 28 ++-
t/{26_marc_replace_all.t => 27-marc_replace_all.t} | 0
t/{27_marc_append.t => 28-marc_append.t} | 0
t/{28_marc_paste.t => 29-marc_paste.t} | 0
t/30-marc_cut.t | 233 +++++++++++++++++++++
11 files changed, 419 insertions(+), 23 deletions(-)
diff --git a/Build.PL b/Build.PL
index a929a05..2960a09 100644
--- a/Build.PL
+++ b/Build.PL
@@ -24,7 +24,7 @@ my %module_build_args = (
"recursive_test_files" => 1,
"requires" => {
"Carp" => 0,
- "Catmandu" => "1.0601",
+ "Catmandu" => "1.0602",
"JSON::XS" => "2.3",
"List::Util" => 0,
"MARC::File::MARCMaker" => "0.05",
diff --git a/Changes b/Changes
index 2d4d03c..9e19097 100644
--- a/Changes
+++ b/Changes
@@ -2,6 +2,7 @@ Revision history for Catmandu-MARC
{{$NEXT}}
- Fixing 0 as false bug when using from/until
+ - Fixing double fix execution bug
1.161 2017-07-06 14:36:29 CEST
- Fixing marc_replace_all evaluating search groups
diff --git a/cpanfile b/cpanfile
index e5514c0..39cf507 100644
--- a/cpanfile
+++ b/cpanfile
@@ -12,7 +12,7 @@ on 'test', sub {
};
requires 'Carp', '0';
-requires 'Catmandu', '>=1.0601';
+requires 'Catmandu', '>=1.0602';
requires 'JSON::XS', '2.3';
requires 'YAML::XS', '0.34';
requires 'List::Util', '0';
diff --git a/lib/Catmandu/Fix/marc_cut.pm b/lib/Catmandu/Fix/marc_cut.pm
new file mode 100644
index 0000000..fa33345
--- /dev/null
+++ b/lib/Catmandu/Fix/marc_cut.pm
@@ -0,0 +1,137 @@
+package Catmandu::Fix::marc_cut;
+
+use Catmandu::Sane;
+use Catmandu::MARC;
+use Moo;
+use Catmandu::Fix::Has;
+
+with 'Catmandu::Fix::Base';
+
+our $VERSION = '1.13';
+
+has marc_path => (fix_arg => 1);
+has path => (fix_arg => 1);
+has equals => (fix_opt => 1);
+
+sub emit {
+ my ($self,$fixer) = @_;
+ my $path = $fixer->split_path($self->path);
+ my $key = $path->[-1];
+ my $marc_obj = Catmandu::MARC->instance;
+
+ # Precompile the marc_path to gain some speed
+ my $marc_context = $marc_obj->compile_marc_path($self->marc_path, subfield_wildcard => 0);
+ my $marc = $fixer->capture($marc_obj);
+ my $marc_path = $fixer->capture($marc_context);
+ my $equals = $fixer->capture($self->equals);
+
+ my $var = $fixer->var;
+ my $result = $fixer->generate_var;
+ my $current_value = $fixer->generate_var;
+
+ my $perl = "";
+ $perl .= $fixer->emit_declare_vars($current_value, "[]");
+ $perl .=<<EOF;
+if (my ${result} = ${marc}->marc_copy(
+ ${var},
+ ${marc_path},
+ ${equals},1) ) {
+ ${result} = ref(${result}) ? ${result} : [${result}];
+ for ${current_value} (\@{${result}}) {
+EOF
+
+ $perl .= $fixer->emit_create_path(
+ $var,
+ $path,
+ sub {
+ my $var2 = shift;
+ "${var2} = ${current_value}"
+ }
+ );
+
+ $perl .=<<EOF;
+ }
+}
+EOF
+ $perl;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Catmandu::Fix::marc_cut - cut marc data in a structured way to a new field
+
+=head1 SYNOPSIS
+
+ # Cut the 001 field out of the MARC record into the fixed001
+ marc_cut(001, fixed001)
+
+ # Cut all 650 fields out of the MARC record into the subjects array
+ marc_cut(650, subjects)
+
+=head1 DESCRIPTION
+
+This Fix work like L<Catmandu::Fix::marc_copy> except it will also remove all
+mathincg fields from the MARC record
+
+=head1 METHODS
+
+=head2 marc_cut(MARC_PATH, JSON_PATH, [equals: REGEX])
+
+Cut this MARC fields referred by a MARC_PATH to a JSON_PATH.
+
+When the MARC_PATH points to a MARC tag then only the fields mathching the MARC
+tag will be copied. When the MATCH_PATH contains indicators or subfields, then
+only the MARC_FIELDS which contain data in these subfields will be copied. Optional,
+a C<equals> regular expression can be provided that should match the subfields that
+need to be copied:
+
+ # Cut all the 300 fields
+ marc_cut(300,tmp)
+
+ # Cut all the 300 fields with indicator 1 = 1
+ marc_cut(300[1],tmp)
+
+ # Cut all the 300 fields which have subfield c
+ marc_cut(300c,tmp)
+
+ # Cut all the 300 fields which have subfield c equal to 'ABC'
+ marc_cut(300c,tmp,equal:"^ABC")
+
+=head1 INLINE
+
+This Fix can be used inline in a Perl script:
+
+ use Catmandu::Fix::marc_copy as => 'marc_cut';
+
+ my $data = { record => ['650', ' ', 0, 'a', 'Perl'] };
+
+ $data = marc_cut($data,'650','subject');
+
+ print $data->{subject}->[0]->{tag} , "\n"; # '650'
+ print $data->{subject}->[0]->{ind1} , "\n"; # ' '
+ print $data->{subject}->[0]->{ind2} , "\n"; # 0
+ print $data->{subject}->[0]->{subfields}->[0]->{a} , "\n"; # 'Perl'
+
+=head1 SEE ALSO
+
+=over
+
+=item * L<Catmandu::Fix::marc_copy>
+
+=item * L<Catmandu::Fix::marc_paste>
+
+=back
+
+=head1 LICENSE AND COPYRIGHT
+
+This program is free software; you can redistribute it and/or modify it
+under the terms of either: the GNU General Public License as published
+by the Free Software Foundation; or the Artistic License.
+
+See http://dev.perl.org/licenses/ for more information.
+
+=cut
diff --git a/lib/Catmandu/Importer/MARC.pm b/lib/Catmandu/Importer/MARC.pm
index de29096..688f6aa 100644
--- a/lib/Catmandu/Importer/MARC.pm
+++ b/lib/Catmandu/Importer/MARC.pm
@@ -6,33 +6,38 @@ use Moo;
our $VERSION = '1.161';
has type => (is => 'ro' , default => sub { 'ISO' });
-has _importer => (is => 'ro' , lazy => 1 , builder => '_build_importer' , handles => ['generator']);
-has _importer_args => (is => 'rwp', writer => '_set_importer_args');
+has _importer => (is => 'ro');
with 'Catmandu::Importer';
-sub _build_importer {
- my ($self) = @_;
+sub BUILD {
+ my ($self,$args) = @_;
my $type = $self->type;
- $type = 'Record' if exists $self->_importer_args->{records};
+ # keep USMARC temporary as alias for ISO, remove in future version
+ # print deprecation warning
+ if ($type eq 'USMARC') {
+ $type = 'ISO';
+ warn( "deprecated", "Oops! Importer \"USMARC\" is deprecated. Use \"ISO\" instead." );
+ }
+
+ if (exists $args->{records}) {
+ $type = 'Record';
+ }
my $pkg = Catmandu::Util::require_package($type,'Catmandu::Importer::MARC');
- $pkg->new($self->_importer_args);
-}
+ delete $args->{file};
+ delete $args->{type};
+ delete $args->{fix};
-sub BUILD {
- my ($self,$args) = @_;
- $self->_set_importer_args($args);
+ $self->{_importer} = $pkg->new(file => $self->file , type => $type, %$args);
+}
- # keep USMARC temporary as alias for ISO, remove in future version
- # print deprecation warning
- if ($self->{type} eq 'USMARC') {
- $self->{type} = 'ISO';
- warn( "deprecated", "Oops! Importer \"USMARC\" is deprecated. Use \"ISO\" instead." );
- }
+sub generator {
+ my ($self) = @_;
+ $self->_importer->generator;
}
1;
diff --git a/lib/Catmandu/Importer/MARC/XML.pm b/lib/Catmandu/Importer/MARC/XML.pm
index e81e48b..ab31449 100644
--- a/lib/Catmandu/Importer/MARC/XML.pm
+++ b/lib/Catmandu/Importer/MARC/XML.pm
@@ -88,7 +88,7 @@ sub generator {
# MARC::File doesn't provide support for inline files
$file = $self->decoder->fake_marc_file($self->fh,'MARC::File::XML') unless $file;
-
+
sub {
$self->decoder->decode($file->next(),$self->id);
}
diff --git a/lib/Catmandu/MARC.pm b/lib/Catmandu/MARC.pm
index 2693c8d..170d7c1 100644
--- a/lib/Catmandu/MARC.pm
+++ b/lib/Catmandu/MARC.pm
@@ -1043,6 +1043,7 @@ sub marc_copy {
my $data = $_[1];
my $marc_path = $_[2];
my $marc_value = $_[3];
+ my $is_cut = $_[4];
# $_[2] : marc_path
my $context = ref($marc_path) ? $marc_path : $self->compile_marc_path($_[2], subfield_wildcard => 0);
@@ -1054,24 +1055,32 @@ sub marc_copy {
return wantarray ? () : undef unless (defined $record && ref($record) eq 'ARRAY');
+ # When is_cut is on, we need to create a new record containing the remaining fields
+ my @new_record = ();
+
my $fields = [];
for my $field (@$record) {
my ($tag, $ind1, $ind2, @subfields) = @$field;
- next if (
+ if (
($context->{is_regex_field} == 0 && $tag ne $context->{field} )
||
($context->{is_regex_field} == 1 && $tag !~ $context->{field_regex} )
- );
+ ) {
+ push @new_record , $field if $is_cut;
+ next;
+ }
if (defined $context->{ind1}) {
if (!defined $ind1 || $ind1 ne $context->{ind1}) {
+ push @new_record , $field if $is_cut;
next;
}
}
if (defined $context->{ind2}) {
if (!defined $ind2 || $ind2 ne $context->{ind2}) {
+ push @new_record , $field if $is_cut;
next;
}
}
@@ -1088,7 +1097,11 @@ sub marc_copy {
}
}
}
- next unless $found;
+
+ unless ($found) {
+ push @new_record , $field if $is_cut;
+ next;
+ }
}
else {
if (defined($marc_value)) {
@@ -1099,7 +1112,10 @@ sub marc_copy {
my $string = join "", @sf;
- next unless ($string =~ /$marc_value/);
+ unless ($string =~ /$marc_value/) {
+ push @new_record , $field if $is_cut;
+ next;
+ }
}
}
@@ -1135,6 +1151,10 @@ sub marc_copy {
push(@$fields, $f);
}
+ if ($is_cut) {
+ $data->{record} = \@new_record;
+ }
+
[$fields];
}
diff --git a/t/26_marc_replace_all.t b/t/27-marc_replace_all.t
similarity index 100%
rename from t/26_marc_replace_all.t
rename to t/27-marc_replace_all.t
diff --git a/t/27_marc_append.t b/t/28-marc_append.t
similarity index 100%
rename from t/27_marc_append.t
rename to t/28-marc_append.t
diff --git a/t/28_marc_paste.t b/t/29-marc_paste.t
similarity index 100%
rename from t/28_marc_paste.t
rename to t/29-marc_paste.t
diff --git a/t/30-marc_cut.t b/t/30-marc_cut.t
new file mode 100644
index 0000000..12aae35
--- /dev/null
+++ b/t/30-marc_cut.t
@@ -0,0 +1,233 @@
+use strict;
+use warnings;
+use Test::More;
+use Test::Exception;
+use Test::Warn;
+use Catmandu;
+
+my $mrc = <<'MRC';
+<?xml version="1.0" encoding="UTF-8"?>
+<marc:collection xmlns:marc="http://www.loc.gov/MARC21/slim">
+ <marc:record>
+ <marc:controlfield tag="001"> 92005291 </marc:controlfield>
+ <marc:datafield ind1="1" ind2="0" tag="245">
+ <marc:subfield code="a">Title / </marc:subfield>
+ <marc:subfield code="c">Name</marc:subfield>
+ </marc:datafield>
+ <marc:datafield ind1=" " ind2=" " tag="999">
+ <marc:subfield code="a">X</marc:subfield>
+ <marc:subfield code="a">Y</marc:subfield>
+ </marc:datafield>
+ <marc:datafield ind1=" " ind2=" " tag="999">
+ <marc:subfield code="a">Z</marc:subfield>
+ </marc:datafield>
+ </marc:record>
+</marc:collection>
+MRC
+
+note 'marc_cut(001,cntrl)';
+{
+ my $importer = Catmandu->importer(
+ 'MARC',
+ file => \$mrc,
+ type => 'XML',
+ fix => 'marc_cut(001,cntrl)'
+ );
+ my $record = $importer->first;
+
+ is_deeply $record->{cntrl},
+ [
+ {
+ tag => '001',
+ ind1 => undef,
+ ind2 => undef,
+ content => " 92005291 "
+ }
+ ], 'marc_cut(001,cntrl)';
+
+ ok ! marc_has($record,'001') , '001 deleted';
+}
+
+note 'marc_cut(245,title)';
+{
+ my $importer = Catmandu->importer(
+ 'MARC',
+ file => \$mrc,
+ type => 'XML',
+ fix => 'marc_cut(245,title)'
+ );
+ my $record = $importer->first;
+ is_deeply $record->{title},
+ [
+ {
+ tag => '245',
+ ind1 => '1',
+ ind2 => '0',
+ subfields => [
+ { a => 'Title / '},
+ { c => 'Name' },
+ ]
+ }
+ ], 'marc_map(245,title)';
+
+ ok ! marc_has($record,'245') , '245 deleted';
+}
+
+note 'marc_cut(245a,title)';
+{
+ my $importer = Catmandu->importer(
+ 'MARC',
+ file => \$mrc,
+ type => 'XML',
+ fix => 'marc_cut(245a,title)'
+ );
+ my $record = $importer->first;
+ is_deeply $record->{title},
+ [
+ {
+ tag => '245',
+ ind1 => '1',
+ ind2 => '0',
+ subfields => [
+ { a => 'Title / '},
+ { c => 'Name' },
+ ]
+ }
+ ], 'marc_map(245a,title)';
+ ok ! marc_has($record,'245') , '245 deleted';
+}
+
+note 'marc_cut(245x,title)';
+{
+ my $importer = Catmandu->importer(
+ 'MARC',
+ file => \$mrc,
+ type => 'XML',
+ fix => 'marc_cut(245x,title)'
+ );
+ my $record = $importer->first;
+ is_deeply $record->{title},
+ [
+ ], 'marc_map(245x,title)';
+ ok marc_has($record,'245') , '245 still exists';
+}
+
+note 'marc_cut(245a,title,equals:"Title / ")';
+{
+ my $importer = Catmandu->importer(
+ 'MARC',
+ file => \$mrc,
+ type => 'XML',
+ fix => 'marc_cut(245a,title,equals:"Title / ");'
+ );
+ my $record = $importer->first;
+ is_deeply $record->{title},
+ [
+ {
+ tag => '245',
+ ind1 => '1',
+ ind2 => '0',
+ subfields => [
+ { a => 'Title / '},
+ { c => 'Name' },
+ ]
+ }
+ ], 'marc_map(245a,title,equals:"Title / ")';
+ ok ! marc_has($record,'245') , '245 deleted';
+}
+
+note 'marc_cut(999,local)';
+{
+ my $importer = Catmandu->importer(
+ 'MARC',
+ file => \$mrc,
+ type => 'XML',
+ fix => 'marc_cut(999,local)'
+ );
+ my $record = $importer->first;
+ is_deeply $record->{local},
+ [
+ {
+ tag => '999',
+ ind1 => ' ',
+ ind2 => ' ',
+ subfields => [
+ { a => 'X'},
+ { a => 'Y'}
+ ]
+ },
+ {
+ tag => '999',
+ ind1 => ' ',
+ ind2 => ' ',
+ subfields => [
+ { a => 'Z'}
+ ]
+ }
+ ], 'marc_cut(999,local)';
+ ok ! marc_has($record,'999') , '999 deleted';
+}
+
+note 'marc_cut(...,all)';
+{
+ my $importer = Catmandu->importer(
+ 'MARC',
+ file => \$mrc,
+ type => 'XML',
+ fix => 'marc_cut(...,all);'
+ );
+ my $record = $importer->first;
+ is_deeply $record->{all},
+ [
+ {
+ tag => 'LDR',
+ ind1 => undef,
+ ind2 => undef,
+ content => " "
+ },
+ {
+ tag => '001',
+ ind1 => undef,
+ ind2 => undef,
+ content => " 92005291 "
+ },
+ {
+ tag => '245',
+ ind1 => '1',
+ ind2 => '0',
+ subfields => [
+ { a => 'Title / '},
+ { c => 'Name' },
+ ]
+ },
+ {
+ tag => '999',
+ ind1 => ' ',
+ ind2 => ' ',
+ subfields => [
+ { a => 'X'},
+ { a => 'Y'}
+ ]
+ },
+ {
+ tag => '999',
+ ind1 => ' ',
+ ind2 => ' ',
+ subfields => [
+ { a => 'Z'}
+ ]
+ }
+ ], 'marc_cut(...,all)';
+
+ is_deeply $record->{record} , [] , 'marc record is empty';
+}
+
+done_testing;
+
+sub marc_has {
+ my ($record,$tag) = @_;
+ for (@{$record->{record}}) {
+ return 1 if $_->[0] eq $tag;
+ }
+ return 0;
+}
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libcatmandu-marc-perl.git
More information about the Pkg-perl-cvs-commits
mailing list