git.rot13.org Git - webpac2/blob - lib/WebPAC/Normalize/MARC.pm

   1 package WebPAC::Normalize::MARC;
   2 use Exporter 'import';
   3 @EXPORT = qw/
   4         marc_template
   5 /;
   6
   7 use strict;
   8 use warnings;
   9
  10 use Data::Dump qw/dump/;
  11 use Carp qw/confess/;
  12
  13 use WebPAC::Normalize;
  14
  15 my $debug = 1;
  16
  17 =head1 NAME
  18
  19 WebPAC::Normalize::MARC - create MARC/ISO2709 records
  20
  21 =cut
  22
  23 =head1 FUNCTIONS
  24
  25 =head2 marc_template
  26
  27         marc_template(
  28                 from => 225, to => 440,
  29                 subfields_rename => [
  30                         'a' => 'a',
  31                         'x' => 'x',
  32                         'v' => 'v',
  33                         'h' => 'n',
  34                         'i' => 'p',
  35                         'w' => 'v',
  36                 ],
  37                 isis_template => [
  38                         'a ; |v. |i',
  39                         'a. |i ; |w',
  40                 ],
  41                 marc_template => [
  42                         'a, |x ; |v. |n, |p ; |v',
  43                         'a ; |v. |p ; |v',
  44                 ],
  45         );
  46
  47 Returns number of records produced.
  48
  49 =cut
  50
  51 sub marc_template {
  52         my $args = {@_};
  53         warn "## marc_template(",dump($args),")",$/ if $debug;
  54
  55         foreach ( qw/subfields_rename isis_template marc_template/ ) {
  56 #               warn "ref($_) = ",ref($args->{$_})  if $debug;
  57                 die "$_ not ARRAY" if defined($args->{$_}) && ref($args->{$_}) ne 'ARRAY';
  58         }
  59
  60         die "marc_template needs isis_template or marc_template"
  61                 if ! defined $args->{isis_template} && ! defined $args->{marc_template};
  62
  63         my $rec = WebPAC::Normalize::_get_rec() || die "_get_rec?";
  64         my $r = $rec->{ $args->{from} } || return;
  65         die "record field ", $args->{from}, " isn't array ",dump( $rec ) unless (ref($r) eq 'ARRAY');
  66
  67         my @subfields_rename = @{ $args->{subfields_rename} };
  68 #       warn "### subfields_rename [$#subfields_rename] = ",dump( @subfields_rename )  if $debug;
  69
  70         confess "need mapping in pairs for subfields_rename"
  71                 if $#subfields_rename % 2 != 1;
  72
  73         my ( $subfields_rename, $from_subfields );
  74         our $to_subfields = {};
  75         while ( my ( $from, $to ) = splice(@subfields_rename, 0, 2) ) {
  76                 my ( $f, $t ) = (
  77                         $from_subfields->{ $from }++,
  78                         $to_subfields->{ $to }++
  79                 );
  80                 $subfields_rename->{ $from }->[ $f ] = [ $to => $t ];
  81         }
  82         warn "### subfields_rename = ",dump( $subfields_rename ),$/ if $debug;
  83         warn "### from_subfields = ", dump( $from_subfields ),$/ if $debug;
  84         warn "### to_subfields = ", dump( $to_subfields ),$/ if $debug;
  85
  86         our $_template;
  87
  88         $_template->{isis}->{fields_re} = join('|', keys %$from_subfields );
  89         $_template->{marc}->{fields_re} = join('|', keys %$to_subfields );
  90
  91         my @marc_out;
  92
  93         sub _parse_template {
  94                 my ( $name, $templates ) = @_;
  95
  96                 my $fields_re = $_template->{$name}->{fields_re} || die "can't find $name in ",dump( $_template->{$name}->{fields_re} );
  97
  98                 foreach my $template ( @{ $templates } ) {
  99                         our $count = {};
 100                         our @order = ();
 101                         sub my_count {
 102                                 my $sf = shift;
 103                                 my $nr = $count->{$sf}++;
 104                                 push @order, [ $sf, $nr ];
 105                                 return $sf . $nr;
 106                         }
 107                         my $pos_template = $template;
 108                         $pos_template =~ s/($fields_re)/my_count($1)/ge;
 109                         my $count_key = dump( $count );
 110                         warn "### template: |$template| -> |$pos_template| count = $count_key order = ",dump( @order ),$/ if $debug;
 111                         $_template->{$name}->{pos}->{ $count_key } = $pos_template;
 112                         $_template->{$name}->{order}->{ $pos_template } = [ @order ];
 113                 }
 114                 warn "### from ",dump( $templates ), " using $fields_re created ", dump( $_template ),$/ if $debug;
 115         }
 116
 117         _parse_template( 'marc', $args->{marc_template} );
 118         _parse_template( 'isis', $args->{isis_template} );
 119         warn "### _template = ",dump( $_template ),$/ if $debug;
 120
 121         my $m;
 122
 123         foreach my $r ( @{ $rec->{ $args->{from} } } ) {
 124
 125                 my $i1 = $r->{i1} || ' ';
 126                 my $i2 = $r->{i2} || ' ';
 127                 $m = [ $args->{to}, $i1, $i2 ];
 128
 129                 warn "### r = ",dump( $r ),$/ if $debug;
 130
 131                 my ( $from_mapping, $to_mapping, $from_count, $to_count );
 132                 foreach my $from_sf ( keys %{$r} ) {
 133                         # skip everything which isn't one char subfield (e.g. 'subfields')
 134                         next unless $from_sf =~ m/^\w$/;
 135                         my $from_nr = $from_count->{$from_sf}++;
 136                         my $rename_to = $subfields_rename->{ $from_sf } ||
 137                                 die "can't find subfield rename for $from_sf/$from_nr in ", dump( $subfields_rename );
 138                         my ( $to_sf, $to_nr ) = @{ $rename_to->[$from_nr] };
 139                         $to_mapping->{ $to_sf }->[ $to_nr ] = [ $from_sf => $from_nr ];
 140
 141                         my $to_nr2 = $to_count->{ $to_sf }++;
 142                         $from_mapping->{ $from_sf }->[ $from_nr ] = [ $to_sf => $to_nr2 ];
 143
 144                         warn "### from $from_sf/$from_nr -> $to_sf/$to_nr\tto $from_sf/$from_nr -> $to_sf/$to_nr2\n" if $debug;
 145                 }
 146
 147                 warn "### from_mapping = ",dump( $from_mapping ), "\n### to_mapping = ",dump( $to_mapping ),$/ if $debug;
 148
 149                 my $count_key = {
 150                         from => dump( $from_count ),
 151                         to   => dump( $to_count),
 152                 };
 153
 154                 warn "### count_key = ",dump( $count_key ),$/ if $debug;
 155
 156                 my $processed_templates = 0;
 157
 158                 # this defines order of traversal
 159                 foreach ( qw/isis:from marc:to/ ) {
 160                         my ($name,$count_name) = split(/:/);
 161
 162                         my $ckey = $count_key->{$count_name} || die "can't find count_key $count_name in ",dump( $count_key );
 163
 164                         my $template = $_template->{$name}->{pos}->{ $ckey } || next;
 165                         $processed_templates++;
 166
 167                         warn "### traverse $name $count_name selected template: |$template|\n",$/ if $debug;
 168
 169                         our $fill_in = {};
 170
 171                         my @templates = split(/\|/, $template );
 172                         @templates = ( $template );
 173
 174                         foreach my $sf ( @templates ) {
 175                                 sub fill_in {
 176                                         my ( $name, $r, $sf, $nr ) = @_;
 177                                         my ( $from_sf, $from_nr );
 178                                         if ( $name eq 'marc' ) {
 179                                                 die "no $sf/$nr in to_mapping: ",dump( $to_mapping ), " form record ",dump( $r ) unless defined $to_mapping->{$sf}->[$nr];
 180                                                 ( $from_sf, $from_nr ) = @{ $to_mapping->{$sf}->[$nr] };
 181                                         } else {
 182                                                 ( $from_sf, $from_nr ) = ( $sf, $nr );
 183                                         }
 184                                         my $v = $r->{ $from_sf }; # || die "no $from_sf/$from_nr";
 185                                         warn "#### fill_in( $sf, $nr ) = $from_sf/$from_nr >>>> ",dump( $v ),$/ if $debug;
 186                                         if ( ref( $v ) eq 'ARRAY' ) {
 187                                                 $fill_in->{$sf}->[$nr] = $v->[$from_nr];
 188                                                 return $v->[$from_nr];
 189                                         } elsif ( $from_nr == 0 ) {
 190                                                 $fill_in->{$sf}->[$nr] = $v;
 191                                                 return $v;
 192                                         } else {
 193                                                 die "requested subfield $from_sf/$from_nr but it's ",dump( $v );
 194                                         }
 195                                 }
 196                                 my $fields_re = $_template->{$name}->{fields_re} || die "can't find $name in ",dump( $_template->{$name}->{fields_re} );
 197                                 warn "#### $sf <<<< $fields_re\n",$/ if $debug;
 198                                 $sf =~ s/($fields_re)(\d+)/fill_in($name,$r,$1,$2)/ge;
 199                                 warn "#### >>>> $sf with fill_in = ",dump( $fill_in ),$/ if $debug;
 200                         }
 201
 202                         warn "## template: |$template|\n## _template->$name = ",dump( $_template->{$name} ),$/ if $debug;
 203
 204                         foreach my $sf ( @{ $_template->{$name}->{order}->{$template} } ) {
 205                                 my ( $sf, $nr ) = @$sf;
 206                                 my $v = $fill_in->{$sf}->[$nr] || die "can't find fill_in $sf/$nr";
 207                                 if ( $name eq 'isis') {
 208                                         ( $sf, $nr ) = @{ $from_mapping->{$sf}->[$nr] };
 209                                 }
 210                                 warn "++ $sf/$nr |$v|\n" if $debug;
 211                                 push @$m, ( $sf, $v );
 212                         }
 213
 214                         warn "#### >>>> created MARC record: ", dump( $m ),$/ if $debug;
 215
 216                         push @marc_out, $m;
 217
 218                         last;
 219                 }
 220
 221                 die "I don't have template for fields ",dump( $count_key ), "\n## available templates\n", dump( $_template ) unless $processed_templates;
 222                 warn ">>> $processed_templates templates applied to data\n",$/ if $debug;
 223         }
 224
 225
 226         my $recs = 0;
 227
 228         foreach my $marc ( @marc_out ) {
 229                 warn "+++ ",dump( $marc ),$/ if $debug;
 230                 WebPAC::Normalize::_marc_push( $marc );
 231                 $recs++;
 232         }
 233
 234         warn "### marc_template produced $recs MARC records: ",dump( @marc_out ),$/ if $debug;
 235
 236         return $recs;
 237 }
 238
 239 1;