17 |
|
|
18 |
use WebPAC::Normalize; |
use WebPAC::Normalize; |
19 |
|
|
20 |
our $debug = 42; |
our $debug = 0; |
21 |
|
|
22 |
my ($marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators, $marc_leader); |
my ($marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators, $marc_leader); |
23 |
my ($marc_record_offset, $marc_fetch_offset) = (0, 0); |
my ($marc_record_offset, $marc_fetch_offset) = (0, 0); |
58 |
|
|
59 |
=cut |
=cut |
60 |
|
|
61 |
|
my $created_with_marc_template; |
62 |
|
|
63 |
sub marc_template { |
sub marc_template { |
64 |
my $args = {@_}; |
my $args = {@_}; |
65 |
warn "## marc_template(",dump($args),")",$/ if $debug; |
warn "## marc_template(",dump($args),")",$/ if $debug; |
132 |
|
|
133 |
my $m; |
my $m; |
134 |
|
|
135 |
foreach my $r ( @{ $rec->{ $args->{from} } } ) { |
our $from_rec = $rec->{ $args->{from} }; |
136 |
|
|
137 |
|
foreach my $r ( @$from_rec ) { |
138 |
|
|
139 |
my $i1 = $r->{i1} || ' '; |
my $to = $args->{to}; |
140 |
my $i2 = $r->{i2} || ' '; |
my ($i1,$i2) = _get_marc_indicators( $to ); |
141 |
$m = [ $args->{to}, $i1, $i2 ]; |
$m = [ $to, $i1, $i2 ]; |
142 |
|
|
143 |
|
$created_with_marc_template->{ $to }++; |
144 |
|
|
145 |
warn "### r = ",dump( $r ),$/ if $debug; |
warn "### r = ",dump( $r ),$/ if $debug; |
146 |
|
|
147 |
my ( $from_mapping, $to_mapping, $from_count, $to_count ); |
my ( $from_mapping, $from_count, $to_count ); |
148 |
|
our $to_mapping; |
149 |
foreach my $from_sf ( keys %{$r} ) { |
foreach my $from_sf ( keys %{$r} ) { |
150 |
# skip everything which isn't one char subfield (e.g. 'subfields') |
# skip everything which isn't one char subfield (e.g. 'subfields') |
151 |
next unless $from_sf =~ m/^\w$/; |
next unless $from_sf =~ m/^\w$/; |
196 |
warn "#### fill_in( $name, r, '$pre', $sf, $nr, '$post' )\n" if $debug; |
warn "#### fill_in( $name, r, '$pre', $sf, $nr, '$post' )\n" if $debug; |
197 |
my ( $from_sf, $from_nr ); |
my ( $from_sf, $from_nr ); |
198 |
if ( $name eq 'marc' ) { |
if ( $name eq 'marc' ) { |
199 |
die "no $sf/$nr in to_mapping: ",dump( $to_mapping ), " form record ",dump( $r ) unless defined $to_mapping->{$sf}->[$nr]; |
die "no $sf/$nr in to_mapping: ",dump( $to_mapping ), "\n>>>> from record ",dump( $r ), "\n>>>> full record = ",dump( $from_rec ) unless defined $to_mapping->{$sf}->[$nr]; |
200 |
( $from_sf, $from_nr ) = @{ $to_mapping->{$sf}->[$nr] }; |
( $from_sf, $from_nr ) = @{ $to_mapping->{$sf}->[$nr] }; |
201 |
} else { |
} else { |
202 |
( $from_sf, $from_nr ) = ( $sf, $nr ); |
( $from_sf, $from_nr ) = ( $sf, $nr ); |
223 |
|
|
224 |
foreach my $sf ( @{ $_template->{$name}->{order}->{$template} } ) { |
foreach my $sf ( @{ $_template->{$name}->{order}->{$template} } ) { |
225 |
my ( $sf, $nr ) = @$sf; |
my ( $sf, $nr ) = @$sf; |
226 |
my $v = $fill_in->{$sf}->[$nr] || die "can't find fill_in $sf/$nr"; |
my $v = $fill_in->{$sf}->[$nr]; |
227 |
|
die "can't find fill_in $sf/$nr" unless defined $v; |
228 |
if ( $name eq 'isis') { |
if ( $name eq 'isis') { |
229 |
( $sf, $nr ) = @{ $from_mapping->{$sf}->[$nr] }; |
( $sf, $nr ) = @{ $from_mapping->{$sf}->[$nr] }; |
230 |
} |
} |
346 |
foreach (@_) { |
foreach (@_) { |
347 |
my $v = $_; # make var read-write for Encode |
my $v = $_; # make var read-write for Encode |
348 |
next unless (defined($v) && $v !~ /^\s*$/); |
next unless (defined($v) && $v !~ /^\s*$/); |
349 |
my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' '); |
my ($i1,$i2) = _get_marc_indicators( $f ); |
350 |
if (defined $sf) { |
if (defined $sf) { |
351 |
push @{ $marc_record->[ $marc_record_offset ] }, [ $f, $i1, $i2, $sf => $v ]; |
push @{ $marc_record->[ $marc_record_offset ] }, [ $f, $i1, $i2, $sf => $v ]; |
352 |
} else { |
} else { |
391 |
@{ $marc_indicators->{$f} } = ($i1,$i2); |
@{ $marc_indicators->{$f} } = ($i1,$i2); |
392 |
} |
} |
393 |
|
|
394 |
|
sub _get_marc_indicators { |
395 |
|
my $f = shift || confess "need field!\n"; |
396 |
|
return defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' '); |
397 |
|
} |
398 |
|
|
399 |
=head2 marc_compose |
=head2 marc_compose |
400 |
|
|
401 |
Save values for each MARC subfield explicitly |
Save values for each MARC subfield explicitly |
416 |
my $f = shift or die "marc_compose needs field"; |
my $f = shift or die "marc_compose needs field"; |
417 |
die "marc_compose field must be numer" unless ($f =~ /^\d+$/); |
die "marc_compose field must be numer" unless ($f =~ /^\d+$/); |
418 |
|
|
419 |
my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' '); |
my ($i1,$i2) = _get_marc_indicators( $f ); |
420 |
my $m = [ $f, $i1, $i2 ]; |
my $m = [ $f, $i1, $i2 ]; |
421 |
|
|
422 |
warn "### marc_compose input subfields = ", dump(@_),$/ if ($debug > 2); |
warn "### marc_compose input subfields = ", dump(@_),$/ if ($debug > 2); |
567 |
my $r = $rec->{$from}; |
my $r = $rec->{$from}; |
568 |
die "record field $from isn't array ",dump( $rec ) unless (ref($r) eq 'ARRAY'); |
die "record field $from isn't array ",dump( $rec ) unless (ref($r) eq 'ARRAY'); |
569 |
|
|
570 |
my ($i1,$i2) = defined($marc_indicators->{$to}) ? @{ $marc_indicators->{$to} } : (' ',' '); |
my ($i1,$i2) = _get_marc_indicators( $to ); |
571 |
warn "## marc_original_order($to,$from) source = ", dump( $r ),$/ if ($debug > 1); |
warn "## marc_original_order($to,$from) source = ", dump( $r ),$/ if ($debug > 1); |
572 |
|
|
573 |
foreach my $d (@$r) { |
foreach my $d (@$r) { |
623 |
return $#{ $marc_record }; |
return $#{ $marc_record }; |
624 |
} |
} |
625 |
|
|
626 |
|
=head1 PRIVATE FUNCTIONS |
627 |
|
|
628 |
=head2 _marc_push |
=head2 _marc_push |
629 |
|
|
630 |
_marc_push( $marc ); |
_marc_push( $marc ); |
636 |
push @{ $marc_record->[ $marc_record_offset ] }, $marc; |
push @{ $marc_record->[ $marc_record_offset ] }, $marc; |
637 |
} |
} |
638 |
|
|
|
=head1 PRIVATE FUNCTIONS |
|
|
|
|
639 |
=head2 _clean |
=head2 _clean |
640 |
|
|
641 |
Clean internal structures |
Clean internal structures |
643 |
=cut |
=cut |
644 |
|
|
645 |
sub _clean { |
sub _clean { |
646 |
($marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators, $marc_leader) = (); |
($marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators, $marc_leader, $created_with_marc_template) = (); |
647 |
($marc_record_offset, $marc_fetch_offset) = (0,0); |
($marc_record_offset, $marc_fetch_offset) = (0,0); |
648 |
} |
} |
649 |
|
|
657 |
We are using I<magic> which detect repeatable fields only from |
We are using I<magic> which detect repeatable fields only from |
658 |
sequence of field/subfield data generated by normalization. |
sequence of field/subfield data generated by normalization. |
659 |
|
|
660 |
|
This magic is disabled for all records created with C<marc_template>. |
661 |
|
|
662 |
Repeatable field is created when there is second occurence of same subfield or |
Repeatable field is created when there is second occurence of same subfield or |
663 |
if any of indicators are different. |
if any of indicators are different. |
664 |
|
|
730 |
|
|
731 |
# first, sort all existing fields |
# first, sort all existing fields |
732 |
# XXX might not be needed, but modern perl might randomize elements in hash |
# XXX might not be needed, but modern perl might randomize elements in hash |
733 |
my @sorted_marc_record = sort { |
# my @sorted_marc_record = sort { |
734 |
$a->[0] . ( $a->[3] || '' ) cmp $b->[0] . ( $b->[3] || '') |
# $a->[0] . ( $a->[3] || '' ) cmp $b->[0] . ( $b->[3] || '') |
735 |
} @{ $marc_rec }; |
# } @{ $marc_rec }; |
736 |
|
|
737 |
@sorted_marc_record = @{ $marc_rec }; ### FIXME disable sorting |
my @sorted_marc_record = @{ $marc_rec }; ### FIXME disable sorting |
738 |
|
|
739 |
# output marc fields |
# output marc fields |
740 |
my @m; |
my @m; |
755 |
my $i = 0; |
my $i = 0; |
756 |
my $field; |
my $field; |
757 |
|
|
758 |
|
warn "## created_with_marc_template = ",dump( $created_with_marc_template ) if $debug; |
759 |
|
|
760 |
foreach ( 0 .. $len ) { |
foreach ( 0 .. $len ) { |
761 |
|
|
762 |
# find next element which isn't visited |
# find next element which isn't visited |
769 |
|
|
770 |
my $row = dclone( $sorted_marc_record[$i] ); |
my $row = dclone( $sorted_marc_record[$i] ); |
771 |
|
|
772 |
|
if ( $created_with_marc_template->{ $row->[0] } ) { |
773 |
|
push @m, $row; |
774 |
|
warn "## copied marc_template created ", dump( $row ),$/ if $debug; |
775 |
|
next; |
776 |
|
} |
777 |
|
|
778 |
# field and subfield which is key for |
# field and subfield which is key for |
779 |
# marc_repeatable_subfield and u |
# marc_repeatable_subfield and u |
780 |
my $fsf = $row->[0] . ( $row->[3] || '' ); |
my $fsf = $row->[0] . ( $row->[3] || '' ); |