[libcatmandu-marc-perl] 171/208: new fix marc_struc
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 1b856949bad73cf21ded4cee47f7addde542af2b
Author: Carsten Klee <cKlee at users.noreply.github.com>
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
More information about the Pkg-perl-cvs-commits
mailing list