/[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 603 by dpavlin, Sun Jul 23 20:19:56 2006 UTC
# Line 35  WebPAC::Normalize - describe normalisato Line 35  WebPAC::Normalize - describe normalisato
35    
36  =head1 VERSION  =head1 VERSION
37    
38  Version 0.10  Version 0.15
39    
40  =cut  =cut
41    
42  our $VERSION = '0.10';  our $VERSION = '0.15';
43    
44  =head1 SYNOPSIS  =head1 SYNOPSIS
45    
# Line 69  Return data structure Line 69  Return data structure
69          row => $row,          row => $row,
70          rules => $normalize_pl_config,          rules => $normalize_pl_config,
71          marc_encoding => 'utf-8',          marc_encoding => 'utf-8',
72            config => $config,
73    );    );
74    
75  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 91  sub data_structure {
91          no strict 'subs';          no strict 'subs';
92          _set_lookup( $arg->{lookup} );          _set_lookup( $arg->{lookup} );
93          _set_rec( $arg->{row} );          _set_rec( $arg->{row} );
94            _set_config( $arg->{config} );
95          _clean_ds( %{ $arg } );          _clean_ds( %{ $arg } );
96          eval "$arg->{rules}";          eval "$arg->{rules}";
97          die "error evaling $arg->{rules}: $@\n" if ($@);          die "error evaling $arg->{rules}: $@\n" if ($@);
# Line 111  sub _set_rec { Line 113  sub _set_rec {
113          $rec = shift or die "no record hash";          $rec = shift or die "no record hash";
114  }  }
115    
116    =head2 _set_config
117    
118    Set current config hash
119    
120      _set_config( $config );
121    
122    Magic keys are:
123    
124    =over 4
125    
126    =item _
127    
128    Code of current database
129    
130    =item _mfn
131    
132    Current MFN
133    
134    =back
135    
136    =cut
137    
138    my $config;
139    
140    sub _set_config {
141            $config = shift;
142    }
143    
144  =head2 _get_ds  =head2 _get_ds
145    
146  Return hash formatted as data structure  Return hash formatted as data structure
# Line 326  sub _get_marc_fields { Line 356  sub _get_marc_fields {
356                  warn "## saved/3 ", dump( $field ),$/ if ($debug);                  warn "## saved/3 ", dump( $field ),$/ if ($debug);
357          }          }
358    
359          return @m;          return \@m;
360  }  }
361    
362  =head2 _debug  =head2 _debug
# 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          while (@_) {          while (@_) {
543                  my $sf = shift or die "marc_compose $f needs subfield";                  my $sf = shift or die "marc_compose $f needs subfield";
544                  my $v = shift;                  my $v = shift;
545    
546                  next unless (defined($v) && $v !~ /^\s*$/);                  next unless (defined($v) && $v !~ /^\s*$/);
547                  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 );  
548                  warn "## ++ marc_compose($f,$sf,$v) ", dump( $m ),$/ if ($debug > 1);                  warn "## ++ marc_compose($f,$sf,$v) ", dump( $m ),$/ if ($debug > 1);
549                    if ($sf ne '+') {
550                            push @$m, ( $sf, $v );
551                    } else {
552                            $m->[ $#$m ] .= $v;
553                    }
554          }          }
555    
556          warn "## marc_compose(d) ", dump( $m ),$/ if ($debug > 1);          warn "## marc_compose current marc = ", dump( $m ),$/ if ($debug > 1);
557    
558          push @{ $marc_record->[ $marc_record_offset ] }, $m if ($#{$m} > 2);          push @{ $marc_record->[ $marc_record_offset ] }, $m if ($#{$m} > 2);
559  }  }
# Line 565  sub marc_remove { Line 604  sub marc_remove {
604    
605          warn "### marc_remove before = ", dump( $marc ), $/ if ($debug > 2);          warn "### marc_remove before = ", dump( $marc ), $/ if ($debug > 2);
606    
607          foreach my $i ( 0 .. $#{ $marc } ) {          my $i = 0;
608            foreach ( 0 .. $#{ $marc } ) {
609                  last unless (defined $marc->[$i]);                  last unless (defined $marc->[$i]);
610                  warn "#### working on ",dump( @{ $marc->[$i] }), $/ if ($debug > 3);                  warn "#### working on ",dump( @{ $marc->[$i] }), $/ if ($debug > 3);
611                  if ($marc->[$i]->[0] eq $f) {                  if ($marc->[$i]->[0] eq $f) {
# Line 591  sub marc_remove { Line 631  sub marc_remove {
631                                  }                                  }
632                          }                          }
633                  }                  }
634                    $i++;
635          }          }
636    
637          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 645  sub rec2 { Line 686  sub rec2 {
686          my $f = shift;          my $f = shift;
687          return unless (defined($rec && $rec->{$f}));          return unless (defined($rec && $rec->{$f}));
688          my $sf = shift;          my $sf = shift;
689          return map { $_->{$sf} } grep { ref($_) eq 'HASH' && $_->{$sf} } @{ $rec->{$f} };          warn "rec2($f,$sf) = ", dump( $rec->{$f} ), $/ if ($debug > 1);
690            return map {
691                    if (ref($_->{$sf}) eq 'ARRAY') {
692                            @{ $_->{$sf} };
693                    } else {
694                            $_->{$sf};
695                    }
696            } grep { ref($_) eq 'HASH' && $_->{$sf} } @{ $rec->{$f} };
697  }  }
698    
699  =head2 rec  =head2 rec
# Line 658  syntaxtic sugar for Line 706  syntaxtic sugar for
706  =cut  =cut
707    
708  sub rec {  sub rec {
709            my @out;
710          if ($#_ == 0) {          if ($#_ == 0) {
711                  return rec1(@_);                  @out = rec1(@_);
712          } elsif ($#_ == 1) {          } elsif ($#_ == 1) {
713                  return rec2(@_);                  @out = rec2(@_);
714            }
715            if (@out) {
716                    return @out;
717            } else {
718                    return '';
719          }          }
720  }  }
721    
# Line 694  Prefix all values with a string Line 748  Prefix all values with a string
748  =cut  =cut
749    
750  sub prefix {  sub prefix {
751          my $p = shift or die "prefix needs string as first argument";          my $p = shift or return;
752          return map { $p . $_ } grep { defined($_) } @_;          return map { $p . $_ } grep { defined($_) } @_;
753  }  }
754    
# Line 757  sub lookup { Line 811  sub lookup {
811          }          }
812  }  }
813    
814    =head2 config
815    
816    Consult config values stored in C<config.yml>
817    
818      # return database code (key under databases in yaml)
819      $database_code = config();    # use _ from hash
820      $database_name = config('name');
821      $database_input_name = config('input name');
822      $tag = config('input normalize tag');
823    
824    Up to three levels are supported.
825    
826    =cut
827    
828    sub config {
829            return unless ($config);
830    
831            my $p = shift;
832    
833            $p ||= '';
834    
835            my $v;
836    
837            warn "### getting config($p)\n" if ($debug > 1);
838    
839            my @p = split(/\s+/,$p);
840            if ($#p < 0) {
841                    $v = $config->{ '_' };  # special, database code
842            } else {
843    
844                    my $c = dclone( $config );
845    
846                    foreach my $k (@p) {
847                            warn "### k: $k c = ",dump($c),$/ if ($debug > 1);
848                            if (ref($c) eq 'ARRAY') {
849                                    $c = shift @$c;
850                                    warn "config($p) taking first occurence of '$k', probably not what you wanted!\n";
851                                    last;
852                            }
853    
854                            if (! defined($c->{$k}) ) {
855                                    $c = undef;
856                                    last;
857                            } else {
858                                    $c = $c->{$k};
859                            }
860                    }
861                    $v = $c if ($c);
862    
863            }
864    
865            warn "## config( '$p' ) = ",dump( $v ),$/ if ($v && $debug);
866            warn "config( '$p' ) is empty\n" if (! $v);
867    
868            return $v;
869    }
870    
871    =head2 id
872    
873    Returns unique id of this record
874    
875      $id = id();
876    
877    Returns C<42/2> for 2nd occurence of MFN 42.
878    
879    =cut
880    
881    sub id {
882            my $mfn = $config->{_mfn} || die "no _mfn in config data";
883            return $mfn . $#{$marc_record} ? $#{$marc_record} + 1 : '';
884    }
885    
886  =head2 join_with  =head2 join_with
887    
888  Joins walues with some delimiter  Joins walues with some delimiter
# Line 767  Joins walues with some delimiter Line 893  Joins walues with some delimiter
893    
894  sub join_with {  sub join_with {
895          my $d = shift;          my $d = shift;
896          return join($d, grep { defined($_) && $_ ne '' } @_);          warn "### join_with('$d',",dump(@_),")\n" if ($debug > 2);
897            my $v = join($d, grep { defined($_) && $_ ne '' } @_);
898            return '' unless defined($v);
899            return $v;
900  }  }
901    
902  =head2 split_rec_on  =head2 split_rec_on
Legend:
Removed from v.574  
changed lines
  Added in v.603
  ViewVC Help
Powered by ViewVC 1.1.26