/[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 579 by dpavlin, Tue Jul 4 11:08:43 2006 UTC revision 641 by dpavlin, Wed Sep 6 20:54:47 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 35  WebPAC::Normalize - describe normalisato Line 37  WebPAC::Normalize - describe normalisato
37    
38  =head1 VERSION  =head1 VERSION
39    
40  Version 0.11  Version 0.17
41    
42  =cut  =cut
43    
44  our $VERSION = '0.11';  our $VERSION = '0.17';
45    
46  =head1 SYNOPSIS  =head1 SYNOPSIS
47    
# Line 69  Return data structure Line 71  Return data structure
71          row => $row,          row => $row,
72          rules => $normalize_pl_config,          rules => $normalize_pl_config,
73          marc_encoding => 'utf-8',          marc_encoding => 'utf-8',
74            config => $config,
75    );    );
76    
77  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 93  sub data_structure {
93          no strict 'subs';          no strict 'subs';
94          _set_lookup( $arg->{lookup} );          _set_lookup( $arg->{lookup} );
95          _set_rec( $arg->{row} );          _set_rec( $arg->{row} );
96            _set_config( $arg->{config} );
97          _clean_ds( %{ $arg } );          _clean_ds( %{ $arg } );
98          eval "$arg->{rules}";          eval "$arg->{rules}";
99          die "error evaling $arg->{rules}: $@\n" if ($@);          die "error evaling $arg->{rules}: $@\n" if ($@);
# Line 111  sub _set_rec { Line 115  sub _set_rec {
115          $rec = shift or die "no record hash";          $rec = shift or die "no record hash";
116  }  }
117    
118    =head2 _set_config
119    
120    Set current config hash
121    
122      _set_config( $config );
123    
124    Magic keys are:
125    
126    =over 4
127    
128    =item _
129    
130    Code of current database
131    
132    =item _mfn
133    
134    Current MFN
135    
136    =back
137    
138    =cut
139    
140    my $config;
141    
142    sub _set_config {
143            $config = shift;
144    }
145    
146  =head2 _get_ds  =head2 _get_ds
147    
148  Return hash formatted as data structure  Return hash formatted as data structure
# Line 495  Save values for each MARC subfield expli Line 527  Save values for each MARC subfield expli
527          'c', rec('200','c')          'c', rec('200','c')
528    );    );
529    
530    If you specify C<+> for subfield, value will be appended
531    to previous defined subfield.
532    
533  =cut  =cut
534    
535  sub marc_compose {  sub marc_compose {
# Line 504  sub marc_compose { Line 539  sub marc_compose {
539          my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');          my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');
540          my $m = [ $f, $i1, $i2 ];          my $m = [ $f, $i1, $i2 ];
541    
542            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*$/);
553                  from_to($v, 'iso-8859-2', $marc_encoding) if ($marc_encoding);                  from_to($v, 'iso-8859-2', $marc_encoding) if ($marc_encoding);
                 push @$m, ( $sf, $v );  
554                  warn "## ++ marc_compose($f,$sf,$v) ", dump( $m ),$/ if ($debug > 1);                  warn "## ++ marc_compose($f,$sf,$v) ", dump( $m ),$/ if ($debug > 1);
555                    if ($sf ne '+') {
556                            push @$m, ( $sf, $v );
557                    } else {
558                            $m->[ $#$m ] .= $v;
559                    }
560          }          }
561    
562          warn "## marc_compose(d) ", dump( $m ),$/ if ($debug > 1);          warn "## marc_compose current marc = ", dump( $m ),$/ if ($debug > 1);
563    
564          push @{ $marc_record->[ $marc_record_offset ] }, $m if ($#{$m} > 2);          push @{ $marc_record->[ $marc_record_offset ] }, $m if ($#{$m} > 2);
565  }  }
# Line 602  sub marc_remove { Line 647  sub marc_remove {
647          warn "## full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 1);          warn "## full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 1);
648  }  }
649    
650    =head2 marc_original_order
651    
652    Copy all subfields preserving original order to marc field.
653    
654      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
661    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.
663    
664    
665    =cut
666    
667    sub marc_original_order {
668    
669            my ($to, $from) = @_;
670            die "marc_original_order needs from and to fields\n" unless ($from && $to);
671    
672            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');
676    
677            my ($i1,$i2) = defined($marc_indicators->{$to}) ? @{ $marc_indicators->{$to} } : (' ',' ');
678            warn "## marc_original_order($to,$from) source = ", dump( $r ),$/ if ($debug > 1);
679    
680            foreach my $d (@$r) {
681    
682                    if (! defined($d->{subfields}) && ref($d->{subfields}) ne 'ARRAY') {
683                            warn "# marc_original_order($to,$from): field $from doesn't have subfields specification\n";
684                            next;
685                    }
686            
687                    my @sfs = @{ $d->{subfields} };
688    
689                    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),$/ if ($debug > 2);
692    
693                    my $m = [ $to, $i1, $i2 ];
694    
695                    while (my $sf = shift @sfs) {
696    
697                            warn "#--> sf: ",dump($sf), $/ if ($debug > 2);
698                            my $offset = shift @sfs;
699                            die "corrupted sufields specification for field $from\n" unless defined($offset);
700    
701                            my $v;
702                            if (ref($d->{$sf}) eq 'ARRAY') {
703                                    $v = $d->{$sf}->[$offset] if (defined($d->{$sf}->[$offset]));
704                            } elsif ($offset == 0) {
705                                    $v = $d->{$sf};
706                            } else {
707                                    die "field $from subfield '$sf' need occurence $offset which doesn't exist", dump($d->{$sf});
708                            }
709                            push @$m, ( $sf, $v ) if (defined($v));
710                    }
711    
712                    if ($#{$m} > 2) {
713                            push @{ $marc_record->[ $marc_record_offset ] }, $m;
714                    }
715            }
716    
717            warn "## marc_record = ", dump( $marc_record ),$/ if ($debug > 1);
718    }
719    
720    
721  =head1 Functions to extract data from input  =head1 Functions to extract data from input
722    
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";
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 623  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    warn "rec1 hash: ",dump($h),"\n";
781                                    push @out, ( _pack_subfields_hash( $h ) );
782                          } else {                          } else {
783                                  $_;                                  push @out, $h;
784                          }                          }
785                  } @{ $rec->{$f} };                  }
786                    return @out;
787          } elsif( defined($rec->{$f}) ) {          } elsif( defined($rec->{$f}) ) {
788                  return $rec->{$f};                  return $rec->{$f};
789          }          }
# Line 647  sub rec2 { Line 801  sub rec2 {
801          my $f = shift;          my $f = shift;
802          return unless (defined($rec && $rec->{$f}));          return unless (defined($rec && $rec->{$f}));
803          my $sf = shift;          my $sf = shift;
804          return map { $_->{$sf} } grep { ref($_) eq 'HASH' && $_->{$sf} } @{ $rec->{$f} };          warn "rec2($f,$sf) = ", dump( $rec->{$f} ), $/ if ($debug > 1);
805            return map {
806                    if (ref($_->{$sf}) eq 'ARRAY') {
807                            @{ $_->{$sf} };
808                    } else {
809                            $_->{$sf};
810                    }
811            } grep { ref($_) eq 'HASH' && $_->{$sf} } @{ $rec->{$f} };
812  }  }
813    
814  =head2 rec  =head2 rec
# Line 660  syntaxtic sugar for Line 821  syntaxtic sugar for
821  =cut  =cut
822    
823  sub rec {  sub rec {
824            my @out;
825          if ($#_ == 0) {          if ($#_ == 0) {
826                  return rec1(@_);                  @out = rec1(@_);
827          } elsif ($#_ == 1) {          } elsif ($#_ == 1) {
828                  return rec2(@_);                  @out = rec2(@_);
829            }
830            if (@out) {
831                    return @out;
832            } else {
833                    return '';
834          }          }
835  }  }
836    
# Line 696  Prefix all values with a string Line 863  Prefix all values with a string
863  =cut  =cut
864    
865  sub prefix {  sub prefix {
866          my $p = shift or die "prefix needs string as first argument";          my $p = shift or return;
867          return map { $p . $_ } grep { defined($_) } @_;          return map { $p . $_ } grep { defined($_) } @_;
868  }  }
869    
# Line 759  sub lookup { Line 926  sub lookup {
926          }          }
927  }  }
928    
929    =head2 config
930    
931    Consult config values stored in C<config.yml>
932    
933      # return database code (key under databases in yaml)
934      $database_code = config();    # use _ from hash
935      $database_name = config('name');
936      $database_input_name = config('input name');
937      $tag = config('input normalize tag');
938    
939    Up to three levels are supported.
940    
941    =cut
942    
943    sub config {
944            return unless ($config);
945    
946            my $p = shift;
947    
948            $p ||= '';
949    
950            my $v;
951    
952            warn "### getting config($p)\n" if ($debug > 1);
953    
954            my @p = split(/\s+/,$p);
955            if ($#p < 0) {
956                    $v = $config->{ '_' };  # special, database code
957            } else {
958    
959                    my $c = dclone( $config );
960    
961                    foreach my $k (@p) {
962                            warn "### k: $k c = ",dump($c),$/ if ($debug > 1);
963                            if (ref($c) eq 'ARRAY') {
964                                    $c = shift @$c;
965                                    warn "config($p) taking first occurence of '$k', probably not what you wanted!\n";
966                                    last;
967                            }
968    
969                            if (! defined($c->{$k}) ) {
970                                    $c = undef;
971                                    last;
972                            } else {
973                                    $c = $c->{$k};
974                            }
975                    }
976                    $v = $c if ($c);
977    
978            }
979    
980            warn "## config( '$p' ) = ",dump( $v ),$/ if ($v && $debug);
981            warn "config( '$p' ) is empty\n" if (! $v);
982    
983            return $v;
984    }
985    
986    =head2 id
987    
988    Returns unique id of this record
989    
990      $id = id();
991    
992    Returns C<42/2> for 2nd occurence of MFN 42.
993    
994    =cut
995    
996    sub id {
997            my $mfn = $config->{_mfn} || die "no _mfn in config data";
998            return $mfn . $#{$marc_record} ? $#{$marc_record} + 1 : '';
999    }
1000    
1001  =head2 join_with  =head2 join_with
1002    
1003  Joins walues with some delimiter  Joins walues with some delimiter
# Line 769  Joins walues with some delimiter Line 1008  Joins walues with some delimiter
1008    
1009  sub join_with {  sub join_with {
1010          my $d = shift;          my $d = shift;
1011          return join($d, grep { defined($_) && $_ ne '' } @_);          warn "### join_with('$d',",dump(@_),")\n" if ($debug > 2);
1012            my $v = join($d, grep { defined($_) && $_ ne '' } @_);
1013            return '' unless defined($v);
1014            return $v;
1015  }  }
1016    
1017  =head2 split_rec_on  =head2 split_rec_on
# Line 797  sub split_rec_on { Line 1039  sub split_rec_on {
1039          my $v = shift @r;          my $v = shift @r;
1040          warn "### first rec($fld,$sf) = ",dump($v),$/ if ($debug > 2);          warn "### first rec($fld,$sf) = ",dump($v),$/ if ($debug > 2);
1041    
1042          return '' if( ! defined($v) || $v =~ /^\s*$/);          return '' if ( ! defined($v) || $v =~ /^\s*$/);
1043    
1044          my @s = split( $regex, $v );          my @s = split( $regex, $v );
1045          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.579  
changed lines
  Added in v.641

  ViewVC Help
Powered by ViewVC 1.1.26