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 1b856949bad73cf21ded4cee47f7addde542af2b Author: Carsten Klee <[email protected]> Date: Fri Jun 30 09:59:30 2017 +0200 new fix marc_struc --- cpanfile | 1 + lib/Catmandu/Fix/marc_struc.pm | 187 +++++++++++++++++++++++++++++++++++++++ lib/Catmandu/MARC.pm | 64 ++++++++++++++ t/26-marc_struc.t | 196 +++++++++++++++++++++++++++++++++++++++++ 4 files changed, 448 insertions(+) diff --git a/cpanfile b/cpanfile index 44fde68..0126702 100644 --- a/cpanfile +++ b/cpanfile @@ -5,6 +5,7 @@ on 'test', sub { requires 'Test::More', '1.001003'; requires 'Test::Deep', '0'; requires 'Test::Warnings', '0'; + requires 'Test::Warn', '0'; requires 'XML::XPath', '1.13'; requires 'Pod::Simple::HTML', '>=3.23'; requires 'Test::Pod' , '0'; diff --git a/lib/Catmandu/Fix/marc_struc.pm b/lib/Catmandu/Fix/marc_struc.pm new file mode 100644 index 0000000..9333cf3 --- /dev/null +++ b/lib/Catmandu/Fix/marc_struc.pm @@ -0,0 +1,187 @@ +package Catmandu::Fix::marc_struc; + +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); + +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); + my $marc = $fixer->capture($marc_obj); + my $marc_path = $fixer->capture($marc_context); + + 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_struc( + ${var}, + ${marc_path}) ) { + ${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_struc - copy marc data in a structured way to a new field + +=head1 SYNOPSIS + + # fixed field + marc_struc(001, fixed001) + +may result into + + fixed001 : [ + { + "tag": "001", + "ind1": null, + "ind2": null, + "content": "fol05882032 " + } + ] + +And + + # variable field + marc_struc(650, subjects) + +may result into + + subjects:[ + { + "subfields" : [ + { + "a" : "Perl (Computer program language)" + } + ], + "ind1" : " ", + "ind2" : "0", + "tag" : "650" + }, + { + "ind1" : " ", + "subfields" : [ + { + "a" : "Web servers." + } + ], + "tag" : "650", + "ind2" : "0" + } + ] + + +=head1 DESCRIPTION + +Copy MARC data referred by MARC_TAG in a structured way to JSON path. + +In contrast to L<Catmandu::Fix::marc_map> and L<Catmandu::Fix::marc_spec> +marc_struc will not only copy data content (values) but also all data elements +like tag, indicators and subfield codes into a nested data structure. + +=head1 METHODS + +=head2 marc_struc(MARC_TAG, JSON_PATH) + +Copy this data referred by a MARC_TAG to a JSON_PATH. + +MARC_TAG (meaning the field tag) is the first segment of MARC_PATH. + +Using a MARC_PATH with subfield codes, indicators or substring will cause a +warning and these segments will be ignored when referring the data. + +=head1 INLINE + +This Fix can be used inline in a Perl script: + + use Catmandu::Fix::marc_struc as => 'marc_struc'; + + my $data = { record => ['650', ' ', 0, 'a', 'Perl'] }; + + $data = marc_struc($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> + +=item * L<Catmandu::Fix::marc_map> + +=item * L<Catmandu::Fix::marc_spec> + +=item * L<Catmandu::Fix::marc_add> + +=item * L<Catmandu::Fix::marc_remove> + +=item * L<Catmandu::Fix::marc_xml> + +=item * L<Catmandu::Fix::marc_in_json> + +=item * L<Catmandu::Fix::marc_decode_dollar_subfields> + +=item * L<Catmandu::Fix::marc_set> + +=item * L<Catmandu::Fix::Bind::marc_each> + +=item * L<Catmandu::Fix::Condition::marc_match> + +=item * L<Catmandu::Fix::Condition::marc_has> + +=item * L<Catmandu::Fix::Condition::marc_has_many> + +=item * L<Catmandu::Fix::Condition::marc_has_ref> + +=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 056c6a4..6cfc39a 100644 --- a/lib/Catmandu/MARC.pm +++ b/lib/Catmandu/MARC.pm @@ -919,6 +919,68 @@ sub compile_marc_path { }; } +sub marc_struc { + my $self = $_[0]; + + # $_[2] : marc_path + my $context = ref($_[2]) ? + $_[2] : + $self->compile_marc_path($_[2]); + + confess "invalid marc path" unless $context; + 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}); + + # $_[1] : data record + my $record = $_[1]->{'record'}; + + return wantarray ? () : undef unless (defined $record && ref($record) eq 'ARRAY'); + + my $fields; + + for my $field (@$record) { + next if ( + ($context->{is_regex_field} == 0 && $field->[0] ne $context->{field} ) + || + ($context->{is_regex_field} == 1 && $field->[0] !~ $context->{field_regex} ) + ); + + my $f = {}; + $f->{tag} = $field->[0]; + + # indicator 1 + if(defined $field->[1]) { + $f->{ind1} = $field->[1]; + } else { + $f->{ind1} = undef; + } + + # indicator 2 + if(defined $field->[2]) { + $f->{ind2} = $field->[2]; + } else { + $f->{ind2} = undef; + } + + # fixed fields + if($field->[3] eq '_') { + $f->{content} = $field->[4]; + push(@$fields, $f); + next; + } + + # subfields + for (my $i = $context->{start}; $i < @{$field}; $i += 2) { + push(@{$f->{subfields}}, { $field->[$i] => $field->[$i + 1] }); + } + + push(@$fields, $f); + } + + [$fields]; +} + 1; __END__ @@ -995,6 +1057,8 @@ Catmandu::MARC - Catmandu modules for working with MARC data =item * L<Catmandu::Fix::marc_set> +=item * L<Catmandu::Fix::marc_struc> + =item * L<Catmandu::Fix::Bind::marc_each> =item * L<Catmandu::Fix::Condition::marc_match> diff --git a/t/26-marc_struc.t b/t/26-marc_struc.t new file mode 100644 index 0000000..29ce7a3 --- /dev/null +++ b/t/26-marc_struc.t @@ -0,0 +1,196 @@ +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)'; +{ + my $importer = Catmandu->importer( + 'MARC', + file => \$mrc, + type => 'XML', + fix => 'marc_struc(001,cntrl); retain_field(cntrl)' + ); + my $record = $importer->first; + is_deeply $record->{cntrl}, + [ + { + tag => '001', + ind1 => undef, + ind2 => undef, + content => " 92005291 " + } + ], 'marc_struc(001,cntrl)'; +} + +note 'marc_struc(245,title)'; +{ + my $importer = Catmandu->importer( + 'MARC', + file => \$mrc, + type => 'XML', + fix => 'marc_struc(245,title); retain_field(title)' + ); + my $record = $importer->first; + is_deeply $record->{title}, + [ + { + tag => '245', + ind1 => '1', + ind2 => '0', + subfields => [ + { a => 'Title / '}, + { c => 'Name' }, + ] + } + ], 'marc_map(245,title)'; +} + +note 'marc_struc(001/0-3,substr)'; +{ + warnings_like { Catmandu->importer( + 'MARC', + file => \$mrc, + type => 'XML', + fix => 'marc_struc(001/0-3,substr)' + )->first} [{carped => qr/^path segments.+/},{carped => qr/^path segments.+/}], "warn on substring usage"; +} + +note 'marc_struc(245[,0],title)'; +{ + warnings_like { Catmandu->importer( + 'MARC', + file => \$mrc, + type => 'XML', + fix => 'marc_struc("245[,0]",title)' + )->first} [{carped => qr/^path segments.+/},{carped => qr/^path segments.+/}], "warn on substring usage"; +} + + +note 'marc_struc(245[1],title)'; +{ + warnings_like { Catmandu->importer( + 'MARC', + file => \$mrc, + type => 'XML', + fix => 'marc_struc(245[1],title)' + )->first} [{carped => qr/^path segments.+/},{carped => qr/^path segments.+/}], "warn on substring usage"; +} + +note 'marc_struc(245a,title)'; +{ + warnings_like { Catmandu->importer( + 'MARC', + file => \$mrc, + type => 'XML', + fix => 'marc_struc(245a,title)' + )->first} [{carped => qr/^path segments.+/},{carped => qr/^path segments.+/}], "warn on substring usage"; +} + +note 'marc_struc(999,local)'; +{ + my $importer = Catmandu->importer( + 'MARC', + file => \$mrc, + type => 'XML', + fix => 'marc_struc(999,local); retain_field(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_struc(999,local)'; +} + +note 'marc_struc(...,all)'; +{ + my $importer = Catmandu->importer( + 'MARC', + file => \$mrc, + type => 'XML', + fix => 'marc_struc(...,all); retain_field(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_struc(...,all)'; +} + + +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
