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 52bfbbb70265e6c7a885229de33fa29dd30cdde1 Author: Patrick Hochstenbach <[email protected]> Date: Mon Jun 13 14:31:29 2016 +0200 Adding inline support for value --- Changes | 1 + lib/Catmandu/Fix/Inline/marc_map.pm | 52 ++++++++++++++++++++++--------------- t/03-marc_map.t | 4 +++ t/07-inline-fix.t | 12 ++++++++- t/test.fix | 7 +++-- 5 files changed, 52 insertions(+), 24 deletions(-) diff --git a/Changes b/Changes index abcb674..86d7915 100644 --- a/Changes +++ b/Changes @@ -2,6 +2,7 @@ Revision history for Catmandu-MARC {{$NEXT}} - Fixed indicator-2 selection bug + - Fixed marc_map value bug 0.215 2016-02-22 09:57:07 CET - Supporting ISO alias for USMARC importer and exporter diff --git a/lib/Catmandu/Fix/Inline/marc_map.pm b/lib/Catmandu/Fix/Inline/marc_map.pm index fbbfe95..cfb1245 100644 --- a/lib/Catmandu/Fix/Inline/marc_map.pm +++ b/lib/Catmandu/Fix/Inline/marc_map.pm @@ -75,6 +75,7 @@ sub marc_map { my $split = $opts{'-split'}; my $join_char = $opts{'-join'} // ''; my $pluck = $opts{'-pluck'}; + my $value_set = $opts{'-value'}; my $attrs = {}; if ($marc_path =~ /(\S{3})(\[(.)?,?(.)?\])?([_a-z0-9^]+)?(\/(\d+)(-(\d+))?)?/) { @@ -127,27 +128,36 @@ sub marc_map { my $v; - if ($var->[0] =~ /LDR|00./) { - $v = $add_subfields->($var,3); - } - elsif (defined $var->[5] && $var->[5] eq '_') { - $v = $add_subfields->($var,5); - } - else { - $v = $add_subfields->($var,3); - } - - if (@$v) { - if (!$split) { - $v = join $join_char, @$v; - - if (defined(my $off = $attrs->{from})) { - my $len = defined $attrs->{to} ? $attrs->{to} - $off + 1 : 1; - $v = substr($v,$off,$len); - } - } - } - + if ($value_set) { + for (my $i = 3; $i < @$var; $i += 2) { + if ($var->[$i] =~ /$attrs->{subfield_regex}/) { + $v = $value_set; + last; + } + } + } + else { + if ($var->[0] =~ /LDR|00./) { + $v = $add_subfields->($var,3); + } + elsif (defined $var->[5] && $var->[5] eq '_') { + $v = $add_subfields->($var,5); + } + else { + $v = $add_subfields->($var,3); + } + + if (@$v) { + if (!$split) { + $v = join $join_char, @$v; + + if (defined(my $off = $attrs->{from})) { + my $len = defined $attrs->{to} ? $attrs->{to} - $off + 1 : 1; + $v = substr($v,$off,$len); + } + } + } + } push (@vals,$v) if ( (ref $v eq 'ARRAY' && @$v) || (ref $v eq '' && length $v )); } diff --git a/t/03-marc_map.t b/t/03-marc_map.t index 5984827..ded46b3 100644 --- a/t/03-marc_map.t +++ b/t/03-marc_map.t @@ -41,4 +41,8 @@ is $records->[0]->{my}->{pluck} , "M33 2000QA76.73.P22" , 'pluck feature'; is $records->[0]->{my}->{has_title}, 'Y' , 'value feature'; +is $records->[0]->{has_260c}, 'OK' , 'value subfield'; + +ok ! $records->[0]->{has_260h}, 'value subfield'; + done_testing; diff --git a/t/07-inline-fix.t b/t/07-inline-fix.t index d4f1106..f812bdc 100644 --- a/t/07-inline-fix.t +++ b/t/07-inline-fix.t @@ -1,7 +1,7 @@ use strict; use warnings; -use Test::More tests => 13; +use Test::More tests => 15; use Catmandu::Fix::Inline::marc_map qw(marc_map); use Catmandu::Fix::Inline::marc_add qw(marc_add); @@ -68,4 +68,14 @@ ok(@$records == 2 , "Found 2 records"); { my $f050 = marc_map($records->[0],'050ba',-pluck=>1); is $f050 , "M33 2000QA76.73.P22" , q|pluck test|; +} + +{ + my $f260c = marc_map($records->[0],'260c',-value=>'OK'); + is $f260c , "OK" , q|value test|; +} + +{ + my $f260h = marc_map($records->[0],'260h',-value=>'BAD'); + ok ! $f260h , q|value test|; } \ No newline at end of file diff --git a/t/test.fix b/t/test.fix index 6a16f5c..2fbae92 100644 --- a/t/test.fix +++ b/t/test.fix @@ -23,6 +23,9 @@ marc_map('050ba','my.pluck', pluck:1) marc_map('245','my.has_title', value:'Y') -marc_xml('record'); +marc_map('245','my.has_title', value:'Y') + +marc_map('260c','has_260c', value:'OK') +marc_map('260h','has_260h', value:'BAD') -#remove_field('record') +marc_xml('record') \ No newline at end of file -- 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
