/[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 574 by dpavlin, Mon Jul 3 21:08:07 2006 UTC revision 661 by dpavlin, Fri Sep 8 17:47:58 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
11          marc_compose marc_leader          marc_compose marc_leader
12          marc_duplicate marc_remove          marc_duplicate marc_remove
13            marc_original_order
14    
15          rec1 rec2 rec          rec1 rec2 rec
16          regex prefix suffix surround          regex prefix suffix surround
# Line 22  use strict; Line 24  use strict;
24    
25  #use base qw/WebPAC::Common/;  #use base qw/WebPAC::Common/;
26  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
 use Encode qw/from_to/;  
27  use Storable qw/dclone/;  use Storable qw/dclone/;
28    
29  # debugging warn(s)  # debugging warn(s)
# Line 35  WebPAC::Normalize - describe normalisato Line 36  WebPAC::Normalize - describe normalisato
36    
37  =head1 VERSION  =head1 VERSION
38    
39  Version 0.10  Version 0.18
40    
41  =cut  =cut
42    
43  our $VERSION = '0.10';  our $VERSION = '0.18';
44    
45  =head1 SYNOPSIS  =head1 SYNOPSIS
46    
# Line 69  Return data structure Line 70  Return data structure
70          row => $row,          row => $row,
71          rules => $normalize_pl_config,          rules => $normalize_pl_config,
72          marc_encoding => 'utf-8',          marc_encoding => 'utf-8',
73            config => $config,
74    );    );
75    
76  Options C<lookup>, C<row>, C<rules> and C<log> are mandatory while all  Options C<lookup>, C<row>, C<rules> and C<log> are mandatory while all
# Line 90  sub data_structure { Line 92  sub data_structure {
92          no strict 'subs';          no strict 'subs';
93          _set_lookup( $arg->{lookup} );          _set_lookup( $arg->{lookup} );
94          _set_rec( $arg->{row} );          _set_rec( $arg->{row} );
95            _set_config( $arg->{config} );
96          _clean_ds( %{ $arg } );          _clean_ds( %{ $arg } );
97          eval "$arg->{rules}";          eval "$arg->{rules}";
98          die "error evaling $arg->{rules}: $@\n" if ($@);          die "error evaling $arg->{rules}: $@\n" if ($@);
# Line 111  sub _set_rec { Line 114  sub _set_rec {
114          $rec = shift or die "no record hash";          $rec = shift or die "no record hash";
115  }  }
116    
117    =head2 _set_config
118    
119    Set current config hash
120    
121      _set_config( $config );
122    
123    Magic keys are:
124    
125    =over 4
126    
127    =item _
128    
129    Code of current database
130    
131    =item _mfn
132    
133    Current MFN
134    
135    =back
136    
137    =cut
138    
139    my $config;
140    
141    sub _set_config {
142            $config = shift;
143    }
144    
145  =head2 _get_ds  =head2 _get_ds
146    
147  Return hash formatted as data structure  Return hash formatted as data structure
# Line 326  sub _get_marc_fields { Line 357  sub _get_marc_fields {
357                  warn "## saved/3 ", dump( $field ),$/ if ($debug);                  warn "## saved/3 ", dump( $field ),$/ if ($debug);
358          }          }
359    
360          return @m;          return \@m;
361  }  }
362    
363  =head2 _debug  =head2 _debug
# Line 438  sub marc { Line 469  sub marc {
469          foreach (@_) {          foreach (@_) {
470                  my $v = $_;             # make var read-write for Encode                  my $v = $_;             # make var read-write for Encode
471                  next unless (defined($v) && $v !~ /^\s*$/);                  next unless (defined($v) && $v !~ /^\s*$/);
                 from_to($v, 'iso-8859-2', $marc_encoding) if ($marc_encoding);  
472                  my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');                  my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');
473                  if (defined $sf) {                  if (defined $sf) {
474                          push @{ $marc_record->[ $marc_record_offset ] }, [ $f, $i1, $i2, $sf => $v ];                          push @{ $marc_record->[ $marc_record_offset ] }, [ $f, $i1, $i2, $sf => $v ];
# Line 495  Save values for each MARC subfield expli Line 525  Save values for each MARC subfield expli
525          'c', rec('200','c')          'c', rec('200','c')
526    );    );
527    
528    If you specify C<+> for subfield, value will be appended
529    to previous defined subfield.
530    
531  =cut  =cut
532    
533  sub marc_compose {  sub marc_compose {
# Line 504  sub marc_compose { Line 537  sub marc_compose {
537          my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');          my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');
538          my $m = [ $f, $i1, $i2 ];          my $m = [ $f, $i1, $i2 ];
539    
540            warn "### marc_compose input subfields = ", dump(@_),$/ if ($debug > 2);
541    
542            if ($#_ % 2 != 1) {
543                    die "ERROR: marc_compose",dump($f,@_)," not valid (must be even).\nDo you need to add first() or join() around some argument?\n";
544            }
545    
546          while (@_) {          while (@_) {
547                  my $sf = shift or die "marc_compose $f needs subfield";                  my $sf = shift;
548                  my $v = shift;                  my $v = shift;
549    
550                  next unless (defined($v) && $v !~ /^\s*$/);                  next unless (defined($v) && $v !~ /^\s*$/);
                 from_to($v, 'iso-8859-2', $marc_encoding) if ($marc_encoding);  
                 push @$m, ( $sf, $v );  
551                  warn "## ++ marc_compose($f,$sf,$v) ", dump( $m ),$/ if ($debug > 1);                  warn "## ++ marc_compose($f,$sf,$v) ", dump( $m ),$/ if ($debug > 1);
552                    if ($sf ne '+') {
553                            push @$m, ( $sf, $v );
554                    } else {
555                            $m->[ $#$m ] .= $v;
556                    }
557          }          }
558    
559          warn "## marc_compose(d) ", dump( $m ),$/ if ($debug > 1);          warn "## marc_compose current marc = ", dump( $m ),$/ if ($debug > 1);
560    
561          push @{ $marc_record->[ $marc_record_offset ] }, $m if ($#{$m} > 2);          push @{ $marc_record->[ $marc_record_offset ] }, $m if ($#{$m} > 2);
562  }  }
# Line 565  sub marc_remove { Line 607  sub marc_remove {
607    
608          warn "### marc_remove before = ", dump( $marc ), $/ if ($debug > 2);          warn "### marc_remove before = ", dump( $marc ), $/ if ($debug > 2);
609    
610          foreach my $i ( 0 .. $#{ $marc } ) {          my $i = 0;
611            foreach ( 0 .. $#{ $marc } ) {
612                  last unless (defined $marc->[$i]);                  last unless (defined $marc->[$i]);
613                  warn "#### working on ",dump( @{ $marc->[$i] }), $/ if ($debug > 3);                  warn "#### working on ",dump( @{ $marc->[$i] }), $/ if ($debug > 3);
614                  if ($marc->[$i]->[0] eq $f) {                  if ($marc->[$i]->[0] eq $f) {
# Line 591  sub marc_remove { Line 634  sub marc_remove {
634                                  }                                  }
635                          }                          }
636                  }                  }
637                    $i++;
638          }          }
639    
640          warn "### marc_remove($f", $sf ? ",$sf" : "", ") after = ", dump( $marc ), $/ if ($debug > 2);          warn "### marc_remove($f", $sf ? ",$sf" : "", ") after = ", dump( $marc ), $/ if ($debug > 2);
# Line 600  sub marc_remove { Line 644  sub marc_remove {
644          warn "## full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 1);          warn "## full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 1);
645  }  }
646    
647    =head2 marc_original_order
648    
649    Copy all subfields preserving original order to marc field.
650    
651      marc_original_order( marc_field_number, original_input_field_number );
652    
653    Please note that field numbers are consistent with other commands (marc
654    field number first), but somewhat counter-intuitive (destination and then
655    source).
656    
657    You might want to use this command if you are just renaming subfields or
658    using pre-processing modify_record in C<config.yml> and don't need any
659    post-processing or want to preserve order of original subfields.
660    
661    
662    =cut
663    
664    sub marc_original_order {
665    
666            my ($to, $from) = @_;
667            die "marc_original_order needs from and to fields\n" unless ($from && $to);
668    
669            return unless defined($rec->{$from});
670    
671            my $r = $rec->{$from};
672            die "record field $from isn't array\n" unless (ref($r) eq 'ARRAY');
673    
674            my ($i1,$i2) = defined($marc_indicators->{$to}) ? @{ $marc_indicators->{$to} } : (' ',' ');
675            warn "## marc_original_order($to,$from) source = ", dump( $r ),$/ if ($debug > 1);
676    
677            foreach my $d (@$r) {
678    
679                    if (! defined($d->{subfields}) && ref($d->{subfields}) ne 'ARRAY') {
680                            warn "# marc_original_order($to,$from): field $from doesn't have subfields specification\n";
681                            next;
682                    }
683            
684                    my @sfs = @{ $d->{subfields} };
685    
686                    die "field $from doesn't have even number of subfields specifications\n" unless($#sfs % 2 == 1);
687    
688                    warn "#--> d: ",dump($d), "\n#--> sfs: ",dump(@sfs),$/ if ($debug > 2);
689    
690                    my $m = [ $to, $i1, $i2 ];
691    
692                    while (my $sf = shift @sfs) {
693    
694                            warn "#--> sf: ",dump($sf), $/ if ($debug > 2);
695                            my $offset = shift @sfs;
696                            die "corrupted sufields specification for field $from\n" unless defined($offset);
697    
698                            my $v;
699                            if (ref($d->{$sf}) eq 'ARRAY') {
700                                    $v = $d->{$sf}->[$offset] if (defined($d->{$sf}->[$offset]));
701                            } elsif ($offset == 0) {
702                                    $v = $d->{$sf};
703                            } else {
704                                    die "field $from subfield '$sf' need occurence $offset which doesn't exist", dump($d->{$sf});
705                            }
706                            push @$m, ( $sf, $v ) if (defined($v));
707                    }
708    
709                    if ($#{$m} > 2) {
710                            push @{ $marc_record->[ $marc_record_offset ] }, $m;
711                    }
712            }
713    
714            warn "## marc_record = ", dump( $marc_record ),$/ if ($debug > 1);
715    }
716    
717    
718  =head1 Functions to extract data from input  =head1 Functions to extract data from input
719    
720  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
721  above.  above.
722    
723    =head2 _pack_subfields_hash
724    
725     @values = _pack_subfields_hash( $h, $include_subfields )
726    
727    =cut
728    
729    sub _pack_subfields_hash {
730    
731            warn "## _pack_subfields_hash( ",dump(@_), " )\n" if ($debug > 1);
732    
733            my ($h,$include_subfields) = @_;
734    
735    
736            if ( defined($h->{subfields}) ) {
737                    my $sfs = delete $h->{subfields} || die "no subfields?";
738                    my @out;
739                    while (@$sfs) {
740                            my $sf = shift @$sfs;
741                            push @out, '^' . $sf if ($include_subfields);
742                            my $o = shift @$sfs;
743                            if ($o == 0 && ref( $h->{$sf} ) ne 'ARRAY' ) {
744                                    # single element subfields are not arrays
745                                    push @out, $h->{$sf};
746                            } else {
747    #warn "====> $f $sf $o $#$sfs ", dump( $sfs ), "\n";
748                                    push @out, $h->{$sf}->[$o];
749                            }
750                    }
751                    return @out;
752            } else {
753                    # FIXME this should probably be in alphabetical order instead of hash order
754                    values %{$h};
755            }
756    }
757    
758  =head2 rec1  =head2 rec1
759    
760  Return all values in some field  Return all values in some field
# Line 621  sub rec1 { Line 771  sub rec1 {
771          return unless (defined($rec) && defined($rec->{$f}));          return unless (defined($rec) && defined($rec->{$f}));
772          warn "rec1($f) = ", dump( $rec->{$f} ), $/ if ($debug > 1);          warn "rec1($f) = ", dump( $rec->{$f} ), $/ if ($debug > 1);
773          if (ref($rec->{$f}) eq 'ARRAY') {          if (ref($rec->{$f}) eq 'ARRAY') {
774                  return map {                  my @out;
775                          if (ref($_) eq 'HASH') {                  foreach my $h ( @{ $rec->{$f} } ) {
776                                  values %{$_};                          if (ref($h) eq 'HASH') {
777                                    push @out, ( _pack_subfields_hash( $h ) );
778                          } else {                          } else {
779                                  $_;                                  push @out, $h;
780                          }                          }
781                  } @{ $rec->{$f} };                  }
782                    return @out;
783          } elsif( defined($rec->{$f}) ) {          } elsif( defined($rec->{$f}) ) {
784                  return $rec->{$f};                  return $rec->{$f};
785          }          }
# Line 645  sub rec2 { Line 797  sub rec2 {
797          my $f = shift;          my $f = shift;
798          return unless (defined($rec && $rec->{$f}));          return unless (defined($rec && $rec->{$f}));
799          my $sf = shift;          my $sf = shift;
800          return map { $_->{$sf} } grep { ref($_) eq 'HASH' && $_->{$sf} } @{ $rec->{$f} };          warn "rec2($f,$sf) = ", dump( $rec->{$f} ), $/ if ($debug > 1);
801            return map {
802                    if (ref($_->{$sf}) eq 'ARRAY') {
803                            @{ $_->{$sf} };
804                    } else {
805                            $_->{$sf};
806                    }
807            } grep { ref($_) eq 'HASH' && $_->{$sf} } @{ $rec->{$f} };
808  }  }
809    
810  =head2 rec  =head2 rec
# Line 658  syntaxtic sugar for Line 817  syntaxtic sugar for
817  =cut  =cut
818    
819  sub rec {  sub rec {
820            my @out;
821          if ($#_ == 0) {          if ($#_ == 0) {
822                  return rec1(@_);                  @out = rec1(@_);
823          } elsif ($#_ == 1) {          } elsif ($#_ == 1) {
824                  return rec2(@_);                  @out = rec2(@_);
825            }
826            if (@out) {
827                    return @out;
828            } else {
829                    return '';
830          }          }
831  }  }
832    
# Line 694  Prefix all values with a string Line 859  Prefix all values with a string
859  =cut  =cut
860    
861  sub prefix {  sub prefix {
862          my $p = shift or die "prefix needs string as first argument";          my $p = shift or return;
863          return map { $p . $_ } grep { defined($_) } @_;          return map { $p . $_ } grep { defined($_) } @_;
864  }  }
865    
# Line 757  sub lookup { Line 922  sub lookup {
922          }          }
923  }  }
924    
925    =head2 config
926    
927    Consult config values stored in C<config.yml>
928    
929      # return database code (key under databases in yaml)
930      $database_code = config();    # use _ from hash
931      $database_name = config('name');
932      $database_input_name = config('input name');
933      $tag = config('input normalize tag');
934    
935    Up to three levels are supported.
936    
937    =cut
938    
939    sub config {
940            return unless ($config);
941    
942            my $p = shift;
943    
944            $p ||= '';
945    
946            my $v;
947    
948            warn "### getting config($p)\n" if ($debug > 1);
949    
950            my @p = split(/\s+/,$p);
951            if ($#p < 0) {
952                    $v = $config->{ '_' };  # special, database code
953            } else {
954    
955                    my $c = dclone( $config );
956    
957                    foreach my $k (@p) {
958                            warn "### k: $k c = ",dump($c),$/ if ($debug > 1);
959                            if (ref($c) eq 'ARRAY') {
960                                    $c = shift @$c;
961                                    warn "config($p) taking first occurence of '$k', probably not what you wanted!\n";
962                                    last;
963                            }
964    
965                            if (! defined($c->{$k}) ) {
966                                    $c = undef;
967                                    last;
968                            } else {
969                                    $c = $c->{$k};
970                            }
971                    }
972                    $v = $c if ($c);
973    
974            }
975    
976            warn "## config( '$p' ) = ",dump( $v ),$/ if ($v && $debug);
977            warn "config( '$p' ) is empty\n" if (! $v);
978    
979            return $v;
980    }
981    
982    =head2 id
983    
984    Returns unique id of this record
985    
986      $id = id();
987    
988    Returns C<42/2> for 2nd occurence of MFN 42.
989    
990    =cut
991    
992    sub id {
993            my $mfn = $config->{_mfn} || die "no _mfn in config data";
994            return $mfn . $#{$marc_record} ? $#{$marc_record} + 1 : '';
995    }
996    
997  =head2 join_with  =head2 join_with
998    
999  Joins walues with some delimiter  Joins walues with some delimiter
# Line 767  Joins walues with some delimiter Line 1004  Joins walues with some delimiter
1004    
1005  sub join_with {  sub join_with {
1006          my $d = shift;          my $d = shift;
1007          return join($d, grep { defined($_) && $_ ne '' } @_);          warn "### join_with('$d',",dump(@_),")\n" if ($debug > 2);
1008            my $v = join($d, grep { defined($_) && $_ ne '' } @_);
1009            return '' unless defined($v);
1010            return $v;
1011  }  }
1012    
1013  =head2 split_rec_on  =head2 split_rec_on
# Line 795  sub split_rec_on { Line 1035  sub split_rec_on {
1035          my $v = shift @r;          my $v = shift @r;
1036          warn "### first rec($fld,$sf) = ",dump($v),$/ if ($debug > 2);          warn "### first rec($fld,$sf) = ",dump($v),$/ if ($debug > 2);
1037    
1038          return '' if( ! defined($v) || $v =~ /^\s*$/);          return '' if ( ! defined($v) || $v =~ /^\s*$/);
1039    
1040          my @s = split( $regex, $v );          my @s = split( $regex, $v );
1041          warn "## split_rec_on($fld,$sf,$regex,$part) = ",dump(@s),$/ if ($debug > 1);          warn "## split_rec_on($fld,$sf,$regex,$part) = ",dump(@s),$/ if ($debug > 1);

Legend:
Removed from v.574  
changed lines
  Added in v.661

  ViewVC Help
Powered by ViewVC 1.1.26