/[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 661 by dpavlin, Fri Sep 8 17:47:58 2006 UTC revision 707 by dpavlin, Mon Sep 25 15:26:12 2006 UTC
# Line 15  use Exporter 'import'; Line 15  use Exporter 'import';
15          rec1 rec2 rec          rec1 rec2 rec
16          regex prefix suffix surround          regex prefix suffix surround
17          first lookup join_with          first lookup join_with
18            save_into_lookup
19    
20          split_rec_on          split_rec_on
21  /;  /;
# Line 36  WebPAC::Normalize - describe normalisato Line 37  WebPAC::Normalize - describe normalisato
37    
38  =head1 VERSION  =head1 VERSION
39    
40  Version 0.18  Version 0.20
41    
42  =cut  =cut
43    
44  our $VERSION = '0.18';  our $VERSION = '0.20';
45    
46  =head1 SYNOPSIS  =head1 SYNOPSIS
47    
# Line 66  All other functions are available for us Line 67  All other functions are available for us
67  Return data structure  Return data structure
68    
69    my $ds = WebPAC::Normalize::data_structure(    my $ds = WebPAC::Normalize::data_structure(
70          lookup => $lookup->lookup_hash,          lookup => $lookup_variable,
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,          config => $config,
75    );    );
76    
77  Options C<lookup>, C<row>, C<rules> and C<log> are mandatory while all  Options C<row>, C<rules> and C<log> are mandatory while all
78  other are optional.  other are optional.
79    
80  This function will B<die> if normalizastion can't be evaled.  This function will B<die> if normalizastion can't be evaled.
# Line 90  sub data_structure { Line 91  sub data_structure {
91          die "need normalisation argument" unless ($arg->{rules});          die "need normalisation argument" unless ($arg->{rules});
92    
93          no strict 'subs';          no strict 'subs';
94          _set_lookup( $arg->{lookup} );          _set_lookup( $arg->{lookup} ) if (defined( $arg->{lookup} ));
95          _set_rec( $arg->{row} );          _set_rec( $arg->{row} );
96          _set_config( $arg->{config} );          _set_config( $arg->{config} ) if (defined( $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 186  sub _set_lookup { Line 187  sub _set_lookup {
187          $lookup = shift;          $lookup = shift;
188  }  }
189    
190    =head2 _get_lookup
191    
192    Get current lookup hash
193    
194      my $lookup = _get_lookup();
195    
196    =cut
197    
198    sub _get_lookup {
199            return $lookup;
200    }
201    
202  =head2 _get_marc_fields  =head2 _get_marc_fields
203    
204  Get all fields defined by calls to C<marc>  Get all fields defined by calls to C<marc>
# Line 722  above. Line 735  above.
735    
736  =head2 _pack_subfields_hash  =head2 _pack_subfields_hash
737    
738   @values = _pack_subfields_hash( $h, $include_subfields )   @subfields = _pack_subfields_hash( $h );
739     $subfields = _pack_subfields_hash( $h, 1 );
740    
741    Return each subfield value in array or pack them all together and return scalar
742    with subfields (denoted by C<^>) and values.
743    
744  =cut  =cut
745    
# Line 732  sub _pack_subfields_hash { Line 749  sub _pack_subfields_hash {
749    
750          my ($h,$include_subfields) = @_;          my ($h,$include_subfields) = @_;
751    
   
752          if ( defined($h->{subfields}) ) {          if ( defined($h->{subfields}) ) {
753                  my $sfs = delete $h->{subfields} || die "no subfields?";                  my $sfs = delete $h->{subfields} || die "no subfields?";
754                  my @out;                  my @out;
# Line 742  sub _pack_subfields_hash { Line 758  sub _pack_subfields_hash {
758                          my $o = shift @$sfs;                          my $o = shift @$sfs;
759                          if ($o == 0 && ref( $h->{$sf} ) ne 'ARRAY' ) {                          if ($o == 0 && ref( $h->{$sf} ) ne 'ARRAY' ) {
760                                  # single element subfields are not arrays                                  # single element subfields are not arrays
761    #warn "====> $sf $o / $#$sfs ", dump( $sfs, $h->{$sf} ), "\n";
762    
763                                  push @out, $h->{$sf};                                  push @out, $h->{$sf};
764                          } else {                          } else {
765  #warn "====> $f $sf $o $#$sfs ", dump( $sfs ), "\n";  #warn "====> $sf $o / $#$sfs ", dump( $sfs, $h->{$sf} ), "\n";
766                                  push @out, $h->{$sf}->[$o];                                  push @out, $h->{$sf}->[$o];
767                          }                          }
768                  }                  }
769                  return @out;                  if ($include_subfields) {
770                            return join('', @out);
771                    } else {
772                            return @out;
773                    }
774          } else {          } else {
775                  # FIXME this should probably be in alphabetical order instead of hash order                  if ($include_subfields) {
776                  values %{$h};                          my $out = '';
777                            foreach my $sf (sort keys %$h) {
778                                    if (ref($h->{$sf}) eq 'ARRAY') {
779                                            $out .= '^' . $sf . join('^' . $sf, @{ $h->{$sf} });
780                                    } else {
781                                            $out .= '^' . $sf . $h->{$sf};
782                                    }
783                            }
784                            return $out;
785                    } else {
786                            # FIXME this should probably be in alphabetical order instead of hash order
787                            values %{$h};
788                    }
789          }          }
790  }  }
791    
# Line 910  Consult lookup hashes for some value Line 944  Consult lookup hashes for some value
944    @v = lookup( $v );    @v = lookup( $v );
945    @v = lookup( @v );    @v = lookup( @v );
946    
947    FIXME B<currently this one is broken!>
948    
949  =cut  =cut
950    
951  sub lookup {  sub lookup {
# Line 922  sub lookup { Line 958  sub lookup {
958          }          }
959  }  }
960    
961    =head2 save_into_lookup
962    
963    Save value into lookup.
964    
965      save_into_lookup($key,sub {
966            # code which produce one or more values
967      });
968    
969    This function shouldn't be called directly, it's called from code created by L<WebPAC::Parser>.
970    
971    =cut
972    
973    sub save_into_lookup {
974            my ($k,$coderef) = @_;
975            die "save_into_lookup needs key" unless defined($k);
976            die "save_into_lookup needs CODE" unless ( defined($coderef) && ref($coderef) eq 'CODE' );
977            my $mfn = $rec->{'000'}->[0] || die "mfn not defined or zero";
978            foreach my $v ( $coderef->() ) {
979                    $lookup->{$k}->{$v}->{$mfn}++;
980                    warn "# lookup $k $v $mfn saved\n";     # if ($debug > 1);
981            }
982    }
983    
984  =head2 config  =head2 config
985    
986  Consult config values stored in C<config.yml>  Consult config values stored in C<config.yml>

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

  ViewVC Help
Powered by ViewVC 1.1.26