/[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 616 by dpavlin, Wed Aug 23 14:29:43 2006 UTC revision 915 by dpavlin, Tue Oct 30 20:27:20 2007 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_row
6          _get_ds _clean_ds          _get_ds _clean_ds
7          _debug          _debug
8            _pack_subfields_hash
9    
10            search_display search display
11    
         tag search display  
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          regex prefix suffix surround          regex prefix suffix surround
19          first lookup join_with          first lookup join_with
20            save_into_lookup
21    
22          split_rec_on          split_rec_on
23    
24            get set
25            count
26  /;  /;
27    
28  use warnings;  use warnings;
# Line 23  use strict; Line 30  use strict;
30    
31  #use base qw/WebPAC::Common/;  #use base qw/WebPAC::Common/;
32  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
 use Encode qw/from_to/;  
33  use Storable qw/dclone/;  use Storable qw/dclone/;
34    use Carp qw/confess/;
35    
36  # debugging warn(s)  # debugging warn(s)
37  my $debug = 0;  my $debug = 0;
# Line 36  WebPAC::Normalize - describe normalisato Line 43  WebPAC::Normalize - describe normalisato
43    
44  =head1 VERSION  =head1 VERSION
45    
46  Version 0.16  Version 0.30
47    
48  =cut  =cut
49    
50  our $VERSION = '0.16';  our $VERSION = '0.30';
51    
52  =head1 SYNOPSIS  =head1 SYNOPSIS
53    
# Line 53  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 66  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->lookup_hash,          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) = shift;
83                    $store->load_row( database => $database, input => $input, id => $mfn );
84            },
85    );    );
86    
87  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
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 83  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 90  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} );          _set_lookup( $arg->{lookup} ) if defined($arg->{lookup});
110          _set_rec( $arg->{row} );          _set_rec( $arg->{row} );
111          _set_config( $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    
# Line 150  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 {
# Line 167  Clean data structure hash for next recor Line 185  Clean data structure hash for next recor
185    
186  sub _clean_ds {  sub _clean_ds {
187          my $a = {@_};          my $a = {@_};
188          ($out,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators) = ();          ($out,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators, $marc_leader) = ();
189          ($marc_record_offset, $marc_fetch_offset) = (0,0);          ($marc_record_offset, $marc_fetch_offset) = (0,0);
190          $marc_encoding = $a->{marc_encoding};          $marc_encoding = $a->{marc_encoding};
191  }  }
# Line 186  sub _set_lookup { Line 204  sub _set_lookup {
204          $lookup = shift;          $lookup = shift;
205  }  }
206    
207    =head2 _get_lookup
208    
209    Get current lookup hash
210    
211      my $lookup = _get_lookup();
212    
213    =cut
214    
215    sub _get_lookup {
216            return $lookup;
217    }
218    
219    =head2 _set_load_row
220    
221    Setup code reference which will return L<data_structure> from
222    L<WebPAC::Store>
223    
224      _set_load_row(sub {
225                    my ($database,$input,$mfn) = @_;
226                    $store->load_row( database => $database, input => $input, id => $mfn );
227      });
228    
229    =cut
230    
231    sub _set_load_row {
232            my $coderef = shift;
233            confess "argument isn't CODE" unless ref($coderef) eq 'CODE';
234    
235            $load_row_coderef = $coderef;
236    }
237    
238  =head2 _get_marc_fields  =head2 _get_marc_fields
239    
240  Get all fields defined by calls to C<marc>  Get all fields defined by calls to C<marc>
# Line 241  will return 42th copy record (if it exis Line 290  will return 42th copy record (if it exis
290    
291  =cut  =cut
292    
293    my $fetch_pos;
294    
295  sub _get_marc_fields {  sub _get_marc_fields {
296    
297          my $arg = {@_};          my $arg = {@_};
298          warn "### _get_marc_fields arg: ", dump($arg), $/ if ($debug > 2);          warn "### _get_marc_fields arg: ", dump($arg), $/ if ($debug > 2);
299          my $offset = $marc_fetch_offset;          $fetch_pos = $marc_fetch_offset;
300          if ($arg->{offset}) {          if ($arg->{offset}) {
301                  $offset = $arg->{offset};                  $fetch_pos = $arg->{offset};
302          } elsif($arg->{fetch_next}) {          } elsif($arg->{fetch_next}) {
303                  $marc_fetch_offset++;                  $marc_fetch_offset++;
304          }          }
# Line 256  sub _get_marc_fields { Line 307  sub _get_marc_fields {
307    
308          warn "### full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 2);          warn "### full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 2);
309    
310          my $marc_rec = $marc_record->[ $offset ];          my $marc_rec = $marc_record->[ $fetch_pos ];
311    
312          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);
313    
314          return if (! $marc_rec || ref($marc_rec) ne 'ARRAY' || $#{ $marc_rec } < 0);          return if (! $marc_rec || ref($marc_rec) ne 'ARRAY' || $#{ $marc_rec } < 0);
315    
# Line 279  sub _get_marc_fields { Line 330  sub _get_marc_fields {
330    
331          if ($debug) {          if ($debug) {
332                  warn "## marc_repeatable_subfield = ", dump( $marc_repeatable_subfield ), $/ if ( $marc_repeatable_subfield );                  warn "## marc_repeatable_subfield = ", dump( $marc_repeatable_subfield ), $/ if ( $marc_repeatable_subfield );
333                  warn "## marc_record[$offset] = ", dump( $marc_rec ), $/;                  warn "## marc_record[$fetch_pos] = ", dump( $marc_rec ), $/;
334                  warn "## sorted_marc_record = ", dump( \@sorted_marc_record ), $/;                  warn "## sorted_marc_record = ", dump( \@sorted_marc_record ), $/;
335                  warn "## subfield count = ", dump( $u ), $/;                  warn "## subfield count = ", dump( $u ), $/;
336          }          }
# Line 360  sub _get_marc_fields { Line 411  sub _get_marc_fields {
411          return \@m;          return \@m;
412  }  }
413    
414    =head2 _get_marc_leader
415    
416    Return leader from currently fetched record by L</_get_marc_fields>
417    
418      print WebPAC::Normalize::_get_marc_leader();
419    
420    =cut
421    
422    sub _get_marc_leader {
423            die "no fetch_pos, did you called _get_marc_fields first?" unless ( defined( $fetch_pos ) );
424            return $marc_leader->[ $fetch_pos ];
425    }
426    
427  =head2 _debug  =head2 _debug
428    
429  Change level of debug warnings  Change level of debug warnings
# Line 379  sub _debug { Line 443  sub _debug {
443    
444  Those functions generally have to first in your normalization file.  Those functions generally have to first in your normalization file.
445    
446  =head2 tag  =head2 search_display
447    
448  Define new tag for I<search> and I<display>.  Define output for L<search> and L<display> at the same time
449    
450    tag('Title', rec('200','a') );    search_display('Title', rec('200','a') );
451    
452    
453  =cut  =cut
454    
455  sub tag {  sub search_display {
456          my $name = shift or die "tag needs name as first argument";          my $name = shift or die "search_display needs name as first argument";
457          my @o = grep { defined($_) && $_ ne '' } @_;          my @o = grep { defined($_) && $_ ne '' } @_;
458          return unless (@o);          return unless (@o);
         $out->{$name}->{tag} = $name;  
459          $out->{$name}->{search} = \@o;          $out->{$name}->{search} = \@o;
460          $out->{$name}->{display} = \@o;          $out->{$name}->{display} = \@o;
461  }  }
462    
463    =head2 tag
464    
465    Old name for L<search_display>, but supported
466    
467    =cut
468    
469    sub tag {
470            search_display( @_ );
471    }
472    
473  =head2 display  =head2 display
474    
475  Define tag just for I<display>  Define output just for I<display>
476    
477    @v = display('Title', rec('200','a') );    @v = display('Title', rec('200','a') );
478    
# Line 409  sub display { Line 482  sub display {
482          my $name = shift or die "display needs name as first argument";          my $name = shift or die "display needs name as first argument";
483          my @o = grep { defined($_) && $_ ne '' } @_;          my @o = grep { defined($_) && $_ ne '' } @_;
484          return unless (@o);          return unless (@o);
         $out->{$name}->{tag} = $name;  
485          $out->{$name}->{display} = \@o;          $out->{$name}->{display} = \@o;
486  }  }
487    
# Line 425  sub search { Line 497  sub search {
497          my $name = shift or die "search needs name as first argument";          my $name = shift or die "search needs name as first argument";
498          my @o = grep { defined($_) && $_ ne '' } @_;          my @o = grep { defined($_) && $_ ne '' } @_;
499          return unless (@o);          return unless (@o);
         $out->{$name}->{tag} = $name;  
500          $out->{$name}->{search} = \@o;          $out->{$name}->{search} = \@o;
501  }  }
502    
# Line 442  sub marc_leader { Line 513  sub marc_leader {
513          my ($offset,$value) = @_;          my ($offset,$value) = @_;
514    
515          if ($offset) {          if ($offset) {
516                  $out->{' leader'}->{ $offset } = $value;                  $marc_leader->[ $marc_record_offset ]->{ $offset } = $value;
517          } else {          } else {
518                  return $out->{' leader'};                  
519                    if (defined($marc_leader)) {
520                            die "marc_leader not array = ", dump( $marc_leader ) unless (ref($marc_leader) eq 'ARRAY');
521                            return $marc_leader->[ $marc_record_offset ];
522                    } else {
523                            return;
524                    }
525            }
526    }
527    
528    =head2 marc_fixed
529    
530    Create control/indentifier fields with values in fixed positions
531    
532      marc_fixed('008', 00, '070402');
533      marc_fixed('008', 39, '|');
534    
535    Positions not specified will be filled with spaces (C<0x20>).
536    
537    There will be no effort to extend last specified value to full length of
538    field in standard.
539    
540    =cut
541    
542    sub marc_fixed {
543            my ($f, $pos, $val) = @_;
544            die "need marc(field, position, value)" unless defined($f) && defined($pos);
545    
546            confess "need val" unless defined $val;
547    
548            my $update = 0;
549    
550            map {
551                    if ($_->[0] eq $f) {
552                            my $old = $_->[1];
553                            if (length($old) <= $pos) {
554                                    $_->[1] .= ' ' x ( $pos - length($old) ) . $val;
555                                    warn "## marc_fixed($f,$pos,'$val') append '$old' -> '$_->[1]'\n" if ($debug > 1);
556                            } else {
557                                    $_->[1] = substr($old, 0, $pos) . $val . substr($old, $pos + length($val));
558                                    warn "## marc_fixed($f,$pos,'$val') update '$old' -> '$_->[1]'\n" if ($debug > 1);
559                            }
560                            $update++;
561                    }
562            } @{ $marc_record->[ $marc_record_offset ] };
563    
564            if (! $update) {
565                    my $v = ' ' x $pos . $val;
566                    push @{ $marc_record->[ $marc_record_offset ] }, [ $f, $v ];
567                    warn "## marc_fixed($f,$pos,'val') created '$v'\n" if ($debug > 1);
568          }          }
569  }  }
570    
# Line 469  sub marc { Line 589  sub marc {
589          foreach (@_) {          foreach (@_) {
590                  my $v = $_;             # make var read-write for Encode                  my $v = $_;             # make var read-write for Encode
591                  next unless (defined($v) && $v !~ /^\s*$/);                  next unless (defined($v) && $v !~ /^\s*$/);
                 from_to($v, 'iso-8859-2', $marc_encoding) if ($marc_encoding);  
592                  my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');                  my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');
593                  if (defined $sf) {                  if (defined $sf) {
594                          push @{ $marc_record->[ $marc_record_offset ] }, [ $f, $i1, $i2, $sf => $v ];                          push @{ $marc_record->[ $marc_record_offset ] }, [ $f, $i1, $i2, $sf => $v ];
# Line 540  sub marc_compose { Line 659  sub marc_compose {
659    
660          warn "### marc_compose input subfields = ", dump(@_),$/ if ($debug > 2);          warn "### marc_compose input subfields = ", dump(@_),$/ if ($debug > 2);
661    
662            if ($#_ % 2 != 1) {
663                    die "ERROR: marc_compose",dump($f,@_)," not valid (must be even).\nDo you need to add first() or join() around some argument?\n";
664            }
665    
666          while (@_) {          while (@_) {
667                  my $sf = shift or die "marc_compose $f needs subfield";                  my $sf = shift;
668                  my $v = shift;                  my $v = shift;
669    
670                  next unless (defined($v) && $v !~ /^\s*$/);                  next unless (defined($v) && $v !~ /^\s*$/);
                 from_to($v, 'iso-8859-2', $marc_encoding) if ($marc_encoding);  
671                  warn "## ++ marc_compose($f,$sf,$v) ", dump( $m ),$/ if ($debug > 1);                  warn "## ++ marc_compose($f,$sf,$v) ", dump( $m ),$/ if ($debug > 1);
672                  if ($sf ne '+') {                  if ($sf ne '+') {
673                          push @$m, ( $sf, $v );                          push @$m, ( $sf, $v );
# Line 574  sub marc_duplicate { Line 696  sub marc_duplicate {
696           my $m = $marc_record->[ -1 ];           my $m = $marc_record->[ -1 ];
697           die "can't duplicate record which isn't defined" unless ($m);           die "can't duplicate record which isn't defined" unless ($m);
698           push @{ $marc_record }, dclone( $m );           push @{ $marc_record }, dclone( $m );
699           warn "## marc_duplicate = ", dump(@$marc_record), $/ if ($debug > 1);           push @{ $marc_leader }, dclone( marc_leader() );
700             warn "## marc_duplicate = ", dump(@$marc_leader, @$marc_record), $/ if ($debug > 1);
701           $marc_record_offset = $#{ $marc_record };           $marc_record_offset = $#{ $marc_record };
702           warn "## marc_record_offset = $marc_record_offset", $/ if ($debug > 1);           warn "## marc_record_offset = $marc_record_offset", $/ if ($debug > 1);
703    
704  }  }
705    
706  =head2 marc_remove  =head2 marc_remove
# Line 588  Remove some field or subfield from MARC Line 712  Remove some field or subfield from MARC
712    
713  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.
714    
715      marc_remove('*');
716    
717    Will remove all fields in current MARC record.
718    
719  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
720  should probably just remove that subfield definition if you are not  should probably just remove that subfield definition if you are not
721  using C<marc_duplicate>).  using C<marc_duplicate>).
# Line 605  sub marc_remove { Line 733  sub marc_remove {
733    
734          warn "### marc_remove before = ", dump( $marc ), $/ if ($debug > 2);          warn "### marc_remove before = ", dump( $marc ), $/ if ($debug > 2);
735    
736          my $i = 0;          if ($f eq '*') {
737          foreach ( 0 .. $#{ $marc } ) {  
738                  last unless (defined $marc->[$i]);                  delete( $marc_record->[ $marc_record_offset ] );
739                  warn "#### working on ",dump( @{ $marc->[$i] }), $/ if ($debug > 3);                  warn "## full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 1);
740                  if ($marc->[$i]->[0] eq $f) {  
741                          if (! defined $sf) {          } else {
742                                  # remove whole field  
743                                  splice @$marc, $i, 1;                  my $i = 0;
744                                  warn "#### slice \@\$marc, $i, 1 = ",dump( @{ $marc }), $/ if ($debug > 3);                  foreach ( 0 .. $#{ $marc } ) {
745                                  $i--;                          last unless (defined $marc->[$i]);
746                          } else {                          warn "#### working on ",dump( @{ $marc->[$i] }), $/ if ($debug > 3);
747                                  foreach my $j ( 0 .. (( $#{ $marc->[$i] } - 3 ) / 2) ) {                          if ($marc->[$i]->[0] eq $f) {
748                                          my $o = ($j * 2) + 3;                                  if (! defined $sf) {
749                                          if ($marc->[$i]->[$o] eq $sf) {                                          # remove whole field
750                                                  # remove subfield                                          splice @$marc, $i, 1;
751                                                  splice @{$marc->[$i]}, $o, 2;                                          warn "#### slice \@\$marc, $i, 1 = ",dump( @{ $marc }), $/ if ($debug > 3);
752                                                  warn "#### slice \@{\$marc->[$i]}, $o, 2 = ", dump( @{ $marc }), $/ if ($debug > 3);                                          $i--;
753                                                  # is record now empty?                                  } else {
754                                                  if ($#{ $marc->[$i] } == 2) {                                          foreach my $j ( 0 .. (( $#{ $marc->[$i] } - 3 ) / 2) ) {
755                                                          splice @$marc, $i, 1;                                                  my $o = ($j * 2) + 3;
756                                                          warn "#### slice \@\$marc, $i, 1 = ", dump( @{ $marc }), $/ if ($debug > 3);                                                  if ($marc->[$i]->[$o] eq $sf) {
757                                                          $i--;                                                          # remove subfield
758                                                  };                                                          splice @{$marc->[$i]}, $o, 2;
759                                                            warn "#### slice \@{\$marc->[$i]}, $o, 2 = ", dump( @{ $marc }), $/ if ($debug > 3);
760                                                            # is record now empty?
761                                                            if ($#{ $marc->[$i] } == 2) {
762                                                                    splice @$marc, $i, 1;
763                                                                    warn "#### slice \@\$marc, $i, 1 = ", dump( @{ $marc }), $/ if ($debug > 3);
764                                                                    $i--;
765                                                            };
766                                                    }
767                                          }                                          }
768                                  }                                  }
769                          }                          }
770                            $i++;
771                  }                  }
                 $i++;  
         }  
772    
773          warn "### marc_remove($f", $sf ? ",$sf" : "", ") after = ", dump( $marc ), $/ if ($debug > 2);                  warn "### marc_remove($f", $sf ? ",$sf" : "", ") after = ", dump( $marc ), $/ if ($debug > 2);
774    
775          $marc_record->[ $marc_record_offset ] = $marc;                  $marc_record->[ $marc_record_offset ] = $marc;
776            }
777    
778          warn "## full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 1);          warn "## full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 1);
779  }  }
# Line 683  sub marc_original_order { Line 819  sub marc_original_order {
819    
820                  die "field $from doesn't have even number of subfields specifications\n" unless($#sfs % 2 == 1);                  die "field $from doesn't have even number of subfields specifications\n" unless($#sfs % 2 == 1);
821    
822  warn "#--> d: ",dump($d), "\n#--> sfs: ",dump(@sfs),$/;                  warn "#--> d: ",dump($d), "\n#--> sfs: ",dump(@sfs),$/ if ($debug > 2);
823    
824                  my $m = [ $to, $i1, $i2 ];                  my $m = [ $to, $i1, $i2 ];
825    
826                  while (my $sf = shift @sfs) {                  while (my $sf = shift @sfs) {
827  warn "#--> sf: ",dump($sf), $/;  
828                            warn "#--> sf: ",dump($sf), $/ if ($debug > 2);
829                          my $offset = shift @sfs;                          my $offset = shift @sfs;
830                          die "corrupted sufields specification for field $from\n" unless defined($offset);                          die "corrupted sufields specification for field $from\n" unless defined($offset);
831    
# Line 709  warn "#--> sf: ",dump($sf), $/; Line 846  warn "#--> sf: ",dump($sf), $/;
846          }          }
847    
848          warn "## marc_record = ", dump( $marc_record ),$/ if ($debug > 1);          warn "## marc_record = ", dump( $marc_record ),$/ if ($debug > 1);
849    }
850    
851    =head2 marc_count
852    
853    Return number of MARC records created using L</marc_duplicate>.
854    
855      print "created ", marc_count(), " records";
856    
857          warn "# marc_original_order is partly implemented";  =cut
858    
859    sub marc_count {
860            return $#{ $marc_record };
861  }  }
862    
863    
# Line 719  warn "#--> sf: ",dump($sf), $/; Line 866  warn "#--> sf: ",dump($sf), $/;
866  This function should be used inside functions to create C<data_structure> described  This function should be used inside functions to create C<data_structure> described
867  above.  above.
868    
869    =head2 _pack_subfields_hash
870    
871     @subfields = _pack_subfields_hash( $h );
872     $subfields = _pack_subfields_hash( $h, 1 );
873    
874    Return each subfield value in array or pack them all together and return scalar
875    with subfields (denoted by C<^>) and values.
876    
877    =cut
878    
879    sub _pack_subfields_hash {
880    
881            warn "## _pack_subfields_hash( ",dump(@_), " )\n" if ($debug > 1);
882    
883            my ($h,$include_subfields) = @_;
884    
885            # sanity and ease of use
886            return $h if (ref($h) ne 'HASH');
887    
888            if ( defined($h->{subfields}) ) {
889                    my $sfs = delete $h->{subfields} || die "no subfields?";
890                    my @out;
891                    while (@$sfs) {
892                            my $sf = shift @$sfs;
893                            push @out, '^' . $sf if ($include_subfields);
894                            my $o = shift @$sfs;
895                            if ($o == 0 && ref( $h->{$sf} ) ne 'ARRAY' ) {
896                                    # single element subfields are not arrays
897    #warn "====> $sf $o / $#$sfs ", dump( $sfs, $h->{$sf} ), "\n";
898    
899                                    push @out, $h->{$sf};
900                            } else {
901    #warn "====> $sf $o / $#$sfs ", dump( $sfs, $h->{$sf} ), "\n";
902                                    push @out, $h->{$sf}->[$o];
903                            }
904                    }
905                    if ($include_subfields) {
906                            return join('', @out);
907                    } else {
908                            return @out;
909                    }
910            } else {
911                    if ($include_subfields) {
912                            my $out = '';
913                            foreach my $sf (sort keys %$h) {
914                                    if (ref($h->{$sf}) eq 'ARRAY') {
915                                            $out .= '^' . $sf . join('^' . $sf, @{ $h->{$sf} });
916                                    } else {
917                                            $out .= '^' . $sf . $h->{$sf};
918                                    }
919                            }
920                            return $out;
921                    } else {
922                            # FIXME this should probably be in alphabetical order instead of hash order
923                            values %{$h};
924                    }
925            }
926    }
927    
928  =head2 rec1  =head2 rec1
929    
930  Return all values in some field  Return all values in some field
# Line 735  sub rec1 { Line 941  sub rec1 {
941          return unless (defined($rec) && defined($rec->{$f}));          return unless (defined($rec) && defined($rec->{$f}));
942          warn "rec1($f) = ", dump( $rec->{$f} ), $/ if ($debug > 1);          warn "rec1($f) = ", dump( $rec->{$f} ), $/ if ($debug > 1);
943          if (ref($rec->{$f}) eq 'ARRAY') {          if (ref($rec->{$f}) eq 'ARRAY') {
944                  return map {                  my @out;
945                          if (ref($_) eq 'HASH') {                  foreach my $h ( @{ $rec->{$f} } ) {
946                                  values %{$_};                          if (ref($h) eq 'HASH') {
947                                    push @out, ( _pack_subfields_hash( $h ) );
948                          } else {                          } else {
949                                  $_;                                  push @out, $h;
950                          }                          }
951                  } @{ $rec->{$f} };                  }
952                    return @out;
953          } elsif( defined($rec->{$f}) ) {          } elsif( defined($rec->{$f}) ) {
954                  return $rec->{$f};                  return $rec->{$f};
955          }          }
# Line 776  syntaxtic sugar for Line 984  syntaxtic sugar for
984    @v = rec('200')    @v = rec('200')
985    @v = rec('200','a')    @v = rec('200','a')
986    
987    If rec() returns just single value, it will
988    return scalar, not array.
989    
990  =cut  =cut
991    
992  sub rec {  sub rec {
# Line 785  sub rec { Line 996  sub rec {
996          } elsif ($#_ == 1) {          } elsif ($#_ == 1) {
997                  @out = rec2(@_);                  @out = rec2(@_);
998          }          }
999          if (@out) {          if ($#out == 0 && ! wantarray) {
1000                    return $out[0];
1001            } elsif (@out) {
1002                  return @out;                  return @out;
1003          } else {          } else {
1004                  return '';                  return '';
# Line 821  Prefix all values with a string Line 1034  Prefix all values with a string
1034  =cut  =cut
1035    
1036  sub prefix {  sub prefix {
1037          my $p = shift or return;          my $p = shift;
1038            return @_ unless defined( $p );
1039          return map { $p . $_ } grep { defined($_) } @_;          return map { $p . $_ } grep { defined($_) } @_;
1040  }  }
1041    
# Line 834  suffix all values with a string Line 1048  suffix all values with a string
1048  =cut  =cut
1049    
1050  sub suffix {  sub suffix {
1051          my $s = shift or die "suffix needs string as first argument";          my $s = shift;
1052            return @_ unless defined( $s );
1053          return map { $_ . $s } grep { defined($_) } @_;          return map { $_ . $s } grep { defined($_) } @_;
1054  }  }
1055    
# Line 847  surround all values with a two strings Line 1062  surround all values with a two strings
1062  =cut  =cut
1063    
1064  sub surround {  sub surround {
1065          my $p = shift or die "surround need prefix as first argument";          my $p = shift;
1066          my $s = shift or die "surround needs suffix as second argument";          my $s = shift;
1067            $p = '' unless defined( $p );
1068            $s = '' unless defined( $s );
1069          return map { $p . $_ . $s } grep { defined($_) } @_;          return map { $p . $_ . $s } grep { defined($_) } @_;
1070  }  }
1071    
# Line 869  sub first { Line 1086  sub first {
1086    
1087  Consult lookup hashes for some value  Consult lookup hashes for some value
1088    
1089    @v = lookup( $v );    @v = lookup(
1090    @v = lookup( @v );          sub {
1091                    'ffkk/peri/mfn'.rec('000')
1092            },
1093            'ffkk','peri','200-a-200-e',
1094            sub {
1095                    first(rec(200,'a')).' '.first(rec('200','e'))
1096            }
1097      );
1098    
1099    Code like above will be B<automatically generated> using L<WebPAC::Parse> from
1100    normal lookup definition in C<conf/lookup/something.pl> which looks like:
1101    
1102      lookup(
1103            # which results to return from record recorded in lookup
1104            sub { 'ffkk/peri/mfn' . rec('000') },
1105            # from which database and input
1106            'ffkk','peri',
1107            # such that following values match
1108            sub { first(rec(200,'a')) . ' ' . first(rec('200','e')) },
1109            # if this part is missing, we will try to match same fields
1110            # from lookup record and current one, or you can override
1111            # which records to use from current record using
1112            sub { rec('900','x') . ' ' . rec('900','y') },
1113      )
1114    
1115    You can think about this lookup as SQL (if that helps):
1116    
1117      select
1118            sub { what }
1119      from
1120            database, input
1121      where
1122        sub { filter from lookuped record }
1123      having
1124        sub { optional filter on current record }
1125    
1126    Easy as pie, right?
1127    
1128  =cut  =cut
1129    
1130  sub lookup {  sub lookup {
1131          my $k = shift or return;          my ($what, $database, $input, $key, $having) = @_;
1132          return unless (defined($lookup->{$k}));  
1133          if (ref($lookup->{$k}) eq 'ARRAY') {          confess "lookup needs 5 arguments: what, database, input, key, having\n" unless ($#_ == 4);
1134                  return @{ $lookup->{$k} };  
1135            warn "## lookup ($database, $input, $key)", $/ if ($debug > 1);
1136            return unless (defined($lookup->{$database}->{$input}->{$key}));
1137    
1138            confess "lookup really need load_row_coderef added to data_structure\n" unless ($load_row_coderef);
1139    
1140            my $mfns;
1141            my @having = $having->();
1142    
1143            warn "## having = ", dump( @having ) if ($debug > 2);
1144    
1145            foreach my $h ( @having ) {
1146                    if (defined($lookup->{$database}->{$input}->{$key}->{$h})) {
1147                            warn "lookup for $database/$input/$key/$h return ",dump($lookup->{$database}->{$input}->{$key}->{$h}),"\n" if ($debug);
1148                            $mfns->{$_}++ foreach keys %{ $lookup->{$database}->{$input}->{$key}->{$h} };
1149                    }
1150            }
1151    
1152            return unless ($mfns);
1153    
1154            my @mfns = sort keys %$mfns;
1155    
1156            warn "# lookup loading $database/$input/$key mfn ", join(",",@mfns)," having ",dump(@having),"\n" if ($debug);
1157    
1158            my $old_rec = $rec;
1159            my @out;
1160    
1161            foreach my $mfn (@mfns) {
1162                    $rec = $load_row_coderef->( $database, $input, $mfn );
1163    
1164                    warn "got $database/$input/$mfn = ", dump($rec), $/ if ($debug);
1165    
1166                    my @vals = $what->();
1167    
1168                    push @out, ( @vals );
1169    
1170                    warn "lookup for mfn $mfn returned ", dump(@vals), $/ if ($debug);
1171            }
1172    
1173    #       if (ref($lookup->{$k}) eq 'ARRAY') {
1174    #               return @{ $lookup->{$k} };
1175    #       } else {
1176    #               return $lookup->{$k};
1177    #       }
1178    
1179            $rec = $old_rec;
1180    
1181            warn "## lookup returns = ", dump(@out), $/ if ($debug);
1182    
1183            if ($#out == 0) {
1184                    return $out[0];
1185          } else {          } else {
1186                  return $lookup->{$k};                  return @out;
1187            }
1188    }
1189    
1190    =head2 save_into_lookup
1191    
1192    Save value into lookup. It associates current database, input
1193    and specific keys with one or more values which will be
1194    associated over MFN.
1195    
1196    MFN will be extracted from first occurence current of field 000
1197    in current record, or if it doesn't exist from L<_set_config> C<_mfn>.
1198    
1199      my $nr = save_into_lookup($database,$input,$key,sub {
1200            # code which produce one or more values
1201      });
1202    
1203    It returns number of items saved.
1204    
1205    This function shouldn't be called directly, it's called from code created by
1206    L<WebPAC::Parser>.
1207    
1208    =cut
1209    
1210    sub save_into_lookup {
1211            my ($database,$input,$key,$coderef) = @_;
1212            die "save_into_lookup needs database" unless defined($database);
1213            die "save_into_lookup needs input" unless defined($input);
1214            die "save_into_lookup needs key" unless defined($key);
1215            die "save_into_lookup needs CODE" unless ( defined($coderef) && ref($coderef) eq 'CODE' );
1216    
1217            warn "## save_into_lookup rec = ", dump($rec), " config = ", dump($config), $/ if ($debug > 2);
1218    
1219            my $mfn =
1220                    defined($rec->{'000'}->[0])     ?       $rec->{'000'}->[0]      :
1221                    defined($config->{_mfn})        ?       $config->{_mfn}         :
1222                                                                                    die "mfn not defined or zero";
1223    
1224            my $nr = 0;
1225    
1226            foreach my $v ( $coderef->() ) {
1227                    $lookup->{$database}->{$input}->{$key}->{$v}->{$mfn}++;
1228                    warn "# saved lookup $database/$input/$key [$v] $mfn\n" if ($debug > 1);
1229                    $nr++;
1230          }          }
1231    
1232            return $nr;
1233  }  }
1234    
1235  =head2 config  =head2 config
# Line 892  Consult config values stored in C<config Line 1240  Consult config values stored in C<config
1240    $database_code = config();    # use _ from hash    $database_code = config();    # use _ from hash
1241    $database_name = config('name');    $database_name = config('name');
1242    $database_input_name = config('input name');    $database_input_name = config('input name');
   $tag = config('input normalize tag');  
1243    
1244  Up to three levels are supported.  Up to three levels are supported.
1245    
# Line 1008  sub split_rec_on { Line 1355  sub split_rec_on {
1355          }          }
1356  }  }
1357    
1358    my $hash;
1359    
1360    =head2 set
1361    
1362      set( key => 'value' );
1363    
1364    =cut
1365    
1366    sub set {
1367            my ($k,$v) = @_;
1368            warn "## set ( $k => ", dump($v), " )", $/ if ( $debug );
1369            $hash->{$k} = $v;
1370    };
1371    
1372    =head2 get
1373    
1374      get( 'key' );
1375    
1376    =cut
1377    
1378    sub get {
1379            my $k = shift || return;
1380            my $v = $hash->{$k};
1381            warn "## get $k = ", dump( $v ), $/ if ( $debug );
1382            return $v;
1383    }
1384    
1385    =head2 count
1386    
1387      if ( count( @result ) == 1 ) {
1388            # do something if only 1 result is there
1389      }
1390    
1391    =cut
1392    
1393    sub count {
1394            warn "## count ",dump(@_),$/ if ( $debug );
1395            return @_ . '';
1396    }
1397    
1398  # END  # END
1399  1;  1;

Legend:
Removed from v.616  
changed lines
  Added in v.915

  ViewVC Help
Powered by ViewVC 1.1.26