r1567@llin: dpavlin | 2007-11-07 12:54:20 +0100

 huge dump of marc_template, a new way to specify mappings
 which is basically WebPAC v1 in a sub :-)

git-svn-id: svn+ssh://mjesec/home/dpavlin/svn/webpac2/trunk@1013 07558da8-63fa-0310-ba24-9fe276d99e06

diff --git a/lib/WebPAC/Normalize.pm b/lib/WebPAC/Normalize.pm
index 71cb43e..ea4c49e 100644 (file)
--- a/lib/WebPAC/Normalize.pm
+++ b/lib/WebPAC/Normalize.pm
@@ -13,6 +13,7 @@ our @EXPORT = qw/
        marc_compose marc_leader marc_fixed
        marc_duplicate marc_remove marc_count
        marc_original_order
+       marc_template
 
        rec1 rec2 rec
        frec
@@ -47,7 +48,7 @@ WebPAC::Normalize - describe normalisaton rules using sets
 
 =cut
 
-our $VERSION = '0.32';
+our $VERSION = '0.33';
 
 =head1 SYNOPSIS
 
@@ -859,6 +860,142 @@ 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\n" 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} ) {
+                       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 = {};
+
+               foreach my $sf ( split(/\|/, $template ) ) {
+                       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 );
+       return @marc_out;
+}
+
 =head2 marc_count
 
 Return number of MARC records created using L</marc_duplicate>.

diff --git a/t/3-normalize.t b/t/3-normalize.t
index 3c96d97..ee0c802 100755 (executable)
--- a/t/3-normalize.t
+++ b/t/3-normalize.t
@@ -514,10 +514,11 @@ sub test_s {
                _clean_ds();
                _set_ds($rec);
 
-               foreach my $r (split(/;/, $rules)) {
+               foreach my $r (split(/;\s*$/, $rules)) {
                        $r =~ s/[\s\n\r]+/ /gs;
                        $r =~ s/^\s+//gs;
                        $r =~ s/\s+$//gs;
+                       diag "rule: $r" if $debug;
                        test_s($r) if ($r);
                }
 
@@ -863,5 +864,69 @@ sub test_s {
                [ '1-55860-701-3', '1-55860-701-3' ],
        'isbn_10' );
 
+       # marc_template
+
+       test_rec_rules(
+               'marc_template',
+               {
+                       '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',
+                       }],
+               },
+               qq{
+                       marc_template(
+                               from => 225, to => 440,
+                               subfields_rename => [
+                                       'a' => 'a',
+                                       'x' => 'x',
+                                       'v' => 'v',
+                                       'h' => 'n',
+                                       'i' => 'p',
+                                       'w' => 'v',
+                               ],
+                               marc_template => [
+                                       'a, |x ; |v. |n, |p ; |v',
+                                       'a ; |v. |p ; |v',
+                                       'a. |p ; |v',
+                               ],
+                       );
+               },
+               [
+                       [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"],
+                       ],
+               ],
+       );
 }