/[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 1038 by dpavlin, Mon Nov 12 11:57:00 2007 UTC revision 1062 by dpavlin, Wed Nov 21 10:09:55 2007 UTC
# Line 58  Returns number of records produced. Line 58  Returns number of records produced.
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;
# Line 130  sub marc_template { Line 132  sub marc_template {
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$/;
# Line 189  sub marc_template { Line 196  sub marc_template {
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 );
# Line 216  sub marc_template { Line 223  sub marc_template {
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                                  }                                  }
# Line 338  sub marc { Line 346  sub marc {
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 {
# Line 383  sub marc_indicators { Line 391  sub marc_indicators {
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
# Line 403  sub marc_compose { Line 416  sub marc_compose {
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);
# Line 554  sub marc_original_order { Line 567  sub marc_original_order {
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) {
# Line 610  sub marc_count { Line 623  sub marc_count {
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 );
# Line 621  sub _marc_push { Line 636  sub _marc_push {
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
# Line 630  Clean internal structures Line 643  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    
# Line 644  Get all fields defined by calls to C<mar Line 657  Get all fields defined by calls to C<mar
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    
# Line 715  sub _get_marc_fields { Line 730  sub _get_marc_fields {
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;
# Line 740  sub _get_marc_fields { Line 755  sub _get_marc_fields {
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
# Line 752  sub _get_marc_fields { Line 769  sub _get_marc_fields {
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] || '' );
Legend:
Removed from v.1038  
changed lines
  Added in v.1062
  ViewVC Help
Powered by ViewVC 1.1.26