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 b3eab17f0e9477e87d08780d3e438498638e987c Author: Patrick Hochstenbach <[email protected]> Date: Thu Jun 29 15:50:13 2017 +0200 Adding support for marc_replace_all --- README.md | 2 +- lib/Catmandu/Fix/marc_replace_all.pm | 71 ++++++++++++++++++++++++++++++++++++ lib/Catmandu/MARC.pm | 61 ++++++++++++++++++++++++++++++- t/26_marc_replace_all.t | 35 ++++++++++++++++++ 4 files changed, 166 insertions(+), 3 deletions(-) diff --git a/README.md b/README.md index 2f48900..794c75c 100644 --- a/README.md +++ b/README.md @@ -58,7 +58,7 @@ Catmandu::MARC - Catmandu modules for working with MARC data - [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) - [Catmandu::Fix::Condition::marc\_has\_many](https://metacpan.org/pod/Catmandu::Fix::Condition::marc_has_many) -- [Catmandu::Fix::Condition::marc\_has\_ref](https://metacpan.org/pod/Catmandu::Fix::Condition::marc_has_ref) +- [Catmandu::Fix::Condition::marc\_spec\_has](https://metacpan.org/pod/Catmandu::Fix::Condition::marc_spec_has) - [Catmandu::Fix::Inline::marc\_map](https://metacpan.org/pod/Catmandu::Fix::Inline::marc_map) - [Catmandu::Fix::Inline::marc\_add](https://metacpan.org/pod/Catmandu::Fix::Inline::marc_add) - [Catmandu::Fix::Inline::marc\_remove](https://metacpan.org/pod/Catmandu::Fix::Inline::marc_remove) diff --git a/lib/Catmandu/Fix/marc_replace_all.pm b/lib/Catmandu/Fix/marc_replace_all.pm new file mode 100644 index 0000000..3363fb5 --- /dev/null +++ b/lib/Catmandu/Fix/marc_replace_all.pm @@ -0,0 +1,71 @@ +package Catmandu::Fix::marc_replace_all; + +use Catmandu::Sane; +use Moo; +use Catmandu::MARC; +use Catmandu::Fix::Has; + +with 'Catmandu::Fix::Inlineable'; + +our $VERSION = '1.14'; + +has marc_path => (fix_arg => 1); +has regex => (fix_arg => 1); +has value => (fix_arg => 1); + +sub fix { + my ($self,$data) = @_; + my $marc_path = $self->marc_path; + my $regex = $self->regex; + my $value = $self->value; + return Catmandu::MARC->instance->marc_replace_all($data,$marc_path,$regex,$value); +} + +=head1 NAME + +Catmandu::Fix::marc_set - set a marc value of one (sub)field to a new value + +=head1 SYNOPSIS + + # Set a field in the leader + if marc_match('LDR/6','c') + marc_set('LDR/6','p') + end + + # Set all the 650-p fields to 'test' + marc_set('650p','test') + + # Set the 100-a subfield where indicator-1 is 3 + marc_set('100[3]a','Farquhar family.') + + # Copy data from another field in a subfield + marc_set('100a','$.my.deep.field') + +=head1 DESCRIPTION + +Set the value of a MARC subfield to a new value. + +=head1 METHODS + +=head2 marc_set( MARC_PATH , VALUE , [OPT1:VAL, OPT2: VAL]) + +Set a MARC subfield to a particular new value. This valeu can be a literal or +reference an existing field in the record using the dollar JSON_PATH syntax. + +=head1 INLINE + +This Fix can be used inline in a Perl script: + + use Catmandu::Fix::marc_set as => 'marc_xmarc_setml'; + + my $data = { record => [...] }; + + $data = marc_set($data, '245a', 'test'); + +=head1 SEE ALSO + +L<Catmandu::Fix> + +=cut + +1; diff --git a/lib/Catmandu/MARC.pm b/lib/Catmandu/MARC.pm index d6fe6f1..02437c7 100644 --- a/lib/Catmandu/MARC.pm +++ b/lib/Catmandu/MARC.pm @@ -207,6 +207,63 @@ sub marc_add { $data; } +sub marc_replace_all { + my ($self,$data,$marc_path,$regex,$value) = @_; + my $record = $data->{'record'}; + + return $data unless defined $record; + + if ($value =~ /^\$\.(\S+)/) { + my $path = $1; + $value = Catmandu::Util::data_at($path,$data); + } + + if (Catmandu::Util::is_array_ref $value) { + $value = $value->[-1]; + } + elsif (Catmandu::Util::is_hash_ref $value) { + my $last; + for (keys %$value) { + $last = $value->{$_}; + } + $value = $last; + } + + my $context = $self->compile_marc_path($marc_path, subfield_wildcard => 1); + + confess "invalid marc path" unless $context; + + for my $field (@$record) { + 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; + } + } + + for (my $i = 0; $i < @subfields; $i += 2) { + if ($subfields[$i] =~ $context->{subfield}) { + $field->[$i + 4] =~ s{$regex}{$value}g; + } + } + } + + $data; +} + sub marc_set { my ($self,$data,$marc_path,$value,%opts) = @_; my $record = $data->{'record'}; @@ -229,7 +286,7 @@ sub marc_set { $value = $last; } - my $context = $self->compile_marc_path($marc_path, subfield_default => 1); + my $context = $self->compile_marc_path($marc_path, subfield_wildcard => 1); confess "invalid marc path" unless $context; @@ -256,7 +313,7 @@ sub marc_set { my $found = 0; for (my $i = 0; $i < @subfields; $i += 2) { - if ($subfields[$i] eq $context->{subfield}) { + if ($subfields[$i] =~ $context->{subfield}) { if (defined $context->{from}) { substr($field->[$i + 4], $context->{from}, $context->{len}) = $value; } diff --git a/t/26_marc_replace_all.t b/t/26_marc_replace_all.t new file mode 100644 index 0000000..8e2483d --- /dev/null +++ b/t/26_marc_replace_all.t @@ -0,0 +1,35 @@ +#!/usr/bin/perl + +use strict; +use warnings; +use warnings qw(FATAL utf8); +use utf8; + +use Test::More; + +use Catmandu::Importer::MARC; +use Catmandu::Fix; + + +#--- +{ + my $fixer = Catmandu::Fix->new(fixes => [q|marc_replace_all('100a','Tobias','John')|,q|marc_map('100a','test')|]); + my $importer = Catmandu::Importer::MARC->new( file => 't/camel.mrc', type => "ISO" ); + my $record = $fixer->fix($importer->first); + + like $record->{test}, qr/^Martinsson, John,$/, q|fix: marc_replace_all('100a','Tobias','John')|; +} + +#--- +{ + my $fixer = Catmandu::Fix->new(fixes => [q|marc_replace_all('630','Active','Silly')|,q|marc_map('630a','test.$append')|]); + my $importer = Catmandu::Importer::MARC->new( file => 't/camel.mrc', type => "ISO" ); + my $record = $fixer->fix($importer->first); + + is_deeply $record->{test}, [ + 'Silly server pages.' , + 'SillyX.' + ], q|fix: marc_replace_all('630a','Active','Silly')|; +} + +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
