/[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 603 by dpavlin, Sun Jul 23 20:19:56 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
9    
10            search_display search display sorted
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
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
22    
23          split_rec_on          split_rec_on
24    
25            get set
26            count
27    
28  /;  /;
29    
30  use warnings;  use warnings;
# Line 22  use strict; Line 32  use strict;
32    
33  #use base qw/WebPAC::Common/;  #use base qw/WebPAC::Common/;
34  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
 use Encode qw/from_to/;  
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.15  
   
48  =cut  =cut
49    
50  our $VERSION = '0.15';  our $VERSION = '0.32';
51    
52  =head1 SYNOPSIS  =head1 SYNOPSIS
53    
# Line 52  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 65  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) = @_;
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 82  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 89  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_ds( $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    
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 149  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 166  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 185  sub _set_lookup { Line 205  sub _set_lookup {
205          $lookup = shift;          $lookup = shift;
206  }  }
207    
208    =head2 _get_lookup
209    
210    Get current lookup hash
211    
212      my $lookup = _get_lookup();
213    
214    =cut
215    
216    sub _get_lookup {
217            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 240  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 255  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 278  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 359  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 378  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 420  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 441  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 468  sub marc { Line 599  sub marc {
599          foreach (@_) {          foreach (@_) {
600                  my $v = $_;             # make var read-write for Encode                  my $v = $_;             # make var read-write for Encode
601                  next unless (defined($v) && $v !~ /^\s*$/);                  next unless (defined($v) && $v !~ /^\s*$/);
                 from_to($v, 'iso-8859-2', $marc_encoding) if ($marc_encoding);  
602                  my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');                  my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');
603                  if (defined $sf) {                  if (defined $sf) {
604                          push @{ $marc_record->[ $marc_record_offset ] }, [ $f, $i1, $i2, $sf => $v ];                          push @{ $marc_record->[ $marc_record_offset ] }, [ $f, $i1, $i2, $sf => $v ];
# Line 539  sub marc_compose { Line 669  sub marc_compose {
669    
670          warn "### marc_compose input subfields = ", dump(@_),$/ if ($debug > 2);          warn "### marc_compose input subfields = ", dump(@_),$/ if ($debug > 2);
671    
672            if ($#_ % 2 != 1) {
673                    die "ERROR: marc_compose",dump($f,@_)," not valid (must be even).\nDo you need to add first() or join() around some argument?\n";
674            }
675    
676          while (@_) {          while (@_) {
677                  my $sf = shift or die "marc_compose $f needs subfield";                  my $sf = shift;
678                  my $v = shift;                  my $v = shift;
679    
680                  next unless (defined($v) && $v !~ /^\s*$/);                  next unless (defined($v) && $v !~ /^\s*$/);
                 from_to($v, 'iso-8859-2', $marc_encoding) if ($marc_encoding);  
681                  warn "## ++ marc_compose($f,$sf,$v) ", dump( $m ),$/ if ($debug > 1);                  warn "## ++ marc_compose($f,$sf,$v) ", dump( $m ),$/ if ($debug > 1);
682                  if ($sf ne '+') {                  if ($sf ne '+') {
683                          push @$m, ( $sf, $v );                          push @$m, ( $sf, $v );
# Line 573  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 587  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 604  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  }  }
790    
791    =head2 marc_original_order
792    
793    Copy all subfields preserving original order to marc field.
794    
795      marc_original_order( marc_field_number, original_input_field_number );
796    
797    Please note that field numbers are consistent with other commands (marc
798    field number first), but somewhat counter-intuitive (destination and then
799    source).
800    
801    You might want to use this command if you are just renaming subfields or
802    using pre-processing modify_record in C<config.yml> and don't need any
803    post-processing or want to preserve order of original subfields.
804    
805    
806    =cut
807    
808    sub marc_original_order {
809    
810            my ($to, $from) = @_;
811            die "marc_original_order needs from and to fields\n" unless ($from && $to);
812    
813            return unless defined($rec->{$from});
814    
815            my $r = $rec->{$from};
816            die "record field $from isn't array\n" unless (ref($r) eq 'ARRAY');
817    
818            my ($i1,$i2) = defined($marc_indicators->{$to}) ? @{ $marc_indicators->{$to} } : (' ',' ');
819            warn "## marc_original_order($to,$from) source = ", dump( $r ),$/ if ($debug > 1);
820    
821            foreach my $d (@$r) {
822    
823                    if (! defined($d->{subfields}) && ref($d->{subfields}) ne 'ARRAY') {
824                            warn "# marc_original_order($to,$from): field $from doesn't have subfields specification\n";
825                            next;
826                    }
827            
828                    my @sfs = @{ $d->{subfields} };
829    
830                    die "field $from doesn't have even number of subfields specifications\n" unless($#sfs % 2 == 1);
831    
832                    warn "#--> d: ",dump($d), "\n#--> sfs: ",dump(@sfs),$/ if ($debug > 2);
833    
834                    my $m = [ $to, $i1, $i2 ];
835    
836                    while (my $sf = shift @sfs) {
837    
838                            warn "#--> sf: ",dump($sf), $/ if ($debug > 2);
839                            my $offset = shift @sfs;
840                            die "corrupted sufields specification for field $from\n" unless defined($offset);
841    
842                            my $v;
843                            if (ref($d->{$sf}) eq 'ARRAY') {
844                                    $v = $d->{$sf}->[$offset] if (defined($d->{$sf}->[$offset]));
845                            } elsif ($offset == 0) {
846                                    $v = $d->{$sf};
847                            } else {
848                                    die "field $from subfield '$sf' need occurence $offset which doesn't exist", dump($d->{$sf});
849                            }
850                            push @$m, ( $sf, $v ) if (defined($v));
851                    }
852    
853                    if ($#{$m} > 2) {
854                            push @{ $marc_record->[ $marc_record_offset ] }, $m;
855                    }
856            }
857    
858            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    
876  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
877  above.  above.
878    
879    =head2 _pack_subfields_hash
880    
881     @subfields = _pack_subfields_hash( $h );
882     $subfields = _pack_subfields_hash( $h, 1 );
883    
884    Return each subfield value in array or pack them all together and return scalar
885    with subfields (denoted by C<^>) and values.
886    
887    =cut
888    
889    sub _pack_subfields_hash {
890    
891            warn "## _pack_subfields_hash( ",dump(@_), " )\n" if ($debug > 1);
892    
893            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}) ) {
899                    my $sfs = delete $h->{subfields} || die "no subfields?";
900                    my @out;
901                    while (@$sfs) {
902                            my $sf = shift @$sfs;
903                            push @out, '^' . $sf if ($include_subfields);
904                            my $o = shift @$sfs;
905                            if ($o == 0 && ref( $h->{$sf} ) ne 'ARRAY' ) {
906                                    # single element subfields are not arrays
907    #warn "====> $sf $o / $#$sfs ", dump( $sfs, $h->{$sf} ), "\n";
908    
909                                    push @out, $h->{$sf};
910                            } else {
911    #warn "====> $sf $o / $#$sfs ", dump( $sfs, $h->{$sf} ), "\n";
912                                    push @out, $h->{$sf}->[$o];
913                            }
914                    }
915                    if ($include_subfields) {
916                            return join('', @out);
917                    } else {
918                            return @out;
919                    }
920            } else {
921                    if ($include_subfields) {
922                            my $out = '';
923                            foreach my $sf (sort keys %$h) {
924                                    if (ref($h->{$sf}) eq 'ARRAY') {
925                                            $out .= '^' . $sf . join('^' . $sf, @{ $h->{$sf} });
926                                    } else {
927                                            $out .= '^' . $sf . $h->{$sf};
928                                    }
929                            }
930                            return $out;
931                    } else {
932                            # FIXME this should probably be in alphabetical order instead of hash order
933                            values %{$h};
934                    }
935            }
936    }
937    
938  =head2 rec1  =head2 rec1
939    
940  Return all values in some field  Return all values in some field
# Line 662  sub rec1 { Line 951  sub rec1 {
951          return unless (defined($rec) && defined($rec->{$f}));          return unless (defined($rec) && defined($rec->{$f}));
952          warn "rec1($f) = ", dump( $rec->{$f} ), $/ if ($debug > 1);          warn "rec1($f) = ", dump( $rec->{$f} ), $/ if ($debug > 1);
953          if (ref($rec->{$f}) eq 'ARRAY') {          if (ref($rec->{$f}) eq 'ARRAY') {
954                  return map {                  my @out;
955                          if (ref($_) eq 'HASH') {                  foreach my $h ( @{ $rec->{$f} } ) {
956                                  values %{$_};                          if (ref($h) eq 'HASH') {
957                                    push @out, ( _pack_subfields_hash( $h ) );
958                          } else {                          } else {
959                                  $_;                                  push @out, $h;
960                          }                          }
961                  } @{ $rec->{$f} };                  }
962                    return @out;
963          } elsif( defined($rec->{$f}) ) {          } elsif( defined($rec->{$f}) ) {
964                  return $rec->{$f};                  return $rec->{$f};
965          }          }
# Line 703  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 712  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 748  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 761  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 774  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 796  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    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
1207    
1208    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    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
1217      });
1218    
1219    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
1225    
1226    sub save_into_lookup {
1227            my ($database,$input,$key,$coderef) = @_;
1228            die "save_into_lookup needs database" unless defined($database);
1229            die "save_into_lookup needs input" unless defined($input);
1230            die "save_into_lookup needs key" unless defined($key);
1231            die "save_into_lookup needs CODE" unless ( defined($coderef) && ref($coderef) eq 'CODE' );
1232    
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->() ) {
1243                    $lookup->{$database}->{$input}->{$key}->{$v}->{$mfn}++;
1244                    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
1252    
1253  Consult config values stored in C<config.yml>  Consult config values stored in C<config.yml>
# Line 819  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 924  sub split_rec_on { Line 1360  sub split_rec_on {
1360          my $v = shift @r;          my $v = shift @r;
1361          warn "### first rec($fld,$sf) = ",dump($v),$/ if ($debug > 2);          warn "### first rec($fld,$sf) = ",dump($v),$/ if ($debug > 2);
1362    
1363          return '' if( ! defined($v) || $v =~ /^\s*$/);          return '' if ( ! defined($v) || $v =~ /^\s*$/);
1364    
1365          my @s = split( $regex, $v );          my @s = split( $regex, $v );
1366          warn "## split_rec_on($fld,$sf,$regex,$part) = ",dump(@s),$/ if ($debug > 1);          warn "## split_rec_on($fld,$sf,$regex,$part) = ",dump(@s),$/ if ($debug > 1);
# Line 935  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.603  
changed lines
  Added in v.990

  ViewVC Help
Powered by ViewVC 1.1.26