WebPAC/Normalize/MARC.pm

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;

my $debug = 0;

=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',
                ],
        );

Returns number of records produced.

=cut

sub marc_template {
        my $args = {@_};
        warn "## marc_template(",dump($args),")",$/ if $debug;

        foreach ( qw/subfields_rename isis_template marc_template/ ) {
#               warn "ref($_) = ",ref($args->{$_})  if $debug;
                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 )  if $debug;

        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 ),$/ if $debug;
        warn "### from_subfields = ", dump( $from_subfields ),$/ if $debug;
        warn "### to_subfields = ", dump( $to_subfields ),$/ if $debug;

        our $_template;

        $_template->{isis}->{fields_re} = join('|', keys %$from_subfields );
        $_template->{marc}->{fields_re} = join('|', keys %$to_subfields );

        my @marc_out;

        sub _parse_template {
                my ( $name, $templates ) = @_;

                my $fields_re = $_template->{$name}->{fields_re} || die "can't find $name in ",dump( $_template->{$name}->{fields_re} );

                foreach my $template ( @{ $templates } ) {
                        our $count = {};
                        our @order = ();
                        sub my_count {
                                my $sf = shift;
                                my $nr = $count->{$sf}++;
                                push @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 order = ",dump( @order ),$/ if $debug;
                        $_template->{$name}->{pos}->{ $count_key } = $pos_template;
                        $_template->{$name}->{order}->{ $pos_template } = [ @order ];
                }
                warn "### from ",dump( $templates ), " using $fields_re created ", dump( $_template ),$/ if $debug;
        }

        _parse_template( 'marc', $args->{marc_template} );
        _parse_template( 'isis', $args->{isis_template} );
        warn "### _template = ",dump( $_template ),$/ if $debug;

        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 ),$/ if $debug;

                my ( $from_mapping, $to_mapping, $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] ),$/ if $debug;
                        my ( $to_sf, $to_nr ) = @{ $rename_to->[$nr] };
                        $from_mapping->{ $sf }->[ $nr ] = [ $to_sf => $to_nr ];
                        $to_mapping->{ $to_sf }->[ $to_nr ] = [ $sf => $nr ];

                        $to_count->{ $to_sf }++;
                }

                warn "### to_mapping = ",dump( $to_mapping ),$/ if $debug;

                my $count_key = {
                        from => dump( $from_count ),
                        to   => dump( $to_count),
                };

                warn "### count_key = ",dump( $count_key ),$/ if $debug;

                my $processed_templates = 0;

                # this defines order of traversal
                foreach ( qw/isis:from marc:to/ ) {
                        my ($name,$count_name) = split(/:/);

                        my $ckey = $count_key->{$count_name} || die "can't find count_key $count_name in ",dump( $count_key );

                        my $template = $_template->{$name}->{pos}->{ $ckey } || next;
                        $processed_templates++;

                        warn "### traverse $name $count_name selected template: |$template|\n",$/ if $debug;

                        our $fill_in = {};

                        my @templates = split(/\|/, $template );
                        @templates = ( $template );

                        foreach my $sf ( @templates ) {
                                sub fill_in {
                                        my ( $name, $r, $sf, $nr ) = @_;
                                        my ( $from_sf, $from_nr );
                                        if ( $name eq 'marc' ) {
                                                ( $from_sf, $from_nr ) = @{ $to_mapping->{$sf}->[$nr] };
                                        } else {
                                                ( $from_sf, $from_nr ) = ( $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 $debug;
                                        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 );
                                        }
                                }
                                my $fields_re = $_template->{$name}->{fields_re} || die "can't find $name in ",dump( $_template->{$name}->{fields_re} );
                                warn "#### $sf <<<< $fields_re\n",$/ if $debug;
                                $sf =~ s/($fields_re)(\d+)/fill_in($name,$r,$1,$2)/ge;
                                warn "#### >>>> $sf with fill_in = ",dump( $fill_in ),$/ if $debug;
                        }

                        warn "## template: |$template|\n## _template->$name = ",dump( $_template->{$name} ),$/ if $debug;

                        foreach my $sf ( @{ $_template->{$name}->{order}->{$template} } ) {
                                my ( $sf, $nr ) = @$sf;
                                my $v = $fill_in->{$sf}->[$nr] || die "can't find fill_in $sf/$nr";
                                if ( $name eq 'isis') {
                                        ( $sf, $nr ) = @{ $from_mapping->{$sf}->[$nr] };
                                }
                                warn "++ $sf/$nr |$v|\n" if $debug;
                                push @$m, ( $sf, $v );
                        }

                        warn "#### >>>> created MARC record: ", dump( $m ),$/ if $debug;

                        push @marc_out, $m;
                }
        
                die "I don't have template for fields ",dump( $count_key ), "\n## available templates\n", dump( $_template ) unless $processed_templates;
                warn ">>> $processed_templates templates applied to data\n",$/ if $debug;
        }


        my $recs = 0;

        foreach my $marc ( @marc_out ) {
                warn "+++ ",dump( $marc ),$/ if $debug;
                WebPAC::Normalize::_marc_push( $marc );
                $recs++;
        }

        warn "### marc_template produced $recs MARC records: ",dump( @marc_out ),$/ if $debug;

        return $recs;
}

1;
1	dpavlin	1021	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	dpavlin	1028	my $debug = 0;
16
17	dpavlin	1021	=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	dpavlin	1026	Returns number of records produced.
48
49	dpavlin	1021	=cut
50
51			sub marc_template {
52			my $args = {@_};
53	dpavlin	1028	warn "## marc_template(",dump($args),")",$/ if $debug;
54	dpavlin	1021
55			foreach ( qw/subfields_rename isis_template marc_template/ ) {
56	dpavlin	1028	# warn "ref($_) = ",ref($args->{$_}) if $debug;
57	dpavlin	1021	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	dpavlin	1028	# warn "### subfields_rename [$#subfields_rename] = ",dump( @subfields_rename ) if $debug;
69	dpavlin	1021
70			confess "need mapping in pairs for subfields_rename"
71			if $#subfields_rename % 2 != 1;
72
73			my ( $subfields_rename, $from_subfields, $to_subfields );
74			while ( my ( $from, $to ) = splice(@subfields_rename, 0, 2) ) {
75			my ( $f, $t ) = (
76			$from_subfields->{ $from }++,
77			$to_subfields->{ $to }++
78			);
79			$subfields_rename->{ $from }->[ $f ] = [ $to => $t ];
80			}
81	dpavlin	1028	warn "### subfields_rename = ",dump( $subfields_rename ),$/ if $debug;
82			warn "### from_subfields = ", dump( $from_subfields ),$/ if $debug;
83			warn "### to_subfields = ", dump( $to_subfields ),$/ if $debug;
84	dpavlin	1021
85	dpavlin	1025	our $_template;
86	dpavlin	1021
87	dpavlin	1026	$_template->{isis}->{fields_re} = join('\|', keys %$from_subfields );
88			$_template->{marc}->{fields_re} = join('\|', keys %$to_subfields );
89	dpavlin	1025
90	dpavlin	1021	my @marc_out;
91
92	dpavlin	1023	sub _parse_template {
93	dpavlin	1024	my ( $name, $templates ) = @_;
94	dpavlin	1021
95	dpavlin	1026	my $fields_re = $_template->{$name}->{fields_re} \|\| die "can't find $name in ",dump( $_template->{$name}->{fields_re} );
96	dpavlin	1025
97	dpavlin	1023	foreach my $template ( @{ $templates } ) {
98			our $count = {};
99	dpavlin	1025	our @order = ();
100	dpavlin	1023	sub my_count {
101			my $sf = shift;
102			my $nr = $count->{$sf}++;
103	dpavlin	1025	push @order, [ $sf, $nr ];
104	dpavlin	1023	return $sf . $nr;
105			}
106			my $pos_template = $template;
107			$pos_template =~ s/($fields_re)/my_count($1)/ge;
108			my $count_key = dump( $count );
109	dpavlin	1028	warn "### template: \|$template\| -> \|$pos_template\| count = $count_key order = ",dump( @order ),$/ if $debug;
110	dpavlin	1024	$_template->{$name}->{pos}->{ $count_key } = $pos_template;
111	dpavlin	1025	$_template->{$name}->{order}->{ $pos_template } = [ @order ];
112	dpavlin	1021	}
113	dpavlin	1028	warn "### from ",dump( $templates ), " using $fields_re created ", dump( $_template ),$/ if $debug;
114	dpavlin	1021	}
115
116	dpavlin	1024	_parse_template( 'marc', $args->{marc_template} );
117			_parse_template( 'isis', $args->{isis_template} );
118	dpavlin	1028	warn "### _template = ",dump( $_template ),$/ if $debug;
119	dpavlin	1023
120	dpavlin	1021	my $m;
121
122			foreach my $r ( @{ $rec->{ $args->{from} } } ) {
123
124			my $i1 = $r->{i1} \|\| ' ';
125			my $i2 = $r->{i2} \|\| ' ';
126			$m = [ $args->{to}, $i1, $i2 ];
127
128	dpavlin	1028	warn "### r = ",dump( $r ),$/ if $debug;
129	dpavlin	1021
130	dpavlin	1026	my ( $from_mapping, $to_mapping, $from_count, $to_count );
131	dpavlin	1021	foreach my $sf ( keys %{$r} ) {
132			# skip everything which isn't one char subfield (e.g. 'subfields')
133			next unless $sf =~ m/^\w$/;
134			my $nr = $from_count->{$sf}++;
135			my $rename_to = $subfields_rename->{ $sf } \|\|
136			die "can't find subfield rename for $sf/$nr in ", dump( $subfields_rename );
137	dpavlin	1028	warn "### rename $sf/$nr to ", dump( $rename_to->[$nr] ),$/ if $debug;
138	dpavlin	1021	my ( $to_sf, $to_nr ) = @{ $rename_to->[$nr] };
139	dpavlin	1026	$from_mapping->{ $sf }->[ $nr ] = [ $to_sf => $to_nr ];
140			$to_mapping->{ $to_sf }->[ $to_nr ] = [ $sf => $nr ];
141	dpavlin	1021
142			$to_count->{ $to_sf }++;
143			}
144
145	dpavlin	1028	warn "### to_mapping = ",dump( $to_mapping ),$/ if $debug;
146	dpavlin	1021
147	dpavlin	1025	my $count_key = {
148			from => dump( $from_count ),
149			to => dump( $to_count),
150			};
151	dpavlin	1021
152	dpavlin	1028	warn "### count_key = ",dump( $count_key ),$/ if $debug;
153	dpavlin	1021
154	dpavlin	1025	my $processed_templates = 0;
155	dpavlin	1021
156	dpavlin	1025	# this defines order of traversal
157			foreach ( qw/isis:from marc:to/ ) {
158			my ($name,$count_name) = split(/:/);
159	dpavlin	1021
160	dpavlin	1025	my $ckey = $count_key->{$count_name} \|\| die "can't find count_key $count_name in ",dump( $count_key );
161	dpavlin	1021
162	dpavlin	1025	my $template = $_template->{$name}->{pos}->{ $ckey } \|\| next;
163			$processed_templates++;
164	dpavlin	1021
165	dpavlin	1028	warn "### traverse $name $count_name selected template: \|$template\|\n",$/ if $debug;
166	dpavlin	1025
167			our $fill_in = {};
168
169			my @templates = split(/\\|/, $template );
170			@templates = ( $template );
171
172			foreach my $sf ( @templates ) {
173			sub fill_in {
174			my ( $name, $r, $sf, $nr ) = @_;
175	dpavlin	1028	my ( $from_sf, $from_nr );
176	dpavlin	1025	if ( $name eq 'marc' ) {
177	dpavlin	1026	( $from_sf, $from_nr ) = @{ $to_mapping->{$sf}->[$nr] };
178	dpavlin	1025	} else {
179			( $from_sf, $from_nr ) = ( $sf, $nr );
180			}
181			my $v = $r->{ $from_sf }; # \|\| die "no $from_sf/$from_nr";
182	dpavlin	1028	warn "#### fill_in( $sf, $nr ) = $from_sf/$from_nr >>>> ",dump( $v ),$/ if $debug;
183	dpavlin	1025	if ( ref( $v ) eq 'ARRAY' ) {
184			$fill_in->{$sf}->[$nr] = $v->[$from_nr];
185			return $v->[$from_nr];
186			} elsif ( $from_nr == 0 ) {
187			$fill_in->{$sf}->[$nr] = $v;
188			return $v;
189			} else {
190			die "requested subfield $from_sf/$from_nr but it's ",dump( $v );
191			}
192	dpavlin	1021	}
193	dpavlin	1026	my $fields_re = $_template->{$name}->{fields_re} \|\| die "can't find $name in ",dump( $_template->{$name}->{fields_re} );
194	dpavlin	1028	warn "#### $sf <<<< $fields_re\n",$/ if $debug;
195	dpavlin	1025	$sf =~ s/($fields_re)(\d+)/fill_in($name,$r,$1,$2)/ge;
196	dpavlin	1028	warn "#### >>>> $sf with fill_in = ",dump( $fill_in ),$/ if $debug;
197	dpavlin	1021	}
198
199	dpavlin	1028	warn "## template: \|$template\|\n## _template->$name = ",dump( $_template->{$name} ),$/ if $debug;
200	dpavlin	1021
201	dpavlin	1025	foreach my $sf ( @{ $_template->{$name}->{order}->{$template} } ) {
202			my ( $sf, $nr ) = @$sf;
203			my $v = $fill_in->{$sf}->[$nr] \|\| die "can't find fill_in $sf/$nr";
204	dpavlin	1026	if ( $name eq 'isis') {
205			( $sf, $nr ) = @{ $from_mapping->{$sf}->[$nr] };
206			}
207	dpavlin	1028	warn "++ $sf/$nr \|$v\|\n" if $debug;
208	dpavlin	1025	push @$m, ( $sf, $v );
209			}
210	dpavlin	1021
211	dpavlin	1028	warn "#### >>>> created MARC record: ", dump( $m ),$/ if $debug;
212	dpavlin	1025
213			push @marc_out, $m;
214			}
215
216			die "I don't have template for fields ",dump( $count_key ), "\n## available templates\n", dump( $_template ) unless $processed_templates;
217	dpavlin	1028	warn ">>> $processed_templates templates applied to data\n",$/ if $debug;
218	dpavlin	1021	}
219
220
221	dpavlin	1026	my $recs = 0;
222	dpavlin	1025
223	dpavlin	1021	foreach my $marc ( @marc_out ) {
224	dpavlin	1028	warn "+++ ",dump( $marc ),$/ if $debug;
225	dpavlin	1021	WebPAC::Normalize::_marc_push( $marc );
226	dpavlin	1026	$recs++;
227	dpavlin	1021	}
228	dpavlin	1026
229	dpavlin	1028	warn "### marc_template produced $recs MARC records: ",dump( @marc_out ),$/ if $debug;
230
231			return $recs;
232	dpavlin	1021	}
233
234			1;