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 64417677e463a68741901686ff9de104a73119da Author: Patrick Hochstenbach <[email protected]> Date: Fri Jul 8 14:27:38 2016 +0200 Benchmarking code --- lib/Catmandu/Fix/Inline/marc_map.pm | 6 +- lib/Catmandu/Fix/marc_map.pm | 25 +++-- lib/Catmandu/MARC.pm | 182 +++++++++++++++++------------------- 3 files changed, 103 insertions(+), 110 deletions(-) diff --git a/lib/Catmandu/Fix/Inline/marc_map.pm b/lib/Catmandu/Fix/Inline/marc_map.pm index 07c17c1..ab8bc74 100644 --- a/lib/Catmandu/Fix/Inline/marc_map.pm +++ b/lib/Catmandu/Fix/Inline/marc_map.pm @@ -70,8 +70,12 @@ our $VERSION = '0.219'; sub marc_map { my ($data,$marc_path,%opts) = @_; # Set default to nested_arrays for backwards compatibility + $opts{'-record'} = 'record' unless exists $opts{'-record'}; $opts{'-nested_arrays'} = 1 unless exists $opts{'-nested_arrays'}; - return Catmandu::MARC->new->marc_map($data,$marc_path,%opts); + return Catmandu::MARC->new->marc_map( + $data, + $marc_path, + \%opts); } 1; diff --git a/lib/Catmandu/Fix/marc_map.pm b/lib/Catmandu/Fix/marc_map.pm index dbc5c8b..90bda3f 100644 --- a/lib/Catmandu/Fix/marc_map.pm +++ b/lib/Catmandu/Fix/marc_map.pm @@ -22,27 +22,24 @@ sub emit { my ($self,$fixer) = @_; my $path = $fixer->split_path($self->path); + my $marc = $fixer->capture(Catmandu::MARC->new); my $marc_path = $fixer->emit_string($self->marc_path); - my $record_opt = $fixer->emit_string($self->record // 'record'); - my $join_opt = $fixer->emit_string($self->join // ''); - my $split_opt = $fixer->emit_string($self->split // 0); - my $pluck_opt = $fixer->emit_string($self->pluck // 0); - my $nested_arrays_opt = $fixer->emit_string($self->nested_arrays // 0); - - my $value_opt = $self->value ? - $fixer->emit_string($self->value) : 'undef'; + my $marc_opt = $fixer->capture({ + '-record' => $self->record // 'record' , + '-join' => $self->join // '' , + '-split' => $self->split // 0 , + '-pluck' => $self->pluck // 0 , + '-nested_arrays' => $self->nested_arrays // 0 , + '-value' => $self->value + }); my $var = $fixer->var; my $result = $fixer->generate_var; my $perl =<<EOF; -if (my ${result} = Catmandu::MARC->new->marc_map( +if (my ${result} = ${marc}->marc_map( ${var}, ${marc_path}, - -split => ${split_opt}, - -join => ${join_opt}, - -pluck => ${pluck_opt}, - -nested_arrays => ${nested_arrays_opt} , - -value => ${value_opt}) ) { + ${marc_opt}) ) { EOF $perl .= $fixer->emit_create_path( $var, diff --git a/lib/Catmandu/MARC.pm b/lib/Catmandu/MARC.pm index 539b88d..aa69dd7 100644 --- a/lib/Catmandu/MARC.pm +++ b/lib/Catmandu/MARC.pm @@ -7,39 +7,48 @@ use Memoize; use Carp; use Moo; -#memoize('_compile_marc_path'); +memoize('_compile_marc_path'); our $VERSION = '0.219'; -warn 'here'; - sub marc_map { - my ($self,$data,$marc_path,%opts) = @_; - my $record_key = $opts{record} // 'record'; + my $self = $_[0]; + my $data = $_[1]; + my $marc_path = $_[2]; + my $opts = $_[3]; - return undef unless exists $data->{$record_key}; + my $record_key = $opts->{'-record'} // 'record'; - my $record = $data->{$record_key}; + return wantarray ? () : undef + unless (defined $data->{$record_key} && ref $data->{$record_key} eq 'ARRAY'); - unless (defined $record && ref $record eq 'ARRAY') { - return wantarray ? () : undef; - } + my $split = $opts->{'-split'} // 0; + my $join_char = $opts->{'-join'} // ''; + my $pluck = $opts->{'-pluck'}; + my $value_set = $opts->{'-value'}; + my $nested_arrays = $opts->{'-nested_arrays'} // 0; - my $split = $opts{'-split'} // 0; - my $join_char = $opts{'-join'} // ''; - my $pluck = $opts{'-pluck'}; - my $value_set = $opts{'-value'}; - my $nested_arrays = $opts{'-nested_arrays'} // 0; - my $attrs = {}; + my $context = _compile_marc_path($marc_path, subfield_wildcard => 1); + + confess "invalid marc path" unless $context; my $vals; - marc_at_field($record, $marc_path, sub { - my ($field, $context) = @_; + for my $field (@{$data->{$record_key}}) { + next if ( + ($context->{is_regex_field} == 1 && $field->[0] !~ $context->{field_regex} ) + || + ($context->{is_regex_field} == 0 && $field->[0] ne $context->{field} ) + || + (defined $context->{ind1} && (!defined $field->[1] || $field->[1] ne $context->{ind1})) + || + (defined $context->{ind2} && (!defined $field->[2] || $field->[2] ne $context->{ind2})) + ); + my $v; if ($value_set) { - for (my $i = $context->{start}; $i < $context->{end}; $i += 2) { + for (my $i = 3; $field->[$i]; $i += 2) { my $subfield_regex = $context->{subfield_regex}; if ($field->[$i] =~ $subfield_regex) { $v = $value_set; @@ -99,7 +108,7 @@ sub marc_map { } } } - }, subfield_wildcard => 1); + } if (!defined $vals) { return undef; @@ -114,13 +123,14 @@ sub marc_map { sub _extract_subfields { my ($field,$context,%opts) = @_; + my $field_size = int(@$field); my @v = (); if ($opts{pluck}) { # Treat the subfield as a hash index my $_h = {}; - for (my $i = $context->{start}; $i < $context->{end}; $i += 2) { + for (my $i = $context->{start}; $i < $field_size; $i += 2) { push @{ $_h->{ $field->[$i] } } , $field->[$i + 1]; } my $subfield = $context->{subfield}; @@ -130,7 +140,7 @@ sub _extract_subfields { } } else { - for (my $i = $context->{start}; $i < $context->{end}; $i += 2) { + for (my $i = $context->{start}; $i < $field_size; $i += 2) { my $subfield_regex = $context->{subfield_regex}; if ($field->[$i] =~ $subfield_regex) { push(@v, $field->[$i + 1]); @@ -141,7 +151,6 @@ sub _extract_subfields { return @v ? \@v : undef; } - sub marc_add { my ($self,$data,$marc_path,@subfields) = @_; @@ -215,17 +224,39 @@ sub marc_set { $value = $last; } - marc_at_field($record, $marc_path, sub { - my ($field,$context) = @_; + my $context = _compile_marc_path($marc_path, subfield_default => 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; + } + } my $found = 0; - for (my $i = $context->{start}; $i < $context->{end}; $i += 2) { - if ($field->[$i] eq $context->{subfield}) { + for (my $i = 0; $i < @subfields; $i += 2) { + if ($subfields[$i] eq $context->{subfield}) { if (defined $context->{from}) { - substr($field->[$i + 1], $context->{from}, $context->{len}) = $value; + substr($field->[$i + 4], $context->{from}, $context->{len}) = $value; } else { - $field->[$i + 1] = $value; + $field->[$i + 4] = $value; } $found = 1; } @@ -234,7 +265,7 @@ sub marc_set { if ($found == 0) { push(@$field,$context->{subfield},$value); } - }, subfield_default => 1); + } $data; } @@ -246,31 +277,37 @@ sub marc_remove { my $new_record; - marc_at_field($record, $marc_path, sub { - my ($field,$context) = @_; + my $context = _compile_marc_path($marc_path); - if ($field->[0] =~ $context->{field_regex}) { + confess "invalid marc path" unless $context; + + for my $field (@$record) { + my $field_size = int(@$field); + + if ( + ($context->{is_regex_field} == 0 && $field->[0] eq $context->{field}) + || + ($context->{is_regex_field} == 1 && $field->[0] =~ $context->{field_regex}) + ) { if (defined $context->{ind1}) { - return if (defined $field->[1] && $field->[1] eq $context->{ind1}); + next if (defined $field->[1] && $field->[1] eq $context->{ind1}); } if (defined $context->{ind2}) { - return if (defined $field->[2] && $field->[2] eq $context->{ind2}); + next if (defined $field->[2] && $field->[2] eq $context->{ind2}); } unless ( defined $context->{ind1} || defined $context->{ind2} || defined $context->{subfield_regex} ) { - return; + next; } - } - if (defined $context->{subfield_regex}) { - my $subfield_regex = $context->{subfield_regex}; - if ( $field->[0] =~ $context->{field_regex}) { + if (defined $context->{subfield_regex}) { + my $subfield_regex = $context->{subfield_regex}; my $new_subf = []; - for (my $i = $context->{start}; $i < $context->{end}; $i += 2) { + for (my $i = $context->{start}; $i < $field_size; $i += 2) { unless ($field->[$i] =~ $subfield_regex) { push @$new_subf , $field->[$i]; push @$new_subf , $field->[$i+1]; @@ -281,8 +318,7 @@ sub marc_remove { } push @$new_record , $field; - - }, nofilter => 1); + } $data->{$record_key} = $new_record; @@ -389,9 +425,9 @@ sub marc_decode_dollar_subfields { my $new_record = []; for my $field (@$old_record) { - my ($field,$ind1,$ind2,@subfields) = @$field; + my ($tag,$ind1,$ind2,@subfields) = @$field; - my $fixed_field = [$field,$ind1,$ind2]; + my $fixed_field = [$tag,$ind1,$ind2]; for (my $i = 0 ; $i < @subfields ; $i += 2) { my $code = $subfields[$i]; @@ -452,14 +488,15 @@ sub _compile_marc_path { return undef; } - $field_regex = $field; - if ($field =~ /\*/) { + $field_regex = $field; $field_regex =~ s/\*/./g; $is_regex_field = 1; + $field_regex = qr/^$field_regex$/; + } + else { + $is_regex_field = 0; } - - $field_regex = qr/^$field_regex$/; return { field => $field , @@ -469,58 +506,13 @@ sub _compile_marc_path { subfield_regex => $subfield_regex , ind1 => $ind1 , ind2 => $ind2 , + start => 3, from => $from , to => $to , len => $len }; } -sub marc_at_field { - my ($record,$marc_path,$callback,%opts) = @_; - - croak "need a marc_path and callback" unless defined($marc_path) && defined($callback); - - my $context = _compile_marc_path($marc_path,%opts); - - confess "invalid marc path" unless $context; - - for my $row (@$record) { - unless ($opts{nofilter}) { - if ($context->{is_regex_field}) { - next unless $row->[0] =~ $context->{field_regex}; - } - else { - next unless $row->[0] eq $context->{field}; - } - - if (defined $context->{ind1}) { - if (!defined $row->[1] || $row->[1] ne $context->{ind1}) { - next; - } - } - if (defined $context->{ind2}) { - if (!defined $row->[2] || $row->[2] ne $context->{ind2}) { - next; - } - } - } - - if ($row->[0] =~ /^LDR|^00/) { - $context->{start} = 3; - } - elsif (defined $row->[5] && $row->[5] eq '_') { - $context->{start} = 5; - } - else { - $context->{start} = 3; - } - - $context->{end} = int(@$row); - - $callback->($row,$context); - } -} - 1; __END__ -- 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
