/[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 618 by dpavlin, Fri Aug 25 12:31:01 2006 UTC
# Line 9  use Exporter 'import'; Line 9  use Exporter 'import';
9          marc marc_indicators marc_repeatable_subfield          marc marc_indicators marc_repeatable_subfield
10          marc_compose marc_leader          marc_compose marc_leader
11          marc_duplicate marc_remove          marc_duplicate marc_remove
12            marc_original_order
13    
14          rec1 rec2 rec          rec1 rec2 rec
15          regex prefix suffix surround          regex prefix suffix surround
# Line 35  WebPAC::Normalize - describe normalisato Line 36  WebPAC::Normalize - describe normalisato
36    
37  =head1 VERSION  =head1 VERSION
38    
39  Version 0.11  Version 0.16
40    
41  =cut  =cut
42    
43  our $VERSION = '0.11';  our $VERSION = '0.16';
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 495  Save values for each MARC subfield expli Line 526  Save values for each MARC subfield expli
526          'c', rec('200','c')          'c', rec('200','c')
527    );    );
528    
529    If you specify C<+> for subfield, value will be appended
530    to previous defined subfield.
531    
532  =cut  =cut
533    
534  sub marc_compose {  sub marc_compose {
# Line 504  sub marc_compose { Line 538  sub marc_compose {
538          my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');          my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');
539          my $m = [ $f, $i1, $i2 ];          my $m = [ $f, $i1, $i2 ];
540    
541            warn "### marc_compose input subfields = ", dump(@_),$/ if ($debug > 2);
542    
543          while (@_) {          while (@_) {
544                  my $sf = shift or die "marc_compose $f needs subfield";                  my $sf = shift or die "marc_compose $f needs subfield";
545                  my $v = shift;                  my $v = shift;
546    
547                  next unless (defined($v) && $v !~ /^\s*$/);                  next unless (defined($v) && $v !~ /^\s*$/);
548                  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 );  
549                  warn "## ++ marc_compose($f,$sf,$v) ", dump( $m ),$/ if ($debug > 1);                  warn "## ++ marc_compose($f,$sf,$v) ", dump( $m ),$/ if ($debug > 1);
550                    if ($sf ne '+') {
551                            push @$m, ( $sf, $v );
552                    } else {
553                            $m->[ $#$m ] .= $v;
554                    }
555          }          }
556    
557          warn "## marc_compose(d) ", dump( $m ),$/ if ($debug > 1);          warn "## marc_compose current marc = ", dump( $m ),$/ if ($debug > 1);
558    
559          push @{ $marc_record->[ $marc_record_offset ] }, $m if ($#{$m} > 2);          push @{ $marc_record->[ $marc_record_offset ] }, $m if ($#{$m} > 2);
560  }  }
# Line 602  sub marc_remove { Line 642  sub marc_remove {
642          warn "## full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 1);          warn "## full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 1);
643  }  }
644    
645    =head2 marc_original_order
646    
647    Copy all subfields preserving original order to marc field.
648    
649      marc_original_order( marc_field_number, original_input_field_number );
650    
651    Please note that field numbers are consistent with other commands (marc
652    field number first), but somewhat counter-intuitive (destination and then
653    source).
654    
655    You might want to use this command if you are just renaming subfields or
656    using pre-processing modify_record in C<config.yml> and don't need any
657    post-processing or want to preserve order of original subfields.
658    
659    
660    =cut
661    
662    sub marc_original_order {
663    
664            my ($to, $from) = @_;
665            die "marc_original_order needs from and to fields\n" unless ($from && $to);
666    
667            return unless defined($rec->{$from});
668    
669            my $r = $rec->{$from};
670            die "record field $from isn't array\n" unless (ref($r) eq 'ARRAY');
671    
672            my ($i1,$i2) = defined($marc_indicators->{$to}) ? @{ $marc_indicators->{$to} } : (' ',' ');
673            warn "## marc_original_order($to,$from) source = ", dump( $r ),$/ if ($debug > 1);
674    
675            foreach my $d (@$r) {
676    
677                    if (! defined($d->{subfields}) && ref($d->{subfields}) ne 'ARRAY') {
678                            warn "# marc_original_order($to,$from): field $from doesn't have subfields specification\n";
679                            next;
680                    }
681            
682                    my @sfs = @{ $d->{subfields} };
683    
684                    die "field $from doesn't have even number of subfields specifications\n" unless($#sfs % 2 == 1);
685    
686                    warn "#--> d: ",dump($d), "\n#--> sfs: ",dump(@sfs),$/ if ($debug > 2);
687    
688                    my $m = [ $to, $i1, $i2 ];
689    
690                    while (my $sf = shift @sfs) {
691    
692                            warn "#--> sf: ",dump($sf), $/ if ($debug > 2);
693                            my $offset = shift @sfs;
694                            die "corrupted sufields specification for field $from\n" unless defined($offset);
695    
696                            my $v;
697                            if (ref($d->{$sf}) eq 'ARRAY') {
698                                    $v = $d->{$sf}->[$offset] if (defined($d->{$sf}->[$offset]));
699                            } elsif ($offset == 0) {
700                                    $v = $d->{$sf};
701                            } else {
702                                    die "field $from subfield '$sf' need occurence $offset which doesn't exist", dump($d->{$sf});
703                            }
704                            push @$m, ( $sf, $v ) if (defined($v));
705                    }
706    
707                    if ($#{$m} > 2) {
708                            push @{ $marc_record->[ $marc_record_offset ] }, $m;
709                    }
710            }
711    
712            warn "## marc_record = ", dump( $marc_record ),$/ if ($debug > 1);
713    }
714    
715    
716  =head1 Functions to extract data from input  =head1 Functions to extract data from input
717    
718  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
# Line 647  sub rec2 { Line 758  sub rec2 {
758          my $f = shift;          my $f = shift;
759          return unless (defined($rec && $rec->{$f}));          return unless (defined($rec && $rec->{$f}));
760          my $sf = shift;          my $sf = shift;
761          return map { $_->{$sf} } grep { ref($_) eq 'HASH' && $_->{$sf} } @{ $rec->{$f} };          warn "rec2($f,$sf) = ", dump( $rec->{$f} ), $/ if ($debug > 1);
762            return map {
763                    if (ref($_->{$sf}) eq 'ARRAY') {
764                            @{ $_->{$sf} };
765                    } else {
766                            $_->{$sf};
767                    }
768            } grep { ref($_) eq 'HASH' && $_->{$sf} } @{ $rec->{$f} };
769  }  }
770    
771  =head2 rec  =head2 rec
# Line 660  syntaxtic sugar for Line 778  syntaxtic sugar for
778  =cut  =cut
779    
780  sub rec {  sub rec {
781            my @out;
782          if ($#_ == 0) {          if ($#_ == 0) {
783                  return rec1(@_);                  @out = rec1(@_);
784          } elsif ($#_ == 1) {          } elsif ($#_ == 1) {
785                  return rec2(@_);                  @out = rec2(@_);
786            }
787            if (@out) {
788                    return @out;
789            } else {
790                    return '';
791          }          }
792  }  }
793    
# Line 696  Prefix all values with a string Line 820  Prefix all values with a string
820  =cut  =cut
821    
822  sub prefix {  sub prefix {
823          my $p = shift or die "prefix needs string as first argument";          my $p = shift or return;
824          return map { $p . $_ } grep { defined($_) } @_;          return map { $p . $_ } grep { defined($_) } @_;
825  }  }
826    
# Line 759  sub lookup { Line 883  sub lookup {
883          }          }
884  }  }
885    
886    =head2 config
887    
888    Consult config values stored in C<config.yml>
889    
890      # return database code (key under databases in yaml)
891      $database_code = config();    # use _ from hash
892      $database_name = config('name');
893      $database_input_name = config('input name');
894      $tag = config('input normalize tag');
895    
896    Up to three levels are supported.
897    
898    =cut
899    
900    sub config {
901            return unless ($config);
902    
903            my $p = shift;
904    
905            $p ||= '';
906    
907            my $v;
908    
909            warn "### getting config($p)\n" if ($debug > 1);
910    
911            my @p = split(/\s+/,$p);
912            if ($#p < 0) {
913                    $v = $config->{ '_' };  # special, database code
914            } else {
915    
916                    my $c = dclone( $config );
917    
918                    foreach my $k (@p) {
919                            warn "### k: $k c = ",dump($c),$/ if ($debug > 1);
920                            if (ref($c) eq 'ARRAY') {
921                                    $c = shift @$c;
922                                    warn "config($p) taking first occurence of '$k', probably not what you wanted!\n";
923                                    last;
924                            }
925    
926                            if (! defined($c->{$k}) ) {
927                                    $c = undef;
928                                    last;
929                            } else {
930                                    $c = $c->{$k};
931                            }
932                    }
933                    $v = $c if ($c);
934    
935            }
936    
937            warn "## config( '$p' ) = ",dump( $v ),$/ if ($v && $debug);
938            warn "config( '$p' ) is empty\n" if (! $v);
939    
940            return $v;
941    }
942    
943    =head2 id
944    
945    Returns unique id of this record
946    
947      $id = id();
948    
949    Returns C<42/2> for 2nd occurence of MFN 42.
950    
951    =cut
952    
953    sub id {
954            my $mfn = $config->{_mfn} || die "no _mfn in config data";
955            return $mfn . $#{$marc_record} ? $#{$marc_record} + 1 : '';
956    }
957    
958  =head2 join_with  =head2 join_with
959    
960  Joins walues with some delimiter  Joins walues with some delimiter
# Line 769  Joins walues with some delimiter Line 965  Joins walues with some delimiter
965    
966  sub join_with {  sub join_with {
967          my $d = shift;          my $d = shift;
968          return join($d, grep { defined($_) && $_ ne '' } @_);          warn "### join_with('$d',",dump(@_),")\n" if ($debug > 2);
969            my $v = join($d, grep { defined($_) && $_ ne '' } @_);
970            return '' unless defined($v);
971            return $v;
972  }  }
973    
974  =head2 split_rec_on  =head2 split_rec_on
# Line 797  sub split_rec_on { Line 996  sub split_rec_on {
996          my $v = shift @r;          my $v = shift @r;
997          warn "### first rec($fld,$sf) = ",dump($v),$/ if ($debug > 2);          warn "### first rec($fld,$sf) = ",dump($v),$/ if ($debug > 2);
998    
999          return '' if( ! defined($v) || $v =~ /^\s*$/);          return '' if ( ! defined($v) || $v =~ /^\s*$/);
1000    
1001          my @s = split( $regex, $v );          my @s = split( $regex, $v );
1002          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.618

  ViewVC Help
Powered by ViewVC 1.1.26