/[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 721 by dpavlin, Fri Sep 29 12:27:47 2006 UTC revision 990 by dpavlin, Sun Nov 4 13:27:12 2007 UTC
# Line 1  Line 1 
1  package WebPAC::Normalize;  package WebPAC::Normalize;
2  use Exporter 'import';  use Exporter 'import';
3  @EXPORT = qw/  our @EXPORT = qw/
4          _set_rec _set_lookup          _set_ds _set_lookup
5            _set_load_row
6          _get_ds _clean_ds          _get_ds _clean_ds
7          _debug          _debug
8          _pack_subfields_hash          _pack_subfields_hash
9    
10          tag search display          search_display search display sorted
11    
12          marc marc_indicators marc_repeatable_subfield          marc marc_indicators marc_repeatable_subfield
13          marc_compose marc_leader          marc_compose marc_leader marc_fixed
14          marc_duplicate marc_remove          marc_duplicate marc_remove marc_count
15          marc_original_order          marc_original_order
16    
17          rec1 rec2 rec          rec1 rec2 rec
18            frec
19          regex prefix suffix surround          regex prefix suffix surround
20          first lookup join_with          first lookup join_with
21          save_into_lookup          save_into_lookup
22    
23          split_rec_on          split_rec_on
24    
25            get set
26            count
27    
28  /;  /;
29    
30  use warnings;  use warnings;
# Line 26  use strict; Line 33  use strict;
33  #use base qw/WebPAC::Common/;  #use base qw/WebPAC::Common/;
34  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
35  use Storable qw/dclone/;  use Storable qw/dclone/;
36    use Carp qw/confess/;
37    
38  # debugging warn(s)  # debugging warn(s)
39  my $debug = 0;  my $debug = 0;
40    
41    use WebPAC::Normalize::ISBN;
42    push @EXPORT, ( 'isbn_10', 'isbn_13' );
43    
44  =head1 NAME  =head1 NAME
45    
46  WebPAC::Normalize - describe normalisaton rules using sets  WebPAC::Normalize - describe normalisaton rules using sets
47    
 =head1 VERSION  
   
 Version 0.20  
   
48  =cut  =cut
49    
50  our $VERSION = '0.20';  our $VERSION = '0.32';
51    
52  =head1 SYNOPSIS  =head1 SYNOPSIS
53    
# Line 54  means that you check it's validity befor Line 60  means that you check it's validity befor
60  C<perl -c normalize.pl>.  C<perl -c normalize.pl>.
61    
62  Normalisation can generate multiple output normalized data. For now, supported output  Normalisation can generate multiple output normalized data. For now, supported output
63  types (on the left side of definition) are: C<tag>, C<display>, C<search> and  types (on the left side of definition) are: C<search_display>, C<display>, C<search> and
64  C<marc>.  C<marc>.
65    
66  =head1 FUNCTIONS  =head1 FUNCTIONS
# Line 67  All other functions are available for us Line 73  All other functions are available for us
73  Return data structure  Return data structure
74    
75    my $ds = WebPAC::Normalize::data_structure(    my $ds = WebPAC::Normalize::data_structure(
76          lookup => $lookup_variable,          lookup => $lookup_hash,
77          row => $row,          row => $row,
78          rules => $normalize_pl_config,          rules => $normalize_pl_config,
79          marc_encoding => 'utf-8',          marc_encoding => 'utf-8',
80          config => $config,          config => $config,
81            load_row_coderef => sub {
82                    my ($database,$input,$mfn) = @_;
83                    $store->load_row( database => $database, input => $input, id => $mfn );
84            },
85    );    );
86    
87  Options C<row>, C<rules> and C<log> are mandatory while all  Options C<row>, C<rules> and C<log> are mandatory while all
88  other are optional.  other are optional.
89    
90    C<load_row_coderef> is closure only used when executing lookups, so they will
91    die if it's not defined.
92    
93  This function will B<die> if normalizastion can't be evaled.  This function will B<die> if normalizastion can't be evaled.
94    
95  Since this function isn't exported you have to call it with  Since this function isn't exported you have to call it with
# Line 84  C<WebPAC::Normalize::data_structure>. Line 97  C<WebPAC::Normalize::data_structure>.
97    
98  =cut  =cut
99    
100    my $load_row_coderef;
101    
102  sub data_structure {  sub data_structure {
103          my $arg = {@_};          my $arg = {@_};
104    
# Line 91  sub data_structure { Line 106  sub data_structure {
106          die "need normalisation argument" unless ($arg->{rules});          die "need normalisation argument" unless ($arg->{rules});
107    
108          no strict 'subs';          no strict 'subs';
109          _set_lookup( $arg->{lookup} ) if (defined( $arg->{lookup} ));          _set_lookup( $arg->{lookup} ) if defined($arg->{lookup});
110          _set_rec( $arg->{row} );          _set_ds( $arg->{row} );
111          _set_config( $arg->{config} ) if (defined( $arg->{config} ));          _set_config( $arg->{config} ) if defined($arg->{config});
112          _clean_ds( %{ $arg } );          _clean_ds( %{ $arg } );
113            $load_row_coderef = $arg->{load_row_coderef};
114    
115          eval "$arg->{rules}";          eval "$arg->{rules}";
116          die "error evaling $arg->{rules}: $@\n" if ($@);          die "error evaling $arg->{rules}: $@\n" if ($@);
117    
118          return _get_ds();          return _get_ds();
119  }  }
120    
121  =head2 _set_rec  =head2 _set_ds
122    
123  Set current record hash  Set current record hash
124    
125    _set_rec( $rec );    _set_ds( $rec );
126    
127  =cut  =cut
128    
129  my $rec;  my $rec;
130    
131  sub _set_rec {  sub _set_ds {
132          $rec = shift or die "no record hash";          $rec = shift or die "no record hash";
133  }  }
134    
# Line 151  Return hash formatted as data structure Line 168  Return hash formatted as data structure
168    
169  =cut  =cut
170    
171  my ($out, $marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators);  my ($out, $marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators, $marc_leader);
172  my ($marc_record_offset, $marc_fetch_offset) = (0, 0);  my ($marc_record_offset, $marc_fetch_offset) = (0, 0);
173    
174  sub _get_ds {  sub _get_ds {
175    #warn "## out = ",dump($out);
176          return $out;          return $out;
177  }  }
178    
# Line 168  Clean data structure hash for next recor Line 186  Clean data structure hash for next recor
186    
187  sub _clean_ds {  sub _clean_ds {
188          my $a = {@_};          my $a = {@_};
189          ($out,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators) = ();          ($out,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators, $marc_leader) = ();
190          ($marc_record_offset, $marc_fetch_offset) = (0,0);          ($marc_record_offset, $marc_fetch_offset) = (0,0);
191          $marc_encoding = $a->{marc_encoding};          $marc_encoding = $a->{marc_encoding};
192  }  }
# Line 199  sub _get_lookup { Line 217  sub _get_lookup {
217          return $lookup;          return $lookup;
218  }  }
219    
220    =head2 _set_load_row
221    
222    Setup code reference which will return L<data_structure> from
223    L<WebPAC::Store>
224    
225      _set_load_row(sub {
226                    my ($database,$input,$mfn) = @_;
227                    $store->load_row( database => $database, input => $input, id => $mfn );
228      });
229    
230    =cut
231    
232    sub _set_load_row {
233            my $coderef = shift;
234            confess "argument isn't CODE" unless ref($coderef) eq 'CODE';
235    
236            $load_row_coderef = $coderef;
237    }
238    
239  =head2 _get_marc_fields  =head2 _get_marc_fields
240    
241  Get all fields defined by calls to C<marc>  Get all fields defined by calls to C<marc>
# Line 254  will return 42th copy record (if it exis Line 291  will return 42th copy record (if it exis
291    
292  =cut  =cut
293    
294    my $fetch_pos;
295    
296  sub _get_marc_fields {  sub _get_marc_fields {
297    
298          my $arg = {@_};          my $arg = {@_};
299          warn "### _get_marc_fields arg: ", dump($arg), $/ if ($debug > 2);          warn "### _get_marc_fields arg: ", dump($arg), $/ if ($debug > 2);
300          my $offset = $marc_fetch_offset;          $fetch_pos = $marc_fetch_offset;
301          if ($arg->{offset}) {          if ($arg->{offset}) {
302                  $offset = $arg->{offset};                  $fetch_pos = $arg->{offset};
303          } elsif($arg->{fetch_next}) {          } elsif($arg->{fetch_next}) {
304                  $marc_fetch_offset++;                  $marc_fetch_offset++;
305          }          }
# Line 269  sub _get_marc_fields { Line 308  sub _get_marc_fields {
308    
309          warn "### full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 2);          warn "### full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 2);
310    
311          my $marc_rec = $marc_record->[ $offset ];          my $marc_rec = $marc_record->[ $fetch_pos ];
312    
313          warn "## _get_marc_fields (at offset: $offset) -- marc_record = ", dump( @$marc_rec ), $/ if ($debug > 1);          warn "## _get_marc_fields (at offset: $fetch_pos) -- marc_record = ", dump( @$marc_rec ), $/ if ($debug > 1);
314    
315          return if (! $marc_rec || ref($marc_rec) ne 'ARRAY' || $#{ $marc_rec } < 0);          return if (! $marc_rec || ref($marc_rec) ne 'ARRAY' || $#{ $marc_rec } < 0);
316    
# Line 292  sub _get_marc_fields { Line 331  sub _get_marc_fields {
331    
332          if ($debug) {          if ($debug) {
333                  warn "## marc_repeatable_subfield = ", dump( $marc_repeatable_subfield ), $/ if ( $marc_repeatable_subfield );                  warn "## marc_repeatable_subfield = ", dump( $marc_repeatable_subfield ), $/ if ( $marc_repeatable_subfield );
334                  warn "## marc_record[$offset] = ", dump( $marc_rec ), $/;                  warn "## marc_record[$fetch_pos] = ", dump( $marc_rec ), $/;
335                  warn "## sorted_marc_record = ", dump( \@sorted_marc_record ), $/;                  warn "## sorted_marc_record = ", dump( \@sorted_marc_record ), $/;
336                  warn "## subfield count = ", dump( $u ), $/;                  warn "## subfield count = ", dump( $u ), $/;
337          }          }
# Line 373  sub _get_marc_fields { Line 412  sub _get_marc_fields {
412          return \@m;          return \@m;
413  }  }
414    
415    =head2 _get_marc_leader
416    
417    Return leader from currently fetched record by L</_get_marc_fields>
418    
419      print WebPAC::Normalize::_get_marc_leader();
420    
421    =cut
422    
423    sub _get_marc_leader {
424            die "no fetch_pos, did you called _get_marc_fields first?" unless ( defined( $fetch_pos ) );
425            return $marc_leader->[ $fetch_pos ];
426    }
427    
428  =head2 _debug  =head2 _debug
429    
430  Change level of debug warnings  Change level of debug warnings
# Line 392  sub _debug { Line 444  sub _debug {
444    
445  Those functions generally have to first in your normalization file.  Those functions generally have to first in your normalization file.
446    
447  =head2 tag  =head2 search_display
448    
449  Define new tag for I<search> and I<display>.  Define output for L<search> and L<display> at the same time
450    
451    tag('Title', rec('200','a') );    search_display('Title', rec('200','a') );
452    
453    
454  =cut  =cut
455    
456  sub tag {  sub search_display {
457          my $name = shift or die "tag needs name as first argument";          my $name = shift or die "search_display needs name as first argument";
458          my @o = grep { defined($_) && $_ ne '' } @_;          my @o = grep { defined($_) && $_ ne '' } @_;
459          return unless (@o);          return unless (@o);
         $out->{$name}->{tag} = $name;  
460          $out->{$name}->{search} = \@o;          $out->{$name}->{search} = \@o;
461          $out->{$name}->{display} = \@o;          $out->{$name}->{display} = \@o;
462  }  }
463    
464    =head2 tag
465    
466    Old name for L<search_display>, but supported
467    
468    =cut
469    
470    sub tag {
471            search_display( @_ );
472    }
473    
474  =head2 display  =head2 display
475    
476  Define tag just for I<display>  Define output just for I<display>
477    
478    @v = display('Title', rec('200','a') );    @v = display('Title', rec('200','a') );
479    
480  =cut  =cut
481    
482  sub display {  sub _field {
483          my $name = shift or die "display needs name as first argument";          my $type = shift or confess "need type -- BUG?";
484            my $name = shift or confess "needs name as first argument";
485          my @o = grep { defined($_) && $_ ne '' } @_;          my @o = grep { defined($_) && $_ ne '' } @_;
486          return unless (@o);          return unless (@o);
487          $out->{$name}->{tag} = $name;          $out->{$name}->{$type} = \@o;
         $out->{$name}->{display} = \@o;  
488  }  }
489    
490    sub display { _field( 'display', @_ ) }
491    
492  =head2 search  =head2 search
493    
494  Prepare values just for I<search>  Prepare values just for I<search>
# Line 434  Prepare values just for I<search> Line 497  Prepare values just for I<search>
497    
498  =cut  =cut
499    
500  sub search {  sub search { _field( 'search', @_ ) }
501          my $name = shift or die "search needs name as first argument";  
502          my @o = grep { defined($_) && $_ ne '' } @_;  =head2 sorted
503          return unless (@o);  
504          $out->{$name}->{tag} = $name;  Insert into lists which will be automatically sorted
505          $out->{$name}->{search} = \@o;  
506  }   sorted('Title', rec('200','a') );
507    
508    =cut
509    
510    sub sorted { _field( 'sorted', @_ ) }
511    
512    
513  =head2 marc_leader  =head2 marc_leader
514    
# Line 455  sub marc_leader { Line 523  sub marc_leader {
523          my ($offset,$value) = @_;          my ($offset,$value) = @_;
524    
525          if ($offset) {          if ($offset) {
526                  $out->{' leader'}->{ $offset } = $value;                  $marc_leader->[ $marc_record_offset ]->{ $offset } = $value;
527          } else {          } else {
528                  return $out->{' leader'};                  
529                    if (defined($marc_leader)) {
530                            die "marc_leader not array = ", dump( $marc_leader ) unless (ref($marc_leader) eq 'ARRAY');
531                            return $marc_leader->[ $marc_record_offset ];
532                    } else {
533                            return;
534                    }
535            }
536    }
537    
538    =head2 marc_fixed
539    
540    Create control/indentifier fields with values in fixed positions
541    
542      marc_fixed('008', 00, '070402');
543      marc_fixed('008', 39, '|');
544    
545    Positions not specified will be filled with spaces (C<0x20>).
546    
547    There will be no effort to extend last specified value to full length of
548    field in standard.
549    
550    =cut
551    
552    sub marc_fixed {
553            my ($f, $pos, $val) = @_;
554            die "need marc(field, position, value)" unless defined($f) && defined($pos);
555    
556            confess "need val" unless defined $val;
557    
558            my $update = 0;
559    
560            map {
561                    if ($_->[0] eq $f) {
562                            my $old = $_->[1];
563                            if (length($old) <= $pos) {
564                                    $_->[1] .= ' ' x ( $pos - length($old) ) . $val;
565                                    warn "## marc_fixed($f,$pos,'$val') append '$old' -> '$_->[1]'\n" if ($debug > 1);
566                            } else {
567                                    $_->[1] = substr($old, 0, $pos) . $val . substr($old, $pos + length($val));
568                                    warn "## marc_fixed($f,$pos,'$val') update '$old' -> '$_->[1]'\n" if ($debug > 1);
569                            }
570                            $update++;
571                    }
572            } @{ $marc_record->[ $marc_record_offset ] };
573    
574            if (! $update) {
575                    my $v = ' ' x $pos . $val;
576                    push @{ $marc_record->[ $marc_record_offset ] }, [ $f, $v ];
577                    warn "## marc_fixed($f,$pos,'val') created '$v'\n" if ($debug > 1);
578          }          }
579  }  }
580    
# Line 589  sub marc_duplicate { Line 706  sub marc_duplicate {
706           my $m = $marc_record->[ -1 ];           my $m = $marc_record->[ -1 ];
707           die "can't duplicate record which isn't defined" unless ($m);           die "can't duplicate record which isn't defined" unless ($m);
708           push @{ $marc_record }, dclone( $m );           push @{ $marc_record }, dclone( $m );
709           warn "## marc_duplicate = ", dump(@$marc_record), $/ if ($debug > 1);           push @{ $marc_leader }, dclone( marc_leader() );
710             warn "## marc_duplicate = ", dump(@$marc_leader, @$marc_record), $/ if ($debug > 1);
711           $marc_record_offset = $#{ $marc_record };           $marc_record_offset = $#{ $marc_record };
712           warn "## marc_record_offset = $marc_record_offset", $/ if ($debug > 1);           warn "## marc_record_offset = $marc_record_offset", $/ if ($debug > 1);
713    
714  }  }
715    
716  =head2 marc_remove  =head2 marc_remove
# Line 603  Remove some field or subfield from MARC Line 722  Remove some field or subfield from MARC
722    
723  This will erase field C<200> or C<200^a> from current MARC record.  This will erase field C<200> or C<200^a> from current MARC record.
724    
725      marc_remove('*');
726    
727    Will remove all fields in current MARC record.
728    
729  This is useful after calling C<marc_duplicate> or on it's own (but, you  This is useful after calling C<marc_duplicate> or on it's own (but, you
730  should probably just remove that subfield definition if you are not  should probably just remove that subfield definition if you are not
731  using C<marc_duplicate>).  using C<marc_duplicate>).
# Line 620  sub marc_remove { Line 743  sub marc_remove {
743    
744          warn "### marc_remove before = ", dump( $marc ), $/ if ($debug > 2);          warn "### marc_remove before = ", dump( $marc ), $/ if ($debug > 2);
745    
746          my $i = 0;          if ($f eq '*') {
747          foreach ( 0 .. $#{ $marc } ) {  
748                  last unless (defined $marc->[$i]);                  delete( $marc_record->[ $marc_record_offset ] );
749                  warn "#### working on ",dump( @{ $marc->[$i] }), $/ if ($debug > 3);                  warn "## full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 1);
750                  if ($marc->[$i]->[0] eq $f) {  
751                          if (! defined $sf) {          } else {
752                                  # remove whole field  
753                                  splice @$marc, $i, 1;                  my $i = 0;
754                                  warn "#### slice \@\$marc, $i, 1 = ",dump( @{ $marc }), $/ if ($debug > 3);                  foreach ( 0 .. $#{ $marc } ) {
755                                  $i--;                          last unless (defined $marc->[$i]);
756                          } else {                          warn "#### working on ",dump( @{ $marc->[$i] }), $/ if ($debug > 3);
757                                  foreach my $j ( 0 .. (( $#{ $marc->[$i] } - 3 ) / 2) ) {                          if ($marc->[$i]->[0] eq $f) {
758                                          my $o = ($j * 2) + 3;                                  if (! defined $sf) {
759                                          if ($marc->[$i]->[$o] eq $sf) {                                          # remove whole field
760                                                  # remove subfield                                          splice @$marc, $i, 1;
761                                                  splice @{$marc->[$i]}, $o, 2;                                          warn "#### slice \@\$marc, $i, 1 = ",dump( @{ $marc }), $/ if ($debug > 3);
762                                                  warn "#### slice \@{\$marc->[$i]}, $o, 2 = ", dump( @{ $marc }), $/ if ($debug > 3);                                          $i--;
763                                                  # is record now empty?                                  } else {
764                                                  if ($#{ $marc->[$i] } == 2) {                                          foreach my $j ( 0 .. (( $#{ $marc->[$i] } - 3 ) / 2) ) {
765                                                          splice @$marc, $i, 1;                                                  my $o = ($j * 2) + 3;
766                                                          warn "#### slice \@\$marc, $i, 1 = ", dump( @{ $marc }), $/ if ($debug > 3);                                                  if ($marc->[$i]->[$o] eq $sf) {
767                                                          $i--;                                                          # remove subfield
768                                                  };                                                          splice @{$marc->[$i]}, $o, 2;
769                                                            warn "#### slice \@{\$marc->[$i]}, $o, 2 = ", dump( @{ $marc }), $/ if ($debug > 3);
770                                                            # is record now empty?
771                                                            if ($#{ $marc->[$i] } == 2) {
772                                                                    splice @$marc, $i, 1;
773                                                                    warn "#### slice \@\$marc, $i, 1 = ", dump( @{ $marc }), $/ if ($debug > 3);
774                                                                    $i--;
775                                                            };
776                                                    }
777                                          }                                          }
778                                  }                                  }
779                          }                          }
780                            $i++;
781                  }                  }
                 $i++;  
         }  
782    
783          warn "### marc_remove($f", $sf ? ",$sf" : "", ") after = ", dump( $marc ), $/ if ($debug > 2);                  warn "### marc_remove($f", $sf ? ",$sf" : "", ") after = ", dump( $marc ), $/ if ($debug > 2);
784    
785          $marc_record->[ $marc_record_offset ] = $marc;                  $marc_record->[ $marc_record_offset ] = $marc;
786            }
787    
788          warn "## full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 1);          warn "## full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 1);
789  }  }
# Line 727  sub marc_original_order { Line 858  sub marc_original_order {
858          warn "## marc_record = ", dump( $marc_record ),$/ if ($debug > 1);          warn "## marc_record = ", dump( $marc_record ),$/ if ($debug > 1);
859  }  }
860    
861    =head2 marc_count
862    
863    Return number of MARC records created using L</marc_duplicate>.
864    
865      print "created ", marc_count(), " records";
866    
867    =cut
868    
869    sub marc_count {
870            return $#{ $marc_record };
871    }
872    
873    
874  =head1 Functions to extract data from input  =head1 Functions to extract data from input
875    
# Line 749  sub _pack_subfields_hash { Line 892  sub _pack_subfields_hash {
892    
893          my ($h,$include_subfields) = @_;          my ($h,$include_subfields) = @_;
894    
895            # sanity and ease of use
896            return $h if (ref($h) ne 'HASH');
897    
898          if ( defined($h->{subfields}) ) {          if ( defined($h->{subfields}) ) {
899                  my $sfs = delete $h->{subfields} || die "no subfields?";                  my $sfs = delete $h->{subfields} || die "no subfields?";
900                  my @out;                  my @out;
# Line 848  syntaxtic sugar for Line 994  syntaxtic sugar for
994    @v = rec('200')    @v = rec('200')
995    @v = rec('200','a')    @v = rec('200','a')
996    
997    If rec() returns just single value, it will
998    return scalar, not array.
999    
1000  =cut  =cut
1001    
1002    sub frec {
1003            my @out = rec(@_);
1004            warn "rec(",dump(@_),") has more than one return value, ignoring\n" if $#out > 0;
1005            return shift @out;
1006    }
1007    
1008  sub rec {  sub rec {
1009          my @out;          my @out;
1010          if ($#_ == 0) {          if ($#_ == 0) {
# Line 857  sub rec { Line 1012  sub rec {
1012          } elsif ($#_ == 1) {          } elsif ($#_ == 1) {
1013                  @out = rec2(@_);                  @out = rec2(@_);
1014          }          }
1015          if (@out) {          if ($#out == 0 && ! wantarray) {
1016                    return $out[0];
1017            } elsif (@out) {
1018                  return @out;                  return @out;
1019          } else {          } else {
1020                  return '';                  return '';
# Line 893  Prefix all values with a string Line 1050  Prefix all values with a string
1050  =cut  =cut
1051    
1052  sub prefix {  sub prefix {
1053          my $p = shift or return;          my $p = shift;
1054            return @_ unless defined( $p );
1055          return map { $p . $_ } grep { defined($_) } @_;          return map { $p . $_ } grep { defined($_) } @_;
1056  }  }
1057    
# Line 906  suffix all values with a string Line 1064  suffix all values with a string
1064  =cut  =cut
1065    
1066  sub suffix {  sub suffix {
1067          my $s = shift or die "suffix needs string as first argument";          my $s = shift;
1068            return @_ unless defined( $s );
1069          return map { $_ . $s } grep { defined($_) } @_;          return map { $_ . $s } grep { defined($_) } @_;
1070  }  }
1071    
# Line 919  surround all values with a two strings Line 1078  surround all values with a two strings
1078  =cut  =cut
1079    
1080  sub surround {  sub surround {
1081          my $p = shift or die "surround need prefix as first argument";          my $p = shift;
1082          my $s = shift or die "surround needs suffix as second argument";          my $s = shift;
1083            $p = '' unless defined( $p );
1084            $s = '' unless defined( $s );
1085          return map { $p . $_ . $s } grep { defined($_) } @_;          return map { $p . $_ . $s } grep { defined($_) } @_;
1086  }  }
1087    
# Line 941  sub first { Line 1102  sub first {
1102    
1103  Consult lookup hashes for some value  Consult lookup hashes for some value
1104    
1105    @v = lookup( $v );    @v = lookup(
1106    @v = lookup( @v );          sub {
1107                    'ffkk/peri/mfn'.rec('000')
1108            },
1109            'ffkk','peri','200-a-200-e',
1110            sub {
1111                    first(rec(200,'a')).' '.first(rec('200','e'))
1112            }
1113      );
1114    
1115    Code like above will be B<automatically generated> using L<WebPAC::Parse> from
1116    normal lookup definition in C<conf/lookup/something.pl> which looks like:
1117    
1118      lookup(
1119            # which results to return from record recorded in lookup
1120            sub { 'ffkk/peri/mfn' . rec('000') },
1121            # from which database and input
1122            'ffkk','peri',
1123            # such that following values match
1124            sub { first(rec(200,'a')) . ' ' . first(rec('200','e')) },
1125            # if this part is missing, we will try to match same fields
1126            # from lookup record and current one, or you can override
1127            # which records to use from current record using
1128            sub { rec('900','x') . ' ' . rec('900','y') },
1129      )
1130    
1131    You can think about this lookup as SQL (if that helps):
1132    
1133      select
1134            sub { what }
1135      from
1136            database, input
1137      where
1138        sub { filter from lookuped record }
1139      having
1140        sub { optional filter on current record }
1141    
1142  FIXME B<currently this one is broken!>  Easy as pie, right?
1143    
1144  =cut  =cut
1145    
1146  sub lookup {  sub lookup {
1147          my $k = shift or return;          my ($what, $database, $input, $key, $having) = @_;
1148          return unless (defined($lookup->{$k}));  
1149          if (ref($lookup->{$k}) eq 'ARRAY') {          confess "lookup needs 5 arguments: what, database, input, key, having\n" unless ($#_ == 4);
1150                  return @{ $lookup->{$k} };  
1151            warn "## lookup ($database, $input, $key)", $/ if ($debug > 1);
1152            return unless (defined($lookup->{$database}->{$input}->{$key}));
1153    
1154            confess "lookup really need load_row_coderef added to data_structure\n" unless ($load_row_coderef);
1155    
1156            my $mfns;
1157            my @having = $having->();
1158    
1159            warn "## having = ", dump( @having ) if ($debug > 2);
1160    
1161            foreach my $h ( @having ) {
1162                    if (defined($lookup->{$database}->{$input}->{$key}->{$h})) {
1163                            warn "lookup for $database/$input/$key/$h return ",dump($lookup->{$database}->{$input}->{$key}->{$h}),"\n" if ($debug);
1164                            $mfns->{$_}++ foreach keys %{ $lookup->{$database}->{$input}->{$key}->{$h} };
1165                    }
1166            }
1167    
1168            return unless ($mfns);
1169    
1170            my @mfns = sort keys %$mfns;
1171    
1172            warn "# lookup loading $database/$input/$key mfn ", join(",",@mfns)," having ",dump(@having),"\n" if ($debug);
1173    
1174            my $old_rec = $rec;
1175            my @out;
1176    
1177            foreach my $mfn (@mfns) {
1178                    $rec = $load_row_coderef->( $database, $input, $mfn );
1179    
1180                    warn "got $database/$input/$mfn = ", dump($rec), $/ if ($debug);
1181    
1182                    my @vals = $what->();
1183    
1184                    push @out, ( @vals );
1185    
1186                    warn "lookup for mfn $mfn returned ", dump(@vals), $/ if ($debug);
1187            }
1188    
1189    #       if (ref($lookup->{$k}) eq 'ARRAY') {
1190    #               return @{ $lookup->{$k} };
1191    #       } else {
1192    #               return $lookup->{$k};
1193    #       }
1194    
1195            $rec = $old_rec;
1196    
1197            warn "## lookup returns = ", dump(@out), $/ if ($debug);
1198    
1199            if ($#out == 0) {
1200                    return $out[0];
1201          } else {          } else {
1202                  return $lookup->{$k};                  return @out;
1203          }          }
1204  }  }
1205    
1206  =head2 save_into_lookup  =head2 save_into_lookup
1207    
1208  Save value into lookup.  Save value into lookup. It associates current database, input
1209    and specific keys with one or more values which will be
1210    associated over MFN.
1211    
1212    save_into_lookup($database,$input,$key,sub {  MFN will be extracted from first occurence current of field 000
1213    in current record, or if it doesn't exist from L<_set_config> C<_mfn>.
1214    
1215      my $nr = save_into_lookup($database,$input,$key,sub {
1216          # code which produce one or more values          # code which produce one or more values
1217    });    });
1218    
1219  This function shouldn't be called directly, it's called from code created by L<WebPAC::Parser>.  It returns number of items saved.
1220    
1221    This function shouldn't be called directly, it's called from code created by
1222    L<WebPAC::Parser>.
1223    
1224  =cut  =cut
1225    
# Line 976  sub save_into_lookup { Line 1229  sub save_into_lookup {
1229          die "save_into_lookup needs input" unless defined($input);          die "save_into_lookup needs input" unless defined($input);
1230          die "save_into_lookup needs key" unless defined($key);          die "save_into_lookup needs key" unless defined($key);
1231          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' );
1232          my $mfn = $rec->{'000'}->[0] || die "mfn not defined or zero";  
1233            warn "## save_into_lookup rec = ", dump($rec), " config = ", dump($config), $/ if ($debug > 2);
1234    
1235            my $mfn =
1236                    defined($rec->{'000'}->[0])     ?       $rec->{'000'}->[0]      :
1237                    defined($config->{_mfn})        ?       $config->{_mfn}         :
1238                                                                                    die "mfn not defined or zero";
1239    
1240            my $nr = 0;
1241    
1242          foreach my $v ( $coderef->() ) {          foreach my $v ( $coderef->() ) {
1243                  $lookup->{$database}->{$input}->{$key}->{$v}->{$mfn}++;                  $lookup->{$database}->{$input}->{$key}->{$v}->{$mfn}++;
1244                  warn "# saved lookup $database/$input/$key [$v] $mfn\n" if ($debug > 1);                  warn "# saved lookup $database/$input/$key [$v] $mfn\n" if ($debug > 1);
1245                    $nr++;
1246          }          }
1247    
1248            return $nr;
1249  }  }
1250    
1251  =head2 config  =head2 config
# Line 991  Consult config values stored in C<config Line 1256  Consult config values stored in C<config
1256    $database_code = config();    # use _ from hash    $database_code = config();    # use _ from hash
1257    $database_name = config('name');    $database_name = config('name');
1258    $database_input_name = config('input name');    $database_input_name = config('input name');
   $tag = config('input normalize tag');  
1259    
1260  Up to three levels are supported.  Up to three levels are supported.
1261    
# Line 1107  sub split_rec_on { Line 1371  sub split_rec_on {
1371          }          }
1372  }  }
1373    
1374    my $hash;
1375    
1376    =head2 set
1377    
1378      set( key => 'value' );
1379    
1380    =cut
1381    
1382    sub set {
1383            my ($k,$v) = @_;
1384            warn "## set ( $k => ", dump($v), " )", $/ if ( $debug );
1385            $hash->{$k} = $v;
1386    };
1387    
1388    =head2 get
1389    
1390      get( 'key' );
1391    
1392    =cut
1393    
1394    sub get {
1395            my $k = shift || return;
1396            my $v = $hash->{$k};
1397            warn "## get $k = ", dump( $v ), $/ if ( $debug );
1398            return $v;
1399    }
1400    
1401    =head2 count
1402    
1403      if ( count( @result ) == 1 ) {
1404            # do something if only 1 result is there
1405      }
1406    
1407    =cut
1408    
1409    sub count {
1410            warn "## count ",dump(@_),$/ if ( $debug );
1411            return @_ . '';
1412    }
1413    
1414  # END  # END
1415  1;  1;

Legend:
Removed from v.721  
changed lines
  Added in v.990

  ViewVC Help
Powered by ViewVC 1.1.26