/[webpac2]/trunk/lib/WebPAC/Normalize.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.pm

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

revision 605 by dpavlin, Sun Jul 30 14:23:23 2006 UTC revision 642 by dpavlin, Wed Sep 6 21:09:30 2006 UTC
# Line 4  use Exporter 'import'; Line 4  use Exporter 'import';
4          _set_rec _set_lookup          _set_rec _set_lookup
5          _get_ds _clean_ds          _get_ds _clean_ds
6          _debug          _debug
7            _pack_subfields_hash
8    
9          tag search display          tag search display
10          marc marc_indicators marc_repeatable_subfield          marc marc_indicators marc_repeatable_subfield
# Line 36  WebPAC::Normalize - describe normalisato Line 37  WebPAC::Normalize - describe normalisato
37    
38  =head1 VERSION  =head1 VERSION
39    
40  Version 0.15  Version 0.17
41    
42  =cut  =cut
43    
44  our $VERSION = '0.15';  our $VERSION = '0.17';
45    
46  =head1 SYNOPSIS  =head1 SYNOPSIS
47    
# Line 540  sub marc_compose { Line 541  sub marc_compose {
541    
542          warn "### marc_compose input subfields = ", dump(@_),$/ if ($debug > 2);          warn "### marc_compose input subfields = ", dump(@_),$/ if ($debug > 2);
543    
544            if ($#_ % 2 != 1) {
545                    die "ERROR: marc_compose",dump($f,@_)," not valid (must be even).\nDo you need to add first() or join() around some argument?\n";
546            }
547    
548          while (@_) {          while (@_) {
549                  my $sf = shift or die "marc_compose $f needs subfield";                  my $sf = shift;
550                  my $v = shift;                  my $v = shift;
551    
552                  next unless (defined($v) && $v !~ /^\s*$/);                  next unless (defined($v) && $v !~ /^\s*$/);
# Line 646  sub marc_remove { Line 651  sub marc_remove {
651    
652  Copy all subfields preserving original order to marc field.  Copy all subfields preserving original order to marc field.
653    
654    marc_original_order(210, 260);    marc_original_order( marc_field_number, original_input_field_number );
655    
656    Please note that field numbers are consistent with other commands (marc
657    field number first), but somewhat counter-intuitive (destination and then
658    source).
659    
660  You might want to use this command if you are just renaming subfields or  You might want to use this command if you are just renaming subfields or
661  using pre-processing modify_record in C<config.yml> and don't need any  using pre-processing modify_record in C<config.yml> and don't need any
662  post-processing or want to preserve order of original subfields.  post-processing or want to preserve order of original subfields.
663    
664    
665  =cut  =cut
666    
667  sub marc_original_order {  sub marc_original_order {
668    
669          my ($from, $to) = @_;          my ($to, $from) = @_;
670          die "marc_original_order needs from and to fields\n" unless ($from && $to);          die "marc_original_order needs from and to fields\n" unless ($from && $to);
671    
672          my $r = $rec->{$from} || return;          return unless defined($rec->{$from});
673    
674            my $r = $rec->{$from};
675          die "record field $from isn't array\n" unless (ref($r) eq 'ARRAY');          die "record field $from isn't array\n" unless (ref($r) eq 'ARRAY');
676    
677          my ($i1,$i2) = defined($marc_indicators->{$to}) ? @{ $marc_indicators->{$to} } : (' ',' ');          my ($i1,$i2) = defined($marc_indicators->{$to}) ? @{ $marc_indicators->{$to} } : (' ',' ');
678          warn "## marc_original_order($from,$to) source = ", dump( $r ),$/ if ($debug > 1);          warn "## marc_original_order($to,$from) source = ", dump( $r ),$/ if ($debug > 1);
679    
680          foreach my $d (@$r) {          foreach my $d (@$r) {
681    
682                  if (! defined($d->{subfields}) && ref($d->{subfields}) ne 'ARRAY') {                  if (! defined($d->{subfields}) && ref($d->{subfields}) ne 'ARRAY') {
683                          warn "# marc_original_order($from,$to): field $from doesn't have subfields specification\n";                          warn "# marc_original_order($to,$from): field $from doesn't have subfields specification\n";
684                          next;                          next;
685                  }                  }
686                    
# Line 676  sub marc_original_order { Line 688  sub marc_original_order {
688    
689                  die "field $from doesn't have even number of subfields specifications\n" unless($#sfs % 2 == 1);                  die "field $from doesn't have even number of subfields specifications\n" unless($#sfs % 2 == 1);
690    
691  warn "#--> d: ",dump($d), "\n#--> sfs: ",dump(@sfs),$/;                  warn "#--> d: ",dump($d), "\n#--> sfs: ",dump(@sfs),$/ if ($debug > 2);
692    
693                  my $m = [ $to, $i1, $i2 ];                  my $m = [ $to, $i1, $i2 ];
694    
695                  while (my $sf = shift @sfs) {                  while (my $sf = shift @sfs) {
696  warn "#--> sf: ",dump($sf), $/;  
697                            warn "#--> sf: ",dump($sf), $/ if ($debug > 2);
698                          my $offset = shift @sfs;                          my $offset = shift @sfs;
699                          die "corrupted sufields specification for field $from\n" unless defined($offset);                          die "corrupted sufields specification for field $from\n" unless defined($offset);
700    
# Line 702  warn "#--> sf: ",dump($sf), $/; Line 715  warn "#--> sf: ",dump($sf), $/;
715          }          }
716    
717          warn "## marc_record = ", dump( $marc_record ),$/ if ($debug > 1);          warn "## marc_record = ", dump( $marc_record ),$/ if ($debug > 1);
   
         warn "# marc_original_order is partly implemented";  
718  }  }
719    
720    
# Line 712  warn "#--> sf: ",dump($sf), $/; Line 723  warn "#--> sf: ",dump($sf), $/;
723  This function should be used inside functions to create C<data_structure> described  This function should be used inside functions to create C<data_structure> described
724  above.  above.
725    
726    =head2 _pack_subfields_hash
727    
728     @values = _pack_subfields_hash( $h, $include_subfields )
729    
730    =cut
731    
732    sub _pack_subfields_hash {
733    
734            warn "## _pack_subfields_hash( ",dump(@_), " )\n" if ($debug > 1);
735    
736            my ($h,$include_subfields) = @_;
737    
738    
739            if ( defined($h->{subfields}) ) {
740                    my $sfs = delete $h->{subfields} || die "no subfields?";
741                    my @out;
742                    while (@$sfs) {
743                            my $sf = shift @$sfs;
744                            push @out, '^' . $sf if ($include_subfields);
745                            my $o = shift @$sfs;
746                            if ($o == 0 && ref( $h->{$sf} ) ne 'ARRAY' ) {
747                                    # single element subfields are not arrays
748                                    push @out, $h->{$sf};
749                            } else {
750    #warn "====> $f $sf $o $#$sfs ", dump( $sfs ), "\n";
751                                    push @out, $h->{$sf}->[$o];
752                            }
753                    }
754                    return @out;
755            } else {
756                    # FIXME this should probably be in alphabetical order instead of hash order
757                    values %{$h};
758            }
759    }
760    
761  =head2 rec1  =head2 rec1
762    
763  Return all values in some field  Return all values in some field
# Line 728  sub rec1 { Line 774  sub rec1 {
774          return unless (defined($rec) && defined($rec->{$f}));          return unless (defined($rec) && defined($rec->{$f}));
775          warn "rec1($f) = ", dump( $rec->{$f} ), $/ if ($debug > 1);          warn "rec1($f) = ", dump( $rec->{$f} ), $/ if ($debug > 1);
776          if (ref($rec->{$f}) eq 'ARRAY') {          if (ref($rec->{$f}) eq 'ARRAY') {
777                  return map {                  my @out;
778                          if (ref($_) eq 'HASH') {                  foreach my $h ( @{ $rec->{$f} } ) {
779                                  values %{$_};                          if (ref($h) eq 'HASH') {
780                                    push @out, ( _pack_subfields_hash( $h ) );
781                          } else {                          } else {
782                                  $_;                                  push @out, $h;
783                          }                          }
784                  } @{ $rec->{$f} };                  }
785                    return @out;
786          } elsif( defined($rec->{$f}) ) {          } elsif( defined($rec->{$f}) ) {
787                  return $rec->{$f};                  return $rec->{$f};
788          }          }
Legend:
Removed from v.605  
changed lines
  Added in v.642
  ViewVC Help
Powered by ViewVC 1.1.26