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 );
        our $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 $from_sf ( keys %{$r} ) {
                        # skip everything which isn't one char subfield (e.g. 'subfields')
                        next unless $from_sf =~ m/^\w$/;
                        my $from_nr = $from_count->{$from_sf}++;
                        my $rename_to = $subfields_rename->{ $from_sf } ||
                                die "can't find subfield rename for $from_sf/$from_nr in ", dump( $subfields_rename );
                        my ( $to_sf, $to_nr ) = @{ $rename_to->[$from_nr] };
                        $to_mapping->{ $to_sf }->[ $to_nr ] = [ $from_sf => $from_nr ];

                        my $to_nr2 = $to_count->{ $to_sf }++;
                        $from_mapping->{ $from_sf }->[ $from_nr ] = [ $to_sf => $to_nr2 ];

                        warn "### from $from_sf/$from_nr -> $to_sf/$to_nr\tto $from_sf/$from_nr -> $to_sf/$to_nr2\n" if $debug;
                }

                warn "### from_mapping = ",dump( $from_mapping ), "\n### 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 ) unless @templates;

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

                        foreach my $sf ( @templates ) {
                                sub fill_in {
                                        my ( $name, $r, $pre, $sf, $nr, $post ) = @_;
                                        warn "#### fill_in( $name, r, '$pre', $sf, $nr, '$post' )\n" if $debug;
                                        my ( $from_sf, $from_nr );
                                        if ( $name eq 'marc' ) {
                                                die "no $sf/$nr in to_mapping: ",dump( $to_mapping ), " form record ",dump( $r ) unless defined $to_mapping->{$sf}->[$nr];
                                                ( $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";
                                        if ( ref( $v ) eq 'ARRAY' ) {
                                                $v = $pre . $v->[$from_nr] . $post;
                                        } elsif ( $from_nr == 0 ) {
                                                $v = $pre . $v . $post;
                                        } else {
                                                die "requested subfield $from_sf/$from_nr but it's ",dump( $v );
                                        }
                                        warn "#### fill_in( $sf, $nr ) = $from_sf/$from_nr >>>> ",dump( $v ),$/ if $debug;
                                        $fill_in->{$sf}->[$nr] = $v;
                                        return $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,$3,$4)/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;

                        last;
                }
        
                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	1031	my $debug = 0;
16	dpavlin	1028
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	dpavlin	1029	my ( $subfields_rename, $from_subfields );
74			our $to_subfields = {};
75	dpavlin	1021	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	dpavlin	1028	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	dpavlin	1021
86	dpavlin	1025	our $_template;
87	dpavlin	1021
88	dpavlin	1026	$_template->{isis}->{fields_re} = join('\|', keys %$from_subfields );
89			$_template->{marc}->{fields_re} = join('\|', keys %$to_subfields );
90	dpavlin	1025
91	dpavlin	1021	my @marc_out;
92
93	dpavlin	1023	sub _parse_template {
94	dpavlin	1024	my ( $name, $templates ) = @_;
95	dpavlin	1021
96	dpavlin	1026	my $fields_re = $_template->{$name}->{fields_re} \|\| die "can't find $name in ",dump( $_template->{$name}->{fields_re} );
97	dpavlin	1025
98	dpavlin	1023	foreach my $template ( @{ $templates } ) {
99			our $count = {};
100	dpavlin	1025	our @order = ();
101	dpavlin	1023	sub my_count {
102			my $sf = shift;
103			my $nr = $count->{$sf}++;
104	dpavlin	1025	push @order, [ $sf, $nr ];
105	dpavlin	1023	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	dpavlin	1028	warn "### template: \|$template\| -> \|$pos_template\| count = $count_key order = ",dump( @order ),$/ if $debug;
111	dpavlin	1024	$_template->{$name}->{pos}->{ $count_key } = $pos_template;
112	dpavlin	1025	$_template->{$name}->{order}->{ $pos_template } = [ @order ];
113	dpavlin	1021	}
114	dpavlin	1028	warn "### from ",dump( $templates ), " using $fields_re created ", dump( $_template ),$/ if $debug;
115	dpavlin	1021	}
116
117	dpavlin	1024	_parse_template( 'marc', $args->{marc_template} );
118			_parse_template( 'isis', $args->{isis_template} );
119	dpavlin	1028	warn "### _template = ",dump( $_template ),$/ if $debug;
120	dpavlin	1023
121	dpavlin	1021	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	dpavlin	1028	warn "### r = ",dump( $r ),$/ if $debug;
130	dpavlin	1021
131	dpavlin	1026	my ( $from_mapping, $to_mapping, $from_count, $to_count );
132	dpavlin	1029	foreach my $from_sf ( keys %{$r} ) {
133	dpavlin	1021	# skip everything which isn't one char subfield (e.g. 'subfields')
134	dpavlin	1029	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	dpavlin	1021
141	dpavlin	1029	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	dpavlin	1021	}
146
147	dpavlin	1029	warn "### from_mapping = ",dump( $from_mapping ), "\n### to_mapping = ",dump( $to_mapping ),$/ if $debug;
148	dpavlin	1021
149	dpavlin	1025	my $count_key = {
150			from => dump( $from_count ),
151			to => dump( $to_count),
152			};
153	dpavlin	1021
154	dpavlin	1028	warn "### count_key = ",dump( $count_key ),$/ if $debug;
155	dpavlin	1021
156	dpavlin	1025	my $processed_templates = 0;
157	dpavlin	1021
158	dpavlin	1025	# this defines order of traversal
159			foreach ( qw/isis:from marc:to/ ) {
160			my ($name,$count_name) = split(/:/);
161	dpavlin	1021
162	dpavlin	1025	my $ckey = $count_key->{$count_name} \|\| die "can't find count_key $count_name in ",dump( $count_key );
163	dpavlin	1021
164	dpavlin	1025	my $template = $_template->{$name}->{pos}->{ $ckey } \|\| next;
165			$processed_templates++;
166	dpavlin	1021
167	dpavlin	1031	warn "### traverse $name $count_name selected template: \|$template\|\n" if $debug;
168	dpavlin	1025
169			our $fill_in = {};
170
171			my @templates = split(/\\|/, $template );
172	dpavlin	1031	@templates = ( $template ) unless @templates;
173	dpavlin	1025
174	dpavlin	1035	warn "### templates = ",dump( @templates ),$/ if $debug;
175	dpavlin	1031
176	dpavlin	1025	foreach my $sf ( @templates ) {
177			sub fill_in {
178	dpavlin	1031	my ( $name, $r, $pre, $sf, $nr, $post ) = @_;
179			warn "#### fill_in( $name, r, '$pre', $sf, $nr, '$post' )\n" if $debug;
180	dpavlin	1028	my ( $from_sf, $from_nr );
181	dpavlin	1025	if ( $name eq 'marc' ) {
182	dpavlin	1029	die "no $sf/$nr in to_mapping: ",dump( $to_mapping ), " form record ",dump( $r ) unless defined $to_mapping->{$sf}->[$nr];
183	dpavlin	1026	( $from_sf, $from_nr ) = @{ $to_mapping->{$sf}->[$nr] };
184	dpavlin	1025	} else {
185			( $from_sf, $from_nr ) = ( $sf, $nr );
186			}
187			my $v = $r->{ $from_sf }; # \|\| die "no $from_sf/$from_nr";
188			if ( ref( $v ) eq 'ARRAY' ) {
189	dpavlin	1031	$v = $pre . $v->[$from_nr] . $post;
190	dpavlin	1025	} elsif ( $from_nr == 0 ) {
191	dpavlin	1031	$v = $pre . $v . $post;
192	dpavlin	1025	} else {
193			die "requested subfield $from_sf/$from_nr but it's ",dump( $v );
194			}
195	dpavlin	1031	warn "#### fill_in( $sf, $nr ) = $from_sf/$from_nr >>>> ",dump( $v ),$/ if $debug;
196			$fill_in->{$sf}->[$nr] = $v;
197			return $v;
198	dpavlin	1021	}
199	dpavlin	1026	my $fields_re = $_template->{$name}->{fields_re} \|\| die "can't find $name in ",dump( $_template->{$name}->{fields_re} );
200	dpavlin	1031	warn "#### $sf <<<< $fields_re\n" if $debug;
201			$sf =~ s/^(.?)($fields_re)(\d+)(.?)$/fill_in($name,$r,$1,$2,$3,$4)/ge;
202	dpavlin	1028	warn "#### >>>> $sf with fill_in = ",dump( $fill_in ),$/ if $debug;
203	dpavlin	1021	}
204
205	dpavlin	1028	warn "## template: \|$template\|\n## _template->$name = ",dump( $_template->{$name} ),$/ if $debug;
206	dpavlin	1021
207	dpavlin	1025	foreach my $sf ( @{ $_template->{$name}->{order}->{$template} } ) {
208			my ( $sf, $nr ) = @$sf;
209			my $v = $fill_in->{$sf}->[$nr] \|\| die "can't find fill_in $sf/$nr";
210	dpavlin	1026	if ( $name eq 'isis') {
211			( $sf, $nr ) = @{ $from_mapping->{$sf}->[$nr] };
212			}
213	dpavlin	1028	warn "++ $sf/$nr \|$v\|\n" if $debug;
214	dpavlin	1025	push @$m, ( $sf, $v );
215			}
216	dpavlin	1021
217	dpavlin	1028	warn "#### >>>> created MARC record: ", dump( $m ),$/ if $debug;
218	dpavlin	1025
219			push @marc_out, $m;
220	dpavlin	1029
221			last;
222	dpavlin	1025	}
223
224			die "I don't have template for fields ",dump( $count_key ), "\n## available templates\n", dump( $_template ) unless $processed_templates;
225	dpavlin	1028	warn ">>> $processed_templates templates applied to data\n",$/ if $debug;
226	dpavlin	1021	}
227
228
229	dpavlin	1026	my $recs = 0;
230	dpavlin	1025
231	dpavlin	1021	foreach my $marc ( @marc_out ) {
232	dpavlin	1028	warn "+++ ",dump( $marc ),$/ if $debug;
233	dpavlin	1021	WebPAC::Normalize::_marc_push( $marc );
234	dpavlin	1026	$recs++;
235	dpavlin	1021	}
236	dpavlin	1026
237	dpavlin	1028	warn "### marc_template produced $recs MARC records: ",dump( @marc_out ),$/ if $debug;
238
239			return $recs;
240	dpavlin	1021	}
241
242			1;