[libcatmandu-marc-perl] 173/208: Adding marc_paste
Jonas Smedegaard
dr at jones.dk
Sat Oct 28 03:42:47 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 795197c70a5803fb43d83690e515a211a7935c7a
Author: Patrick Hochstenbach <patrick.hochstenbach at ugent.be>
Date: Tue Jul 4 11:19:18 2017 +0200
Adding marc_paste
---
Build.PL | 2 ++
README.md | 1 +
lib/Catmandu/Fix/marc_paste.pm | 80 ++++++++++++++++++++++++++++++++++++++++++
lib/Catmandu/MARC.pm | 52 ++++++++++++++++++++++++++-
t/28_marc_paste.t | 44 +++++++++++++++++++++++
5 files changed, 178 insertions(+), 1 deletion(-)
diff --git a/Build.PL b/Build.PL
index 02b6076..3a766ad 100644
--- a/Build.PL
+++ b/Build.PL
@@ -46,6 +46,7 @@ my %module_build_args = (
"Test::More" => "1.001003",
"Test::Pod" => 0,
"Test::Simple" => "1.001003",
+ "Test::Warn" => 0,
"Test::Warnings" => 0,
"XML::XPath" => "1.13"
}
@@ -59,6 +60,7 @@ my %fallback_build_requires = (
"Test::More" => "1.001003",
"Test::Pod" => 0,
"Test::Simple" => "1.001003",
+ "Test::Warn" => 0,
"Test::Warnings" => 0,
"XML::XPath" => "1.13"
);
diff --git a/README.md b/README.md
index 814a750..12325cb 100644
--- a/README.md
+++ b/README.md
@@ -56,6 +56,7 @@ 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::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
new file mode 100644
index 0000000..0ef7182
--- /dev/null
+++ b/lib/Catmandu/Fix/marc_paste.pm
@@ -0,0 +1,80 @@
+package Catmandu::Fix::marc_paste;
+
+use Catmandu::Sane;
+use Catmandu::MARC;
+use Moo;
+use Catmandu::Fix::Has;
+
+with 'Catmandu::Fix::Inlineable';
+
+our $VERSION = '1.15';
+
+has path => (fix_arg => 1);
+
+sub fix {
+ my ($self, $data) = @_;
+ my $path = $self->path;
+ return Catmandu::MARC->instance->marc_paste($data,$path);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Catmandu::Fix::marc_paste - paste a MARC structured field back into the MARC record
+
+=head1 SYNOPSIS
+
+ # Copy a field field
+ marc_struc(001, fixed001)
+
+ # Change it
+ set_fieldfixed001.0.tag,002)
+
+ # Paste it back into the record
+ marc_paste(fixed001)
+
+
+=head1 DESCRIPTION
+
+Paste a MARC stucture created by L<Catmandu::Fix::marc_struc> back at the end of
+a MARC record.
+
+=head1 METHODS
+
+=head2 marc_paste(JSON_PATH)
+
+Paste a MARC struct PATH back in the MARC record
+
+=head1 INLINE
+
+This Fix can be used inline in a Perl script:
+
+ use Catmandu::Fix::marc_struc as => 'marc_struc';
+ use Catmandu::Fix::marc_paste as => 'marc_paste';
+
+ my $data = { record => ['650', ' ', 0, 'a', 'Perl'] };
+
+ $data = marc_struc($data,'650','subject');
+ $data = marc_paste($data,'subject');
+
+
+=head1 SEE ALSO
+
+=over
+
+=item * L<Catmandu::Fix::marc_struc>
+
+=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/MARC.pm b/lib/Catmandu/MARC.pm
index d6fd8d1..f064a9f 100644
--- a/lib/Catmandu/MARC.pm
+++ b/lib/Catmandu/MARC.pm
@@ -1046,7 +1046,7 @@ sub marc_struc {
$self->compile_marc_path($_[2]);
confess "invalid marc path" unless $context;
- carp "path segments like indicators, subfields and substrings are ignored"
+ carp "path segments like indicators, subfields and substrings are ignored"
if(defined $context->{subfield} or defined $context->{from} or
defined $context->{ind1} or defined $context->{ind2});
@@ -1099,6 +1099,56 @@ sub marc_struc {
[$fields];
}
+sub marc_paste {
+ my $self = $_[0];
+ my $data = $_[1];
+ my $json_path = $_[2];
+
+ my $value = Catmandu::Util::data_at($json_path,$data);
+
+ return $data unless Catmandu::Util::is_array_ref($value);
+
+ my @new_parts;
+
+ for my $part (@$value) {
+ return $data unless
+ Catmandu::Util::is_hash_ref($part) &&
+ exists $part->{tag} &&
+ exists $part->{ind1} &&
+ exists $part->{ind2} &&
+ ( exists $part->{content} || exists $part->{subfields} );
+
+ my $tag = $part->{tag};
+ my $ind1 = $part->{ind1} // ' ';
+ my $ind2 = $part->{ind2} // ' ';
+ my $content = $part->{content};
+ my $subfields = $part->{subfields};
+
+ if (defined($content)) {
+ push @new_parts , [ $tag , $ind1 , $ind2 , '_' , $content ];
+ }
+ elsif (defined($subfields) && Catmandu::Util::is_array_ref($subfields)) {
+ my @tmp = ( $tag , $ind1 , $ind2 );
+
+ for my $sf (@$subfields) {
+ while (my ($key, $value) = each %$sf) {
+ push @tmp, $key , $value;
+ }
+ }
+
+ push @new_parts , [ @tmp ];
+ }
+ else {
+ # Illegal input
+ return $data;
+ }
+ }
+
+ push @{$data->{record}} , @new_parts;
+
+ $data;
+}
+
1;
__END__
diff --git a/t/28_marc_paste.t b/t/28_marc_paste.t
new file mode 100644
index 0000000..8c30d41
--- /dev/null
+++ b/t/28_marc_paste.t
@@ -0,0 +1,44 @@
+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_struc(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)'
+ );
+ my $record = $importer->first;
+
+ is_deeply $record->{record}->[-1],
+ [ '002' , ' ' , ' ' , '_' , ' 92005291 ' ]
+ , 'marc_struc(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