[libcatmandu-marc-perl] 176/208: Adding marc_paste tests and documentation
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 9563c9578ef284fd7a8653faa9c812c729c8d6b3
Author: Patrick Hochstenbach <patrick.hochstenbach at ugent.be>
Date: Tue Jul 4 14:01:22 2017 +0200
Adding marc_paste tests and documentation
---
README.md | 3 +-
lib/Catmandu/Fix/marc_paste.pm | 37 +++++++++++++++---
lib/Catmandu/Fix/marc_spec.pm | 6 +--
lib/Catmandu/MARC.pm | 87 ++++++++++++++++++++++++++++++++++++++++--
t/28_marc_paste.t | 85 +++++++++++++++++++++++++++++++++++++++--
5 files changed, 200 insertions(+), 18 deletions(-)
diff --git a/README.md b/README.md
index 12325cb..22afeb9 100644
--- a/README.md
+++ b/README.md
@@ -56,7 +56,8 @@ Catmandu::MARC - Catmandu modules for working with MARC data
- [Catmandu::Fix::marc\_in\_json](https://metacpan.org/pod/Catmandu::Fix::marc_in_json)
- [Catmandu::Fix::marc\_decode\_dollar\_subfields](https://metacpan.org/pod/Catmandu::Fix::marc_decode_dollar_subfields)
- [Catmandu::Fix::marc\_set](https://metacpan.org/pod/Catmandu::Fix::marc_set)
-- [Catmandu::Fix::marc\_struc](https://metacpan.org/pod/Catmandu::Fix::marc_struc)
+- [Catmandu::Fix::marc\_copy](https://metacpan.org/pod/Catmandu::Fix::marc_copy)
+- [Catmandu::Fix::marc\_paste](https://metacpan.org/pod/Catmandu::Fix::marc_paste)
- [Catmandu::Fix::Bind::marc\_each](https://metacpan.org/pod/Catmandu::Fix::Bind::marc_each)
- [Catmandu::Fix::Condition::marc\_match](https://metacpan.org/pod/Catmandu::Fix::Condition::marc_match)
- [Catmandu::Fix::Condition::marc\_has](https://metacpan.org/pod/Catmandu::Fix::Condition::marc_has)
diff --git a/lib/Catmandu/Fix/marc_paste.pm b/lib/Catmandu/Fix/marc_paste.pm
index 0ef7182..40117d6 100644
--- a/lib/Catmandu/Fix/marc_paste.pm
+++ b/lib/Catmandu/Fix/marc_paste.pm
@@ -10,11 +10,15 @@ with 'Catmandu::Fix::Inlineable';
our $VERSION = '1.15';
has path => (fix_arg => 1);
+has at => (fix_opt => 1);
+has equals => (fix_opt => 1);
sub fix {
my ($self, $data) = @_;
- my $path = $self->path;
- return Catmandu::MARC->instance->marc_paste($data,$path);
+ my $path = $self->path;
+ my $at = $self->at;
+ my $regex = $self->equals;
+ return Catmandu::MARC->instance->marc_paste($data,$path,$at,$regex);
}
1;
@@ -27,8 +31,8 @@ Catmandu::Fix::marc_paste - paste a MARC structured field back into the MARC rec
=head1 SYNOPSIS
- # Copy a field field
- marc_struc(001, fixed001)
+ # Copy a MARC field
+ marc_copy(001, fixed001)
# Change it
set_fieldfixed001.0.tag,002)
@@ -44,9 +48,30 @@ a MARC record.
=head1 METHODS
-=head2 marc_paste(JSON_PATH)
+=head2 marc_paste(JSON_PATH, [at: MARC+PATH , [equals: REGEX]])
-Paste a MARC struct PATH back in the MARC record
+Paste a MARC struct PATH back in the MARC record. By default the MARC structure will
+be pasted at the end of the record. Optionally provide an C<at> option to set the
+MARC field after which the structure needs to be pasted. Optionally provide a regex
+that should match the content of the C<at> field.
+
+ # Paste mycopy at the end of the record
+ marc_paste(mycopy)
+
+ # Paste mycopy after the last 300 field
+ marc_paste(mycopy, at:300)
+
+ # Paste mycopy after the last 300 field with indicator1 = 1
+ marc_paste(mycopy, at:300[1])
+
+ # Paste mycopy after the last 300 field which has an 'a' subfield
+ marc_paste(mycopy, at:300a)
+
+ # Paste mycopy after the last 300 field which has an 'a' subfield equal to 'ABC'
+ marc_paste(mycopy, at:300a, equals:'^ABC$')
+
+ # Paste mycopy after the last 300 field with all concatinated subfields equal to 'ABC'
+ marc_paste(mycopy, at:300, equals:'^ABC$')
=head1 INLINE
diff --git a/lib/Catmandu/Fix/marc_spec.pm b/lib/Catmandu/Fix/marc_spec.pm
index 9579b9d..9074037 100644
--- a/lib/Catmandu/Fix/marc_spec.pm
+++ b/lib/Catmandu/Fix/marc_spec.pm
@@ -16,7 +16,7 @@ has join => ( fix_opt=> 1 );
has value => ( fix_opt=> 1 );
has pluck => ( fix_opt=> 1 );
has invert => ( fix_opt=> 1 );
-has nested_arrays => (fix_opt => 1);
+has nested_arrays => ( fix_opt=> 1 );
sub emit {
my ( $self, $fixer ) = @_;
@@ -161,7 +161,7 @@ In a fix file e.g. 'my.fix':
# Assign values of of all other subfields than a of field 020
# to my.isbn.other.subfields
marc_spec('020$a' my.isbn.other.subfields, invert:1)
-
+
# Assign value of subfield a of field 245 only, if subfield a of field 246
# with value 1 for indicator1 exists
marc_spec('245$a{246_1$a}', my.var.title)
@@ -200,7 +200,7 @@ to assign referenced values to
You may use one of $first, $last, $prepend or $append to add
referenced data values to a specific position of an array
-(see L<Catmandu Wildcards|http://librecat.org/Catmandu/#wildcards> and
+(see L<Catmandu Wildcards|http://librecat.org/Catmandu/#wildcards> and
mapping rules at L<https://github.com/LibreCat/Catmandu-MARC/wiki/Mapping-rules>).
# INPUT
diff --git a/lib/Catmandu/MARC.pm b/lib/Catmandu/MARC.pm
index e1f0541..6b50056 100644
--- a/lib/Catmandu/MARC.pm
+++ b/lib/Catmandu/MARC.pm
@@ -1100,9 +1100,11 @@ sub marc_copy {
}
sub marc_paste {
- my $self = $_[0];
- my $data = $_[1];
- my $json_path = $_[2];
+ my $self = $_[0];
+ my $data = $_[1];
+ my $json_path = $_[2];
+ my $marc_path = $_[3];
+ my $marc_value = $_[4];
my $value = Catmandu::Util::data_at($json_path,$data);
@@ -1144,7 +1146,84 @@ sub marc_paste {
}
}
- push @{$data->{record}} , @new_parts;
+ if (defined($marc_path)) {
+ my $context = $self->compile_marc_path($marc_path, subfield_wildcard => 0);
+
+ confess "invalid marc path" unless $context;
+
+ my @record = @{$data->{record}};
+ my $found_match = undef;
+
+ my $field_position = -1;
+
+ for my $field (@record) {
+ $field_position++;
+ my ($tag, $ind1, $ind2, @subfields) = @$field;
+
+ if ($context->{is_regex_field}) {
+ next unless $tag =~ $context->{field_regex};
+ }
+ else {
+ next unless $tag eq $context->{field};
+ }
+
+ if (defined $context->{ind1}) {
+ if (!defined $ind1 || $ind1 ne $context->{ind1}) {
+ next;
+ }
+ }
+ if (defined $context->{ind2}) {
+ if (!defined $ind2 || $ind2 ne $context->{ind2}) {
+ next;
+ }
+ }
+
+ if ($context->{subfield}) {
+ for (my $i = 0; $i < @subfields; $i += 2) {
+ if ($subfields[$i] =~ $context->{subfield}) {
+
+ if (defined($marc_value)) {
+ $found_match = $field_position if $subfields[$i+1] =~ /$marc_value/;
+ }
+ else {
+ $found_match = $field_position;
+ }
+ }
+ }
+ } else {
+ if (defined($marc_value)) {
+ my @sf = ();
+ for (my $i = 0; $i < @subfields; $i += 2) {
+ push @sf , $subfields[$i+1];
+ }
+
+ my $string = join "", @sf;
+
+ if ($string =~ /$marc_value/) {
+ $found_match = $field_position;
+ }
+ else {
+ # don't match anything
+ }
+ }
+ else {
+ $found_match = $field_position;
+ }
+ }
+ }
+
+ if (defined $found_match) {
+ my @new_record = (
+ @record[0..$found_match] ,
+ @new_parts ,
+ @record[$found_match+1..$#record]
+ );
+ $data->{record} = \@new_record;
+ }
+ }
+ else {
+ push @{$data->{record}} , @new_parts;
+ }
$data;
}
diff --git a/t/28_marc_paste.t b/t/28_marc_paste.t
index 8c30d41..310e80b 100644
--- a/t/28_marc_paste.t
+++ b/t/28_marc_paste.t
@@ -14,7 +14,7 @@ my $mrc = <<'MRC';
<marc:subfield code="a">Title / </marc:subfield>
<marc:subfield code="c">Name</marc:subfield>
</marc:datafield>
- <marc:datafield ind1=" " ind2=" " tag="999">
+ <marc:datafield ind1=" " ind2=" " tag="998">
<marc:subfield code="a">X</marc:subfield>
<marc:subfield code="a">Y</marc:subfield>
</marc:datafield>
@@ -26,19 +26,96 @@ my $mrc = <<'MRC';
MRC
-note 'marc_struc(001,cntrl); set_field(cntrl.0.tag,002); marc_paste(cntrl)';
+note 'marc_copy(001,cntrl); set_field(cntrl.0.tag,002); marc_paste(cntrl)';
{
my $importer = Catmandu->importer(
'MARC',
file => \$mrc,
type => 'XML',
- fix => 'marc_struc(001,cntrl); set_field(cntrl.0.tag,002); marc_paste(cntrl)'
+ fix => 'marc_copy(001,cntrl); set_field(cntrl.0.tag,002); marc_paste(cntrl)'
);
my $record = $importer->first;
is_deeply $record->{record}->[-1],
[ '002' , ' ' , ' ' , '_' , ' 92005291 ' ]
- , 'marc_struc(001,cntrl)';
+ , 'marc_copy(001,cntrl)';
}
+
+note 'marc_copy(001,cntrl); set_field(cntrl.0.tag,002); marc_paste(cntrl,at:245)';
+{
+ my $importer = Catmandu->importer(
+ 'MARC',
+ file => \$mrc,
+ type => 'XML',
+ fix => 'marc_copy(001,cntrl); set_field(cntrl.0.tag,002); marc_paste(cntrl,at:245)'
+ );
+ my $record = $importer->first;
+
+ is_deeply $record->{record}->[-3],
+ [ '002' , ' ' , ' ' , '_' , ' 92005291 ' ]
+ , 'marc_copy(001,cntrl)';
+}
+
+note 'marc_copy(001,cntrl); set_field(cntrl.0.tag,002); marc_paste(cntrl,at:245c)';
+{
+ my $importer = Catmandu->importer(
+ 'MARC',
+ file => \$mrc,
+ type => 'XML',
+ fix => 'marc_copy(001,cntrl); set_field(cntrl.0.tag,002); marc_paste(cntrl,at:245c)'
+ );
+ my $record = $importer->first;
+
+ is_deeply $record->{record}->[-3],
+ [ '002' , ' ' , ' ' , '_' , ' 92005291 ' ]
+ , 'marc_copy(001,cntrl)';
+}
+
+note 'marc_copy(001,cntrl); set_field(cntrl.0.tag,002); marc_paste(cntrl,at:245x)';
+{
+ my $importer = Catmandu->importer(
+ 'MARC',
+ file => \$mrc,
+ type => 'XML',
+ fix => 'marc_copy(001,cntrl); set_field(cntrl.0.tag,002); marc_paste(cntrl,at:245x)'
+ );
+ my $record = $importer->first;
+
+ is_deeply $record->{record}->[-3],
+ [ '245' , '1' , '0' , 'a' , 'Title / ', 'c' , 'Name' ]
+ , 'marc_copy(001,cntrl)';
+}
+
+note 'marc_copy(001,cntrl); set_field(cntrl.0.tag,002); marc_paste(cntrl,at:245c,equals:Name)';
+{
+ my $importer = Catmandu->importer(
+ 'MARC',
+ file => \$mrc,
+ type => 'XML',
+ fix => 'marc_copy(001,cntrl); set_field(cntrl.0.tag,002); marc_paste(cntrl,at:245c,equals:Name)'
+ );
+ my $record = $importer->first;
+
+ is_deeply $record->{record}->[-3],
+ [ '002' , ' ' , ' ' , '_' , ' 92005291 ' ]
+ , 'marc_copy(001,cntrl)';
+}
+
+note 'marc_copy(001,cntrl); set_field(cntrl.0.tag,002); marc_paste(cntrl,at:245,equals:"Title / Name")';
+{
+ my $importer = Catmandu->importer(
+ 'MARC',
+ file => \$mrc,
+ type => 'XML',
+ fix => 'marc_copy(001,cntrl); set_field(cntrl.0.tag,002); marc_paste(cntrl,at:245,equals:"Title / Name")'
+ );
+ my $record = $importer->first;
+
+ is_deeply $record->{record}->[-3],
+ [ '002' , ' ' , ' ' , '_' , ' 92005291 ' ]
+ , 'marc_copy(001,cntrl)';
+}
+
+
done_testing();
--
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