/[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 725 by dpavlin, Fri Sep 29 18:55:41 2006 UTC revision 785 by dpavlin, Wed Dec 6 23:44:36 2006 UTC
# Line 2  package WebPAC::Normalize; Line 2  package WebPAC::Normalize;
2  use Exporter 'import';  use Exporter 'import';
3  @EXPORT = qw/  @EXPORT = qw/
4          _set_rec _set_lookup          _set_rec _set_lookup
5          _set_load_ds          _set_load_row
6          _get_ds _clean_ds          _get_ds _clean_ds
7          _debug          _debug
8          _pack_subfields_hash          _pack_subfields_hash
# Line 19  use Exporter 'import'; Line 19  use Exporter 'import';
19          save_into_lookup          save_into_lookup
20    
21          split_rec_on          split_rec_on
22    
23            get set
24  /;  /;
25    
26  use warnings;  use warnings;
# Line 39  WebPAC::Normalize - describe normalisato Line 41  WebPAC::Normalize - describe normalisato
41    
42  =head1 VERSION  =head1 VERSION
43    
44  Version 0.21  Version 0.24
45    
46  =cut  =cut
47    
48  our $VERSION = '0.21';  our $VERSION = '0.24';
49    
50  =head1 SYNOPSIS  =head1 SYNOPSIS
51    
# Line 74  Return data structure Line 76  Return data structure
76          rules => $normalize_pl_config,          rules => $normalize_pl_config,
77          marc_encoding => 'utf-8',          marc_encoding => 'utf-8',
78          config => $config,          config => $config,
79          load_ds_coderef => sub {          load_row_coderef => sub {
80                  my ($database,$input,$mfn) = shift;                  my ($database,$input,$mfn) = shift;
81                  $store->load_ds( database => $database, input => $input, id => $mfn );                  $store->load_row( database => $database, input => $input, id => $mfn );
82          },          },
83    );    );
84    
85  Options C<row>, C<rules> and C<log> are mandatory while all  Options C<row>, C<rules> and C<log> are mandatory while all
86  other are optional.  other are optional.
87    
88  C<load_ds_coderef> is closure only used when executing lookups, so they will  C<load_row_coderef> is closure only used when executing lookups, so they will
89  die if it's not defined.  die if it's not defined.
90    
91  This function will B<die> if normalizastion can't be evaled.  This function will B<die> if normalizastion can't be evaled.
# Line 93  C<WebPAC::Normalize::data_structure>. Line 95  C<WebPAC::Normalize::data_structure>.
95    
96  =cut  =cut
97    
98  my $load_ds_coderef;  my $load_row_coderef;
99    
100  sub data_structure {  sub data_structure {
101          my $arg = {@_};          my $arg = {@_};
# Line 102  sub data_structure { Line 104  sub data_structure {
104          die "need normalisation argument" unless ($arg->{rules});          die "need normalisation argument" unless ($arg->{rules});
105    
106          no strict 'subs';          no strict 'subs';
107          _set_lookup( $arg->{lookup} );          _set_lookup( $arg->{lookup} ) if defined($arg->{lookup});
108          _set_rec( $arg->{row} );          _set_rec( $arg->{row} );
109          _set_config( $arg->{config} );          _set_config( $arg->{config} ) if defined($arg->{config});
110          _clean_ds( %{ $arg } );          _clean_ds( %{ $arg } );
111          $load_ds_coderef = $arg->{load_ds_coderef};          $load_row_coderef = $arg->{load_row_coderef};
112    
113          eval "$arg->{rules}";          eval "$arg->{rules}";
114          die "error evaling $arg->{rules}: $@\n" if ($@);          die "error evaling $arg->{rules}: $@\n" if ($@);
# Line 164  Return hash formatted as data structure Line 166  Return hash formatted as data structure
166    
167  =cut  =cut
168    
169  my ($out, $marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators);  my ($out, $marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators, $leader);
170  my ($marc_record_offset, $marc_fetch_offset) = (0, 0);  my ($marc_record_offset, $marc_fetch_offset) = (0, 0);
171    
172  sub _get_ds {  sub _get_ds {
# Line 181  Clean data structure hash for next recor Line 183  Clean data structure hash for next recor
183    
184  sub _clean_ds {  sub _clean_ds {
185          my $a = {@_};          my $a = {@_};
186          ($out,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators) = ();          ($out,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators, $leader) = ();
187          ($marc_record_offset, $marc_fetch_offset) = (0,0);          ($marc_record_offset, $marc_fetch_offset) = (0,0);
188          $marc_encoding = $a->{marc_encoding};          $marc_encoding = $a->{marc_encoding};
189  }  }
# Line 212  sub _get_lookup { Line 214  sub _get_lookup {
214          return $lookup;          return $lookup;
215  }  }
216    
217  =head2 _set_load_ds  =head2 _set_load_row
218    
219  Setup code reference which will return L<data_structure> from  Setup code reference which will return L<data_structure> from
220  L<WebPAC::Store>  L<WebPAC::Store>
221    
222    _set_load_ds(sub {    _set_load_row(sub {
223                  my ($database,$input,$mfn) = @_;                  my ($database,$input,$mfn) = @_;
224                  $store->load_ds( database => $database, input => $input, id => $mfn );                  $store->load_row( database => $database, input => $input, id => $mfn );
225    });    });
226    
227  =cut  =cut
228    
229  sub _set_load_ds {  sub _set_load_row {
230          my $coderef = shift;          my $coderef = shift;
231          confess "argument isn't CODE" unless ref($coderef) eq 'CODE';          confess "argument isn't CODE" unless ref($coderef) eq 'CODE';
232    
233          $load_ds_coderef = $coderef;          $load_row_coderef = $coderef;
234  }  }
235    
236  =head2 _get_marc_fields  =head2 _get_marc_fields
# Line 487  sub marc_leader { Line 489  sub marc_leader {
489          my ($offset,$value) = @_;          my ($offset,$value) = @_;
490    
491          if ($offset) {          if ($offset) {
492                  $out->{' leader'}->{ $offset } = $value;                  $leader->{ $offset } = $value;
493          } else {          } else {
494                  return $out->{' leader'};                  return $leader;
495          }          }
496  }  }
497    
# Line 880  syntaxtic sugar for Line 882  syntaxtic sugar for
882    @v = rec('200')    @v = rec('200')
883    @v = rec('200','a')    @v = rec('200','a')
884    
885    If rec() returns just single value, it will
886    return scalar, not array.
887    
888  =cut  =cut
889    
890  sub rec {  sub rec {
# Line 889  sub rec { Line 894  sub rec {
894          } elsif ($#_ == 1) {          } elsif ($#_ == 1) {
895                  @out = rec2(@_);                  @out = rec2(@_);
896          }          }
897          if (@out) {          if ($#out == 0 && ! wantarray) {
898                    return $out[0];
899            } elsif (@out) {
900                  return @out;                  return @out;
901          } else {          } else {
902                  return '';                  return '';
# Line 1017  Easy as pie, right? Line 1024  Easy as pie, right?
1024  sub lookup {  sub lookup {
1025          my ($what, $database, $input, $key, $having) = @_;          my ($what, $database, $input, $key, $having) = @_;
1026    
1027          confess "lookup needs 5 arguments: what, database, input, key, having" unless ($#_ == 4);          confess "lookup needs 5 arguments: what, database, input, key, having\n" unless ($#_ == 4);
1028    
1029          warn "# lookup ($database, $input, $key)\n";          warn "## lookup ($database, $input, $key)", $/ if ($debug > 1);
1030          return unless (defined($lookup->{$database}->{$input}->{$key}));          return unless (defined($lookup->{$database}->{$input}->{$key}));
1031    
1032          confess "lookup really need load_ds_coderef added to data_structure\n" unless ($load_ds_coderef);          confess "lookup really need load_row_coderef added to data_structure\n" unless ($load_row_coderef);
1033    
1034          my $mfns;          my $mfns;
1035          my @having = $having->();          my @having = $having->();
1036    
1037          warn "## having = ", dump( @having );          warn "## having = ", dump( @having ) if ($debug > 2);
1038    
1039          foreach my $h ( @having ) {          foreach my $h ( @having ) {
1040                  if (defined($lookup->{$database}->{$input}->{$key}->{$h})) {                  if (defined($lookup->{$database}->{$input}->{$key}->{$h})) {
1041                          warn "lookup for $database/$input/$key/$h return ",dump($lookup->{$database}->{$input}->{$key}->{$h}),"\n";                          warn "lookup for $database/$input/$key/$h return ",dump($lookup->{$database}->{$input}->{$key}->{$h}),"\n" if ($debug);
1042                          $mfns->{$_}++ foreach keys %{ $lookup->{$database}->{$input}->{$key}->{$h} };                          $mfns->{$_}++ foreach keys %{ $lookup->{$database}->{$input}->{$key}->{$h} };
1043                  }                  }
1044          }          }
# Line 1040  sub lookup { Line 1047  sub lookup {
1047    
1048          my @mfns = sort keys %$mfns;          my @mfns = sort keys %$mfns;
1049    
1050          warn "# lookup loading $database/$input/$key mfn ", join(",",@mfns)," having ",dump(@having),"\n";          warn "# lookup loading $database/$input/$key mfn ", join(",",@mfns)," having ",dump(@having),"\n" if ($debug);
1051    
1052          my $old_rec = $rec;          my $old_rec = $rec;
1053          my @out;          my @out;
1054    
1055          foreach my $mfn (@mfns) {          foreach my $mfn (@mfns) {
1056                  $rec = $load_ds_coderef->( $database, $input, $mfn );                  $rec = $load_row_coderef->( $database, $input, $mfn );
1057    
1058                  warn "got $database/$input/$mfn = ", dump($rec), $/;                  warn "got $database/$input/$mfn = ", dump($rec), $/ if ($debug);
1059    
1060                  my @vals = $what->();                  my @vals = $what->();
1061    
1062                  push @out, ( @vals );                  push @out, ( @vals );
1063    
1064                  warn "lookup for mfn $mfn returned ", dump(@vals), $/;                  warn "lookup for mfn $mfn returned ", dump(@vals), $/ if ($debug);
1065          }          }
1066    
1067  #       if (ref($lookup->{$k}) eq 'ARRAY') {  #       if (ref($lookup->{$k}) eq 'ARRAY') {
# Line 1065  sub lookup { Line 1072  sub lookup {
1072    
1073          $rec = $old_rec;          $rec = $old_rec;
1074    
1075          warn "## lookup returns = ", dump(@out), $/;          warn "## lookup returns = ", dump(@out), $/ if ($debug);
1076    
1077          return @out;          if ($#out == 0) {
1078                    return $out[0];
1079            } else {
1080                    return @out;
1081            }
1082  }  }
1083    
1084  =head2 save_into_lookup  =head2 save_into_lookup
# Line 1097  sub save_into_lookup { Line 1108  sub save_into_lookup {
1108          die "save_into_lookup needs key" unless defined($key);          die "save_into_lookup needs key" unless defined($key);
1109          die "save_into_lookup needs CODE" unless ( defined($coderef) && ref($coderef) eq 'CODE' );          die "save_into_lookup needs CODE" unless ( defined($coderef) && ref($coderef) eq 'CODE' );
1110    
1111  warn "## save_into_lookup rec = ", dump($rec), " config = ", dump($config),"\n";          warn "## save_into_lookup rec = ", dump($rec), " config = ", dump($config), $/ if ($debug > 2);
1112    
1113          my $mfn =          my $mfn =
1114                  defined($rec->{'000'}->[0])     ?       $rec->{'000'}->[0]      :                  defined($rec->{'000'}->[0])     ?       $rec->{'000'}->[0]      :
# Line 1239  sub split_rec_on { Line 1250  sub split_rec_on {
1250          }          }
1251  }  }
1252    
1253    my $hash;
1254    
1255    =head2 set
1256    
1257      set( key => 'value' );
1258    
1259    =cut
1260    
1261    sub set {
1262            my ($k,$v) = @_;
1263            warn "## set ( $k => ", dump($v), " )", $/;
1264            $hash->{$k} = $v;
1265    };
1266    
1267    =head2 get
1268    
1269      get( 'key' );
1270    
1271    =cut
1272    
1273    sub get {
1274            my $k = shift || return;
1275            my $v = $hash->{$k};
1276            warn "## get $k = ", dump( $v ), $/;
1277            return $v;
1278    }
1279    
1280    
1281  # END  # END
1282  1;  1;

Legend:
Removed from v.725  
changed lines
  Added in v.785

  ViewVC Help
Powered by ViewVC 1.1.26