/[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 601 by dpavlin, Sun Jul 23 17:33:11 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.14
39    
40  =cut  =cut
41    
42  our $VERSION = '0.10';  our $VERSION = '0.14';
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 504  sub marc_compose { Line 534  sub marc_compose {
534          my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');          my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');
535          my $m = [ $f, $i1, $i2 ];          my $m = [ $f, $i1, $i2 ];
536    
537            warn "### marc_compose input subfields = ", dump(@_),$/ if ($debug > 2);
538    
539          while (@_) {          while (@_) {
540                  my $sf = shift or die "marc_compose $f needs subfield";                  my $sf = shift or die "marc_compose $f needs subfield";
541                  my $v = shift;                  my $v = shift;
# Line 514  sub marc_compose { Line 546  sub marc_compose {
546                  warn "## ++ marc_compose($f,$sf,$v) ", dump( $m ),$/ if ($debug > 1);                  warn "## ++ marc_compose($f,$sf,$v) ", dump( $m ),$/ if ($debug > 1);
547          }          }
548    
549          warn "## marc_compose(d) ", dump( $m ),$/ if ($debug > 1);          warn "## marc_compose current marc = ", dump( $m ),$/ if ($debug > 1);
550    
551          push @{ $marc_record->[ $marc_record_offset ] }, $m if ($#{$m} > 2);          push @{ $marc_record->[ $marc_record_offset ] }, $m if ($#{$m} > 2);
552  }  }
# Line 565  sub marc_remove { Line 597  sub marc_remove {
597    
598          warn "### marc_remove before = ", dump( $marc ), $/ if ($debug > 2);          warn "### marc_remove before = ", dump( $marc ), $/ if ($debug > 2);
599    
600          foreach my $i ( 0 .. $#{ $marc } ) {          my $i = 0;
601            foreach ( 0 .. $#{ $marc } ) {
602                  last unless (defined $marc->[$i]);                  last unless (defined $marc->[$i]);
603                  warn "#### working on ",dump( @{ $marc->[$i] }), $/ if ($debug > 3);                  warn "#### working on ",dump( @{ $marc->[$i] }), $/ if ($debug > 3);
604                  if ($marc->[$i]->[0] eq $f) {                  if ($marc->[$i]->[0] eq $f) {
# Line 591  sub marc_remove { Line 624  sub marc_remove {
624                                  }                                  }
625                          }                          }
626                  }                  }
627                    $i++;
628          }          }
629    
630          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 679  sub rec2 {
679          my $f = shift;          my $f = shift;
680          return unless (defined($rec && $rec->{$f}));          return unless (defined($rec && $rec->{$f}));
681          my $sf = shift;          my $sf = shift;
682          return map { $_->{$sf} } grep { ref($_) eq 'HASH' && $_->{$sf} } @{ $rec->{$f} };          warn "rec2($f,$sf) = ", dump( $rec->{$f} ), $/ if ($debug > 1);
683            return map {
684                    if (ref($_->{$sf}) eq 'ARRAY') {
685                            @{ $_->{$sf} };
686                    } else {
687                            $_->{$sf};
688                    }
689            } grep { ref($_) eq 'HASH' && $_->{$sf} } @{ $rec->{$f} };
690  }  }
691    
692  =head2 rec  =head2 rec
# Line 658  syntaxtic sugar for Line 699  syntaxtic sugar for
699  =cut  =cut
700    
701  sub rec {  sub rec {
702            my @out;
703          if ($#_ == 0) {          if ($#_ == 0) {
704                  return rec1(@_);                  @out = rec1(@_);
705          } elsif ($#_ == 1) {          } elsif ($#_ == 1) {
706                  return rec2(@_);                  @out = rec2(@_);
707            }
708            if (@out) {
709                    return @out;
710            } else {
711                    return '';
712          }          }
713  }  }
714    
# Line 694  Prefix all values with a string Line 741  Prefix all values with a string
741  =cut  =cut
742    
743  sub prefix {  sub prefix {
744          my $p = shift or die "prefix needs string as first argument";          my $p = shift or return;
745          return map { $p . $_ } grep { defined($_) } @_;          return map { $p . $_ } grep { defined($_) } @_;
746  }  }
747    
# Line 757  sub lookup { Line 804  sub lookup {
804          }          }
805  }  }
806    
807    =head2 config
808    
809    Consult config values stored in C<config.yml>
810    
811      # return database code (key under databases in yaml)
812      $database_code = config();    # use _ from hash
813      $database_name = config('name');
814      $database_input_name = config('input name');
815      $tag = config('input normalize tag');
816    
817    Up to three levels are supported.
818    
819    =cut
820    
821    sub config {
822            return unless ($config);
823    
824            my $p = shift;
825    
826            $p ||= '';
827    
828            my $v;
829    
830            warn "### getting config($p)\n" if ($debug > 1);
831    
832            my @p = split(/\s+/,$p);
833            if ($#p < 0) {
834                    $v = $config->{ '_' };  # special, database code
835            } else {
836    
837                    my $c = dclone( $config );
838    
839                    foreach my $k (@p) {
840                            warn "### k: $k c = ",dump($c),$/ if ($debug > 1);
841                            if (ref($c) eq 'ARRAY') {
842                                    $c = shift @$c;
843                                    warn "config($p) taking first occurence of '$k', probably not what you wanted!\n";
844                                    last;
845                            }
846    
847                            if (! defined($c->{$k}) ) {
848                                    $c = undef;
849                                    last;
850                            } else {
851                                    $c = $c->{$k};
852                            }
853                    }
854                    $v = $c if ($c);
855    
856            }
857    
858            warn "## config( '$p' ) = ",dump( $v ),$/ if ($v && $debug);
859            warn "config( '$p' ) is empty\n" if (! $v);
860    
861            return $v;
862    }
863    
864    =head2 id
865    
866    Returns unique id of this record
867    
868      $id = id();
869    
870    Returns C<42/2> for 2nd occurence of MFN 42.
871    
872    =cut
873    
874    sub id {
875            my $mfn = $config->{_mfn} || die "no _mfn in config data";
876            return $mfn . $#{$marc_record} ? $#{$marc_record} + 1 : '';
877    }
878    
879  =head2 join_with  =head2 join_with
880    
881  Joins walues with some delimiter  Joins walues with some delimiter
# Line 767  Joins walues with some delimiter Line 886  Joins walues with some delimiter
886    
887  sub join_with {  sub join_with {
888          my $d = shift;          my $d = shift;
889          return join($d, grep { defined($_) && $_ ne '' } @_);          warn "### join_with('$d',",dump(@_),")\n" if ($debug > 2);
890            my $v = join($d, grep { defined($_) && $_ ne '' } @_);
891            return '' unless defined($v);
892            return $v;
893  }  }
894    
895  =head2 split_rec_on  =head2 split_rec_on

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

  ViewVC Help
Powered by ViewVC 1.1.26