[libcatmandu-marc-perl] 165/208: Adding support for marc_replace_all
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 b3eab17f0e9477e87d08780d3e438498638e987c
Author: Patrick Hochstenbach <patrick.hochstenbach at ugent.be>
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
More information about the Pkg-perl-cvs-commits
mailing list