/[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 786 by dpavlin, Sun Dec 10 12:45:11 2006 UTC revision 915 by dpavlin, Tue Oct 30 20:27:20 2007 UTC
# Line 7  use Exporter 'import'; Line 7  use Exporter 'import';
7          _debug          _debug
8          _pack_subfields_hash          _pack_subfields_hash
9    
10          tag search display          search_display search display
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
# Line 21  use Exporter 'import'; Line 22  use Exporter 'import';
22          split_rec_on          split_rec_on
23    
24          get set          get set
25            count
26  /;  /;
27    
28  use warnings;  use warnings;
# Line 41  WebPAC::Normalize - describe normalisato Line 43  WebPAC::Normalize - describe normalisato
43    
44  =head1 VERSION  =head1 VERSION
45    
46  Version 0.25  Version 0.30
47    
48  =cut  =cut
49    
50  our $VERSION = '0.25';  our $VERSION = '0.30';
51    
52  =head1 SYNOPSIS  =head1 SYNOPSIS
53    
# Line 58  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 166  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, $leader);  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 183  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, $leader) = ();          ($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 288  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 303  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 326  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 407  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 426  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 456  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 472  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 489  sub marc_leader { Line 513  sub marc_leader {
513          my ($offset,$value) = @_;          my ($offset,$value) = @_;
514    
515          if ($offset) {          if ($offset) {
516                  $leader->{ $offset } = $value;                  $marc_leader->[ $marc_record_offset ]->{ $offset } = $value;
517          } else {          } else {
518                  return $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 623  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 661  sub marc_remove { Line 736  sub marc_remove {
736          if ($f eq '*') {          if ($f eq '*') {
737    
738                  delete( $marc_record->[ $marc_record_offset ] );                  delete( $marc_record->[ $marc_record_offset ] );
739                    warn "## full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 1);
740    
741          } else {          } else {
742    
# Line 699  sub marc_remove { Line 775  sub marc_remove {
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  }  }
780    
# Line 773  sub marc_original_order { Line 848  sub marc_original_order {
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    =cut
858    
859    sub marc_count {
860            return $#{ $marc_record };
861    }
862    
863    
864  =head1 Functions to extract data from input  =head1 Functions to extract data from input
865    
# Line 795  sub _pack_subfields_hash { Line 882  sub _pack_subfields_hash {
882    
883          my ($h,$include_subfields) = @_;          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}) ) {          if ( defined($h->{subfields}) ) {
889                  my $sfs = delete $h->{subfields} || die "no subfields?";                  my $sfs = delete $h->{subfields} || die "no subfields?";
890                  my @out;                  my @out;
# Line 944  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 957  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 970  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 1146  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 1272  my $hash; Line 1365  my $hash;
1365    
1366  sub set {  sub set {
1367          my ($k,$v) = @_;          my ($k,$v) = @_;
1368          warn "## set ( $k => ", dump($v), " )", $/;          warn "## set ( $k => ", dump($v), " )", $/ if ( $debug );
1369          $hash->{$k} = $v;          $hash->{$k} = $v;
1370  };  };
1371    
# Line 1285  sub set { Line 1378  sub set {
1378  sub get {  sub get {
1379          my $k = shift || return;          my $k = shift || return;
1380          my $v = $hash->{$k};          my $v = $hash->{$k};
1381          warn "## get $k = ", dump( $v ), $/;          warn "## get $k = ", dump( $v ), $/ if ( $debug );
1382          return $v;          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.786  
changed lines
  Added in v.915

  ViewVC Help
Powered by ViewVC 1.1.26