From 92dcd89f127210593d1f8cf482d8fc5b583b79a7 Mon Sep 17 00:00:00 2001 From: Dobrica Pavlinusic Date: Sat, 10 Nov 2007 11:11:16 +0000 Subject: [PATCH] r1579@llin: dpavlin | 2007-11-10 11:59:27 +0100 Begin extraction of MARC functionality from WebPAC::Normalize to WebPAC::Normalize::MARC git-svn-id: svn+ssh://mjesec/home/dpavlin/svn/webpac2/trunk@1021 07558da8-63fa-0310-ba24-9fe276d99e06 --- lib/WebPAC/Normalize.pm | 169 +++++------------------------- lib/WebPAC/Normalize/MARC.pm | 193 +++++++++++++++++++++++++++++++++++ t/3-normalize-marc.t | 80 +++++++++++++++ t/3-normalize.t | 15 ++- 4 files changed, 309 insertions(+), 148 deletions(-) create mode 100644 lib/WebPAC/Normalize/MARC.pm create mode 100755 t/3-normalize-marc.t diff --git a/lib/WebPAC/Normalize.pm b/lib/WebPAC/Normalize.pm index 3f089fb..1d2eb65 100644 --- a/lib/WebPAC/Normalize.pm +++ b/lib/WebPAC/Normalize.pm @@ -39,16 +39,20 @@ use Carp qw/confess/; # debugging warn(s) my $debug = 0; +# FIXME use WebPAC::Normalize::ISBN; push @EXPORT, ( 'isbn_10', 'isbn_13' ); +use WebPAC::Normalize::MARC; +push @EXPORT, ( 'marc_template' ); + =head1 NAME WebPAC::Normalize - describe normalisaton rules using sets =cut -our $VERSION = '0.34'; +our $VERSION = '0.35'; =head1 SYNOPSIS @@ -134,6 +138,14 @@ sub _set_ds { $rec = shift or die "no record hash"; } +=head2 + + my $rec = _get_rec(); + +=cut + +sub _get_rec { $rec }; + =head2 _set_config Set current config hash @@ -860,150 +872,6 @@ sub marc_original_order { warn "## marc_record = ", dump( $marc_record ),$/ if ($debug > 1); } -=head2 marc_template - -=cut - -sub marc_template { - my $args = {@_}; - warn "## marc_template(",dump($args),")"; - - foreach ( qw/subfields_rename marc_template/ ) { -# warn "ref($_) = ",ref($args->{$_}); - die "$_ not ARRAY" if ref($args->{$_}) ne 'ARRAY'; - } - - my $r = $rec->{ $args->{from} } || return; - die "record field ", $args->{from}, " isn't array ",dump( $rec ) unless (ref($r) eq 'ARRAY'); - - my @subfields_rename = @{ $args->{subfields_rename} }; -# warn "### subfields_rename [$#subfields_rename] = ",dump( @subfields_rename ); - - confess "need mapping in pairs for subfields_rename" - if $#subfields_rename % 2 != 1; - - my ( $subfields_rename, $from_subfields, $to_subfields ); - while ( my ( $from, $to ) = splice(@subfields_rename, 0, 2) ) { - my ( $f, $t ) = ( - $from_subfields->{ $from }++, - $to_subfields->{ $to }++ - ); - $subfields_rename->{ $from }->[ $f ] = [ $to => $t ]; - } - warn "### subfields_rename = ",dump( $subfields_rename ),$/; - warn "### from_subfields = ", dump( $from_subfields ),$/; - warn "### to_subfields = ", dump( $to_subfields ),$/; - - my $fields_re = join('|', keys %$to_subfields ); - - my $pos_templates; - my $count; - my @marc_order; - my $marc_template_order; - my $fill_in; - my @marc_out; - - foreach my $template ( @{ $args->{marc_template} } ) { - $count = {}; - @marc_order = (); - sub my_count { - my $sf = shift; - my $nr = $count->{$sf}++; - push @marc_order, [ $sf, $nr ]; - return $sf . $nr; - } - my $pos_template = $template; - $pos_template =~ s/($fields_re)/my_count($1)/ge; - my $count_key = dump( $count ); - warn "### template: |$template| -> |$pos_template| count = $count_key marc_order = ",dump( @marc_order ),$/; - $pos_templates->{ $count_key } = $pos_template; - $marc_template_order->{ $pos_template } = [ @marc_order ]; - } - warn "### from ",dump( $args->{marc_template} ), " created ", dump( $pos_templates ), " and ", dump( $marc_template_order ); - - my $m; - - foreach my $r ( @{ $rec->{ $args->{from} } } ) { - - my $i1 = $r->{i1} || ' '; - my $i2 = $r->{i2} || ' '; - $m = [ $args->{to}, $i1, $i2 ]; - - warn "### r = ",dump( $r ); - - my ( $new_r, $from_count, $to_count ); - foreach my $sf ( keys %{$r} ) { - # skip everything which isn't one char subfield (e.g. 'subfields') - next unless $sf =~ m/^\w$/; - my $nr = $from_count->{$sf}++; - my $rename_to = $subfields_rename->{ $sf } || - die "can't find subfield rename for $sf/$nr in ", dump( $subfields_rename ); - warn "### rename $sf/$nr to ", dump( $rename_to->[$nr] ), $/; - my ( $to_sf, $to_nr ) = @{ $rename_to->[$nr] }; - $new_r->{ $to_sf }->[ $to_nr ] = [ $sf => $nr ]; - - $to_count->{ $to_sf }++; - } - - warn "### new_r = ",dump( $new_r ); - - my $from_count_key = dump( $to_count ); - - warn "### from_count = ",dump( $from_count ), $/; - warn "### to_count = ",dump( $to_count ), $/; - - my $template = $pos_templates->{ $from_count_key } || - die "I don't have template for:\n$from_count_key\n## available templates\n", dump( $pos_templates ); - - warn "### selected template: |$template|\n"; - - $fill_in = {}; - - my @templates = split(/\|/, $template ); - @templates = ( $template ); - - foreach my $sf ( @templates ) { - sub fill_in { - my ( $r, $sf, $nr ) = @_; - my ( $from_sf, $from_nr ) = @{ $new_r->{ $sf }->[ $nr ] }; - my $v = $r->{ $from_sf }; # || die "no $from_sf/$from_nr"; - warn "#### fill_in( $sf, $nr ) = $from_sf/$from_nr >>>> ",dump( $v ), $/; - if ( ref( $v ) eq 'ARRAY' ) { - $fill_in->{$sf}->[$nr] = $v->[$from_nr]; - return $v->[$from_nr]; - } elsif ( $from_nr == 0 ) { - $fill_in->{$sf}->[$nr] = $v; - return $v; - } else { - die "requested subfield $from_sf/$from_nr but it's ",dump( $v ); - } - } - warn "#### $sf <<<< $fields_re\n"; - $sf =~ s/($fields_re)(\d+)/fill_in($r,$1,$2)/ge; - warn "#### >>>> $sf with fill_in = ",dump( $fill_in ),$/; - } - - warn "## template: |$template|\n## marc_template_order = ",dump( $marc_template_order ); - - foreach my $sf ( @{ $marc_template_order->{$template} } ) { - my ( $sf, $nr ) = @$sf; - my $v = $fill_in->{$sf}->[$nr] || die "can't find fill_in $sf/$nr"; - warn "++ $sf/$nr |$v|\n"; - push @$m, ( $sf, $v ); - } - - warn "#### >>>> created marc: ", dump( $m ); - - push @marc_out, $m; - } - - warn "### marc_template produced: ",dump( @marc_out ); - - foreach my $marc ( @marc_out ) { - warn "+++ ",dump( $marc ); - push @{ $marc_record->[ $marc_record_offset ] }, $marc; - } -} =head2 marc_count @@ -1017,6 +885,17 @@ sub marc_count { return $#{ $marc_record }; } +=head2 _marc_push + + _marc_push( $marc ); + +=cut + +sub _marc_push { + my $marc = shift || die "no marc?"; + push @{ $marc_record->[ $marc_record_offset ] }, $marc; +} + =head1 Functions to extract data from input diff --git a/lib/WebPAC/Normalize/MARC.pm b/lib/WebPAC/Normalize/MARC.pm new file mode 100644 index 0000000..7e0c615 --- /dev/null +++ b/lib/WebPAC/Normalize/MARC.pm @@ -0,0 +1,193 @@ +package WebPAC::Normalize::MARC; +use Exporter 'import'; +@EXPORT = qw/ + marc_template +/; + +use strict; +use warnings; + +use Data::Dump qw/dump/; +use Carp qw/confess/; + +use WebPAC::Normalize; + +=head1 NAME + +WebPAC::Normalize::MARC - create MARC/ISO2709 records + +=cut + +=head1 FUNCTIONS + +=head2 marc_template + + marc_template( + from => 225, to => 440, + subfields_rename => [ + 'a' => 'a', + 'x' => 'x', + 'v' => 'v', + 'h' => 'n', + 'i' => 'p', + 'w' => 'v', + ], + isis_template => [ + 'a ; |v. |i', + 'a. |i ; |w', + ], + marc_template => [ + 'a, |x ; |v. |n, |p ; |v', + 'a ; |v. |p ; |v', + ], + ); + +=cut + +sub marc_template { + my $args = {@_}; + warn "## marc_template(",dump($args),")"; + + foreach ( qw/subfields_rename isis_template marc_template/ ) { +# warn "ref($_) = ",ref($args->{$_}); + die "$_ not ARRAY" if defined($args->{$_}) && ref($args->{$_}) ne 'ARRAY'; + } + + die "marc_template needs isis_template or marc_template" + if ! defined $args->{isis_template} && ! defined $args->{marc_template}; + + my $rec = WebPAC::Normalize::_get_rec() || die "_get_rec?"; + my $r = $rec->{ $args->{from} } || return; + die "record field ", $args->{from}, " isn't array ",dump( $rec ) unless (ref($r) eq 'ARRAY'); + + my @subfields_rename = @{ $args->{subfields_rename} }; +# warn "### subfields_rename [$#subfields_rename] = ",dump( @subfields_rename ); + + confess "need mapping in pairs for subfields_rename" + if $#subfields_rename % 2 != 1; + + my ( $subfields_rename, $from_subfields, $to_subfields ); + while ( my ( $from, $to ) = splice(@subfields_rename, 0, 2) ) { + my ( $f, $t ) = ( + $from_subfields->{ $from }++, + $to_subfields->{ $to }++ + ); + $subfields_rename->{ $from }->[ $f ] = [ $to => $t ]; + } + warn "### subfields_rename = ",dump( $subfields_rename ),$/; + warn "### from_subfields = ", dump( $from_subfields ),$/; + warn "### to_subfields = ", dump( $to_subfields ),$/; + + my $fields_re = join('|', keys %$to_subfields ); + + my $pos_templates; + my $fill_in; + my @marc_out; + + my ( $marc_template_order, @marc_order ); # = _parse_template( $args->{marc_template} ); + + my $templates = $args->{marc_template}; + + foreach my $template ( @{ $templates } ) { + my $count; + my @marc_order; + sub my_count { + my $sf = shift; + my $nr = $count->{$sf}++; + push @marc_order, [ $sf, $nr ]; + return $sf . $nr; + } + my $pos_template = $template; + $pos_template =~ s/($fields_re)/my_count($1)/ge; + my $count_key = dump( $count ); + warn "### template: |$template| -> |$pos_template| count = $count_key marc_order = ",dump( @marc_order ),$/; + $pos_templates->{ $count_key } = $pos_template; + $marc_template_order->{ $pos_template } = [ @marc_order ]; + } + warn "### from ",dump( $templates ), " created ", dump( $pos_templates ), " and ", dump( $marc_template_order ); + + my $m; + + foreach my $r ( @{ $rec->{ $args->{from} } } ) { + + my $i1 = $r->{i1} || ' '; + my $i2 = $r->{i2} || ' '; + $m = [ $args->{to}, $i1, $i2 ]; + + warn "### r = ",dump( $r ); + + my ( $new_r, $from_count, $to_count ); + foreach my $sf ( keys %{$r} ) { + # skip everything which isn't one char subfield (e.g. 'subfields') + next unless $sf =~ m/^\w$/; + my $nr = $from_count->{$sf}++; + my $rename_to = $subfields_rename->{ $sf } || + die "can't find subfield rename for $sf/$nr in ", dump( $subfields_rename ); + warn "### rename $sf/$nr to ", dump( $rename_to->[$nr] ), $/; + my ( $to_sf, $to_nr ) = @{ $rename_to->[$nr] }; + $new_r->{ $to_sf }->[ $to_nr ] = [ $sf => $nr ]; + + $to_count->{ $to_sf }++; + } + + warn "### new_r = ",dump( $new_r ); + + my $from_count_key = dump( $to_count ); + + warn "### from_count = ",dump( $from_count ), $/; + warn "### to_count = ",dump( $to_count ), $/; + + my $template = $pos_templates->{ $from_count_key } || + die "I don't have template for:\n$from_count_key\n## available templates\n", dump( $pos_templates ); + + warn "### selected template: |$template|\n"; + + $fill_in = {}; + + my @templates = split(/\|/, $template ); + @templates = ( $template ); + + foreach my $sf ( @templates ) { + sub fill_in { + my ( $r, $sf, $nr ) = @_; + my ( $from_sf, $from_nr ) = @{ $new_r->{ $sf }->[ $nr ] }; + my $v = $r->{ $from_sf }; # || die "no $from_sf/$from_nr"; + warn "#### fill_in( $sf, $nr ) = $from_sf/$from_nr >>>> ",dump( $v ), $/; + if ( ref( $v ) eq 'ARRAY' ) { + $fill_in->{$sf}->[$nr] = $v->[$from_nr]; + return $v->[$from_nr]; + } elsif ( $from_nr == 0 ) { + $fill_in->{$sf}->[$nr] = $v; + return $v; + } else { + die "requested subfield $from_sf/$from_nr but it's ",dump( $v ); + } + } + warn "#### $sf <<<< $fields_re\n"; + $sf =~ s/($fields_re)(\d+)/fill_in($r,$1,$2)/ge; + warn "#### >>>> $sf with fill_in = ",dump( $fill_in ),$/; + } + + warn "## template: |$template|\n## marc_template_order = ",dump( $marc_template_order ); + + foreach my $sf ( @{ $marc_template_order->{$template} } ) { + my ( $sf, $nr ) = @$sf; + my $v = $fill_in->{$sf}->[$nr] || die "can't find fill_in $sf/$nr"; + warn "++ $sf/$nr |$v|\n"; + push @$m, ( $sf, $v ); + } + + warn "#### >>>> created marc: ", dump( $m ); + + push @marc_out, $m; + } + + warn "### marc_template produced: ",dump( @marc_out ); + + foreach my $marc ( @marc_out ) { + warn "+++ ",dump( $marc ); + WebPAC::Normalize::_marc_push( $marc ); + } +} + +1; diff --git a/t/3-normalize-marc.t b/t/3-normalize-marc.t new file mode 100755 index 0000000..4d720ab --- /dev/null +++ b/t/3-normalize-marc.t @@ -0,0 +1,80 @@ +#!/usr/bin/perl -w + +use strict; +use blib; + +use Test::More tests => 4; + +BEGIN { + use_ok( 'WebPAC::Test' ); + use_ok( 'WebPAC::Normalize' ); + use_ok( 'WebPAC::Normalize::MARC' ); +} + +my $rec = { + '225' => [{ + 'a' => 'a-1-1', + 'i' => 'i-1-1', + 'v' => 'v-1-1', + 'w' => 'w-1-1', + 'h' => 'h-1-1', + 'x' => 'x-1-1', + },{ + 'a' => 'a-2-1', + 'v' => 'v-2-1', + 'i' => 'i-2-1', + },{ + 'a' => 'a-3-1', + 'i' => 'i-3-1', + 'v' => 'v-3-1', + },{ + 'a' => 'a-4-1', + 'v' => 'v-4-1', + 'i' => 'i-4-1', + 'w' => 'w-4-1', + },{ + 'a' => 'a-4-1', + 'v' => 'v-4-1', + 'i' => 'i-4-1', + },{ + 'a' => 'a-4-1', + 'i' => 'i-4-1', + 'w' => 'w-4-1', + }], +}; + +ok( _set_ds( $rec ), '_set_ds' ); + +ok( marc_template( + from => 225, to => 440, + subfields_rename => [ + 'a' => 'a', + 'x' => 'x', + 'v' => 'v', + 'h' => 'n', + 'i' => 'p', + 'w' => 'v', + ], + isis_template => [ + 'a ; |v. |i', + 'a. |i ; |w', + ], + marc_template => [ + 'a', + 'a, |x ; |v. |n, |p ; |v', + 'a ; |v. |p ; |v', + ], +), 'marc_template' ); + +ok(my $marc = WebPAC::Normalize::_get_marc_fields(), "_get_marc_fields"); +diag dump( $marc ) if $debug; + +is_deeply( $marc, + [ + [440, " ", " ", "a", "a-1-1", "x", "x-1-1", "v", "v-1-1", "n", "h-1-1", "p", "i-1-1", "v", "w-1-1", ], + [440, " ", " ", "a", "a-2-1", "p", "i-2-1", "v", "v-2-1"], + [440, " ", " ", "a", "a-3-1", "p", "i-3-1", "v", "v-3-1"], + [440, " ", " ", "a", "a-4-1", "v", "v-4-1", "p", "i-4-1", "v", "w-4-1"], + [440, " ", " ", "a", "a-5-1"], + ], +'is_deeply'); diff --git a/t/3-normalize.t b/t/3-normalize.t index 105c279..36b2704 100755 --- a/t/3-normalize.t +++ b/t/3-normalize.t @@ -523,7 +523,7 @@ sub test_s { } ok(my $marc = WebPAC::Normalize::_get_marc_fields(), "_get_marc_fields"); - diag dump( $marc ) if ($debug); + diag dump( $marc ) if $debug; diag "expects:\n", dump($struct) if ($debug > 1); is_deeply( $marc, $struct, $msg ); } @@ -918,7 +918,13 @@ sub test_s { 'i' => 'i-4-1', 'w' => 'w-4-1', },{ - 'a' => 'a-5-1', + 'a' => 'a-4-1', + 'v' => 'v-4-1', + 'i' => 'i-4-1', + },{ + 'a' => 'a-4-1', + 'i' => 'i-4-1', + 'w' => 'w-4-1', }], }, qq{ @@ -932,11 +938,14 @@ sub test_s { 'i' => 'p', 'w' => 'v', ], + isis_template => [ + 'a ; |v. |i', + 'a. |i ; |w', + ], marc_template => [ 'a', 'a, |x ; |v. |n, |p ; |v', 'a ; |v. |p ; |v', - 'a. |p ; |v', ], ); }, -- 2.20.1