/[webpac2]/trunk/lib/WebPAC/Normalize/MARC.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /trunk/lib/WebPAC/Normalize/MARC.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1036 by dpavlin, Mon Nov 12 11:10:48 2007 UTC revision 1109 by dpavlin, Sat Sep 6 09:54:08 2008 UTC
# Line 6  our @EXPORT = qw/ Line 6  our @EXPORT = qw/
6          marc_duplicate marc_remove marc_count          marc_duplicate marc_remove marc_count
7          marc_original_order          marc_original_order
8          marc_template          marc_template
9            marc_clone
10  /;  /;
11    
12  use strict;  use strict;
# Line 17  use Carp qw/confess/; Line 18  use Carp qw/confess/;
18    
19  use WebPAC::Normalize;  use WebPAC::Normalize;
20    
21  our $debug = 42;  our $debug = 0;
22    
23  my ($marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators, $marc_leader);  my ($marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators, $marc_leader);
24  my ($marc_record_offset, $marc_fetch_offset) = (0, 0);  my ($marc_record_offset, $marc_fetch_offset) = (0, 0);
# Line 58  Returns number of records produced. Line 59  Returns number of records produced.
59    
60  =cut  =cut
61    
62    my $created_with_marc_template;
63    
64  sub marc_template {  sub marc_template {
65          my $args = {@_};          my $args = {@_};
66          warn "## marc_template(",dump($args),")",$/ if $debug;          warn "## marc_template(",dump($args),")",$/ if $debug;
# Line 130  sub marc_template { Line 133  sub marc_template {
133    
134          my $m;          my $m;
135    
136          foreach my $r ( @{ $rec->{ $args->{from} } } ) {          our $from_rec = $rec->{ $args->{from} };
137    
138            foreach my $r ( @$from_rec ) {
139    
140                    my $to = $args->{to};
141                    my ($i1,$i2) = _get_marc_indicators( $to );
142                    $m = [ $to, $i1, $i2 ];
143    
144                  my $i1 = $r->{i1} || ' ';                  $created_with_marc_template->{ $to }++;
                 my $i2 = $r->{i2} || ' ';  
                 $m = [ $args->{to}, $i1, $i2 ];  
145    
146                  warn "### r = ",dump( $r ),$/ if $debug;                  warn "### r = ",dump( $r ),$/ if $debug;
147    
148                  my ( $from_mapping, $to_mapping, $from_count, $to_count );                  my ( $from_mapping, $from_count, $to_count );
149                    our $to_mapping;
150                  foreach my $from_sf ( keys %{$r} ) {                  foreach my $from_sf ( keys %{$r} ) {
151                          # skip everything which isn't one char subfield (e.g. 'subfields')                          # skip everything which isn't one char subfield (e.g. 'subfields')
152                          next unless $from_sf =~ m/^\w$/;                          next unless $from_sf =~ m/^\w$/;
# Line 189  sub marc_template { Line 197  sub marc_template {
197                                          warn "#### fill_in( $name, r, '$pre', $sf, $nr, '$post' )\n" if $debug;                                          warn "#### fill_in( $name, r, '$pre', $sf, $nr, '$post' )\n" if $debug;
198                                          my ( $from_sf, $from_nr );                                          my ( $from_sf, $from_nr );
199                                          if ( $name eq 'marc' ) {                                          if ( $name eq 'marc' ) {
200                                                  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];
201                                                  ( $from_sf, $from_nr ) = @{ $to_mapping->{$sf}->[$nr] };                                                  ( $from_sf, $from_nr ) = @{ $to_mapping->{$sf}->[$nr] };
202                                          } else {                                          } else {
203                                                  ( $from_sf, $from_nr ) = ( $sf, $nr );                                                  ( $from_sf, $from_nr ) = ( $sf, $nr );
# Line 216  sub marc_template { Line 224  sub marc_template {
224    
225                          foreach my $sf ( @{ $_template->{$name}->{order}->{$template} } ) {                          foreach my $sf ( @{ $_template->{$name}->{order}->{$template} } ) {
226                                  my ( $sf, $nr ) = @$sf;                                  my ( $sf, $nr ) = @$sf;
227                                  my $v = $fill_in->{$sf}->[$nr] || die "can't find fill_in $sf/$nr";                                  my $v = $fill_in->{$sf}->[$nr];
228                                    die "can't find fill_in $sf/$nr" unless defined $v;
229                                  if ( $name eq 'isis') {                                  if ( $name eq 'isis') {
230                                          ( $sf, $nr ) = @{ $from_mapping->{$sf}->[$nr] };                                          ( $sf, $nr ) = @{ $from_mapping->{$sf}->[$nr] };
231                                  }                                  }
# Line 338  sub marc { Line 347  sub marc {
347          foreach (@_) {          foreach (@_) {
348                  my $v = $_;             # make var read-write for Encode                  my $v = $_;             # make var read-write for Encode
349                  next unless (defined($v) && $v !~ /^\s*$/);                  next unless (defined($v) && $v !~ /^\s*$/);
350                  my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');                  my ($i1,$i2) = _get_marc_indicators( $f );
351                  if (defined $sf) {                  if (defined $sf) {
352                          push @{ $marc_record->[ $marc_record_offset ] }, [ $f, $i1, $i2, $sf => $v ];                          push @{ $marc_record->[ $marc_record_offset ] }, [ $f, $i1, $i2, $sf => $v ];
353                  } else {                  } else {
# Line 383  sub marc_indicators { Line 392  sub marc_indicators {
392          @{ $marc_indicators->{$f} } = ($i1,$i2);          @{ $marc_indicators->{$f} } = ($i1,$i2);
393  }  }
394    
395    sub _get_marc_indicators {
396            my $f = shift || confess "need field!\n";
397            return defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');
398    }
399    
400  =head2 marc_compose  =head2 marc_compose
401    
402  Save values for each MARC subfield explicitly  Save values for each MARC subfield explicitly
# Line 403  sub marc_compose { Line 417  sub marc_compose {
417          my $f = shift or die "marc_compose needs field";          my $f = shift or die "marc_compose needs field";
418          die "marc_compose field must be numer" unless ($f =~ /^\d+$/);          die "marc_compose field must be numer" unless ($f =~ /^\d+$/);
419    
420          my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');          my ($i1,$i2) = _get_marc_indicators( $f );
421          my $m = [ $f, $i1, $i2 ];          my $m = [ $f, $i1, $i2 ];
422    
423          warn "### marc_compose input subfields = ", dump(@_),$/ if ($debug > 2);          warn "### marc_compose input subfields = ", dump(@_),$/ if ($debug > 2);
# Line 554  sub marc_original_order { Line 568  sub marc_original_order {
568          my $r = $rec->{$from};          my $r = $rec->{$from};
569          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');
570    
571          my ($i1,$i2) = defined($marc_indicators->{$to}) ? @{ $marc_indicators->{$to} } : (' ',' ');          my ($i1,$i2) = _get_marc_indicators( $to );
572          warn "## marc_original_order($to,$from) source = ", dump( $r ),$/ if ($debug > 1);          warn "## marc_original_order($to,$from) source = ", dump( $r ),$/ if ($debug > 1);
573    
574          foreach my $d (@$r) {          foreach my $d (@$r) {
# Line 610  sub marc_count { Line 624  sub marc_count {
624          return $#{ $marc_record };          return $#{ $marc_record };
625  }  }
626    
627    =head2 marc_clone
628    
629    Clone marc records from input file, whole or just some fields/indicators
630    
631      marc_clone;   # whole record
632    
633    =cut
634    
635    sub marc_clone {
636            foreach my $f ( keys %$rec ) {
637                    warn "## marc_clone $f\n" if $debug;
638                    marc_original_order( $f, $f );
639            }
640    }
641    
642    =head1 PRIVATE FUNCTIONS
643    
644  =head2 _marc_push  =head2 _marc_push
645    
646   _marc_push( $marc );   _marc_push( $marc );
# Line 621  sub _marc_push { Line 652  sub _marc_push {
652          push @{ $marc_record->[ $marc_record_offset ] }, $marc;          push @{ $marc_record->[ $marc_record_offset ] }, $marc;
653  }  }
654    
 =head1 PRIVATE FUNCTIONS  
   
655  =head2 _clean  =head2 _clean
656    
657  Clean internal structures  Clean internal structures
# Line 630  Clean internal structures Line 659  Clean internal structures
659  =cut  =cut
660    
661  sub _clean {  sub _clean {
662          ($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) = ();
663          ($marc_record_offset, $marc_fetch_offset) = (0,0);          ($marc_record_offset, $marc_fetch_offset) = (0,0);
664  }  }
665    
# Line 644  Get all fields defined by calls to C<mar Line 673  Get all fields defined by calls to C<mar
673  We are using I<magic> which detect repeatable fields only from  We are using I<magic> which detect repeatable fields only from
674  sequence of field/subfield data generated by normalization.  sequence of field/subfield data generated by normalization.
675    
676    This magic is disabled for all records created with C<marc_template>.
677    
678  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
679  if any of indicators are different.  if any of indicators are different.
680    
# Line 715  sub _get_marc_fields { Line 746  sub _get_marc_fields {
746    
747          # first, sort all existing fields          # first, sort all existing fields
748          # 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
749          my @sorted_marc_record = sort {  #       my @sorted_marc_record = sort {
750                  $a->[0] . ( $a->[3] || '' ) cmp $b->[0] . ( $b->[3] || '')  #               $a->[0] . ( $a->[3] || '' ) cmp $b->[0] . ( $b->[3] || '')
751          } @{ $marc_rec };  #       } @{ $marc_rec };
752    
753          @sorted_marc_record = @{ $marc_rec };   ### FIXME disable sorting          my @sorted_marc_record = @{ $marc_rec };        ### FIXME disable sorting
754                    
755          # output marc fields          # output marc fields
756          my @m;          my @m;
# Line 740  sub _get_marc_fields { Line 771  sub _get_marc_fields {
771          my $i = 0;          my $i = 0;
772          my $field;          my $field;
773    
774            warn "## created_with_marc_template = ",dump( $created_with_marc_template ) if $debug;
775    
776          foreach ( 0 .. $len ) {          foreach ( 0 .. $len ) {
777    
778                  # find next element which isn't visited                  # find next element which isn't visited
# Line 752  sub _get_marc_fields { Line 785  sub _get_marc_fields {
785    
786                  my $row = dclone( $sorted_marc_record[$i] );                  my $row = dclone( $sorted_marc_record[$i] );
787    
788                    if ( $created_with_marc_template->{ $row->[0] } ) {
789                            push @m, $row;
790                            warn "## copied marc_template created ", dump( $row ),$/ if $debug;
791                            next;
792                    }
793    
794                  # field and subfield which is key for                  # field and subfield which is key for
795                  # marc_repeatable_subfield and u                  # marc_repeatable_subfield and u
796                  my $fsf = $row->[0] . ( $row->[3] || '' );                  my $fsf = $row->[0] . ( $row->[3] || '' );
Legend:
Removed from v.1036  
changed lines
  Added in v.1109
  ViewVC Help
Powered by ViewVC 1.1.26