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 <[email protected]> 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 _______________________________________________ Pkg-perl-cvs-commits mailing list [email protected] http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits
