/[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 741 by dpavlin, Sun Oct 8 00:38:04 2006 UTC revision 889 by dpavlin, Thu Sep 6 19:12:15 2007 UTC
# Line 9  use Exporter 'import'; Line 9  use Exporter 'import';
9    
10          tag search display          tag search display
11          marc marc_indicators marc_repeatable_subfield          marc marc_indicators marc_repeatable_subfield
12          marc_compose marc_leader          marc_compose marc_leader marc_fixed
13          marc_duplicate marc_remove          marc_duplicate marc_remove marc_count
14          marc_original_order          marc_original_order
15    
16          rec1 rec2 rec          rec1 rec2 rec
# Line 19  use Exporter 'import'; Line 19  use Exporter 'import';
19          save_into_lookup          save_into_lookup
20    
21          split_rec_on          split_rec_on
22    
23            get set
24            count
25  /;  /;
26    
27  use warnings;  use warnings;
# Line 39  WebPAC::Normalize - describe normalisato Line 42  WebPAC::Normalize - describe normalisato
42    
43  =head1 VERSION  =head1 VERSION
44    
45  Version 0.22  Version 0.29
46    
47  =cut  =cut
48    
49  our $VERSION = '0.22';  our $VERSION = '0.29';
50    
51  =head1 SYNOPSIS  =head1 SYNOPSIS
52    
# Line 164  Return hash formatted as data structure Line 167  Return hash formatted as data structure
167    
168  =cut  =cut
169    
170  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);
171  my ($marc_record_offset, $marc_fetch_offset) = (0, 0);  my ($marc_record_offset, $marc_fetch_offset) = (0, 0);
172    
173  sub _get_ds {  sub _get_ds {
# Line 181  Clean data structure hash for next recor Line 184  Clean data structure hash for next recor
184    
185  sub _clean_ds {  sub _clean_ds {
186          my $a = {@_};          my $a = {@_};
187          ($out,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators, $leader) = ();          ($out,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators, $marc_leader) = ();
188          ($marc_record_offset, $marc_fetch_offset) = (0,0);          ($marc_record_offset, $marc_fetch_offset) = (0,0);
189          $marc_encoding = $a->{marc_encoding};          $marc_encoding = $a->{marc_encoding};
190  }  }
# Line 286  will return 42th copy record (if it exis Line 289  will return 42th copy record (if it exis
289    
290  =cut  =cut
291    
292    my $fetch_pos;
293    
294  sub _get_marc_fields {  sub _get_marc_fields {
295    
296          my $arg = {@_};          my $arg = {@_};
297          warn "### _get_marc_fields arg: ", dump($arg), $/ if ($debug > 2);          warn "### _get_marc_fields arg: ", dump($arg), $/ if ($debug > 2);
298          my $offset = $marc_fetch_offset;          $fetch_pos = $marc_fetch_offset;
299          if ($arg->{offset}) {          if ($arg->{offset}) {
300                  $offset = $arg->{offset};                  $fetch_pos = $arg->{offset};
301          } elsif($arg->{fetch_next}) {          } elsif($arg->{fetch_next}) {
302                  $marc_fetch_offset++;                  $marc_fetch_offset++;
303          }          }
# Line 301  sub _get_marc_fields { Line 306  sub _get_marc_fields {
306    
307          warn "### full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 2);          warn "### full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 2);
308    
309          my $marc_rec = $marc_record->[ $offset ];          my $marc_rec = $marc_record->[ $fetch_pos ];
310    
311          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);
312    
313          return if (! $marc_rec || ref($marc_rec) ne 'ARRAY' || $#{ $marc_rec } < 0);          return if (! $marc_rec || ref($marc_rec) ne 'ARRAY' || $#{ $marc_rec } < 0);
314    
# Line 324  sub _get_marc_fields { Line 329  sub _get_marc_fields {
329    
330          if ($debug) {          if ($debug) {
331                  warn "## marc_repeatable_subfield = ", dump( $marc_repeatable_subfield ), $/ if ( $marc_repeatable_subfield );                  warn "## marc_repeatable_subfield = ", dump( $marc_repeatable_subfield ), $/ if ( $marc_repeatable_subfield );
332                  warn "## marc_record[$offset] = ", dump( $marc_rec ), $/;                  warn "## marc_record[$fetch_pos] = ", dump( $marc_rec ), $/;
333                  warn "## sorted_marc_record = ", dump( \@sorted_marc_record ), $/;                  warn "## sorted_marc_record = ", dump( \@sorted_marc_record ), $/;
334                  warn "## subfield count = ", dump( $u ), $/;                  warn "## subfield count = ", dump( $u ), $/;
335          }          }
# Line 405  sub _get_marc_fields { Line 410  sub _get_marc_fields {
410          return \@m;          return \@m;
411  }  }
412    
413    =head2 _get_marc_leader
414    
415    Return leader from currently fetched record by L</_get_marc_fields>
416    
417      print WebPAC::Normalize::_get_marc_leader();
418    
419    =cut
420    
421    sub _get_marc_leader {
422            die "no fetch_pos, did you called _get_marc_fields first?" unless ( defined( $fetch_pos ) );
423            return $marc_leader->[ $fetch_pos ];
424    }
425    
426  =head2 _debug  =head2 _debug
427    
428  Change level of debug warnings  Change level of debug warnings
# Line 487  sub marc_leader { Line 505  sub marc_leader {
505          my ($offset,$value) = @_;          my ($offset,$value) = @_;
506    
507          if ($offset) {          if ($offset) {
508                  $leader->{ $offset } = $value;                  $marc_leader->[ $marc_record_offset ]->{ $offset } = $value;
509          } else {          } else {
510                  return $leader;                  
511                    if (defined($marc_leader)) {
512                            die "marc_leader not array = ", dump( $marc_leader ) unless (ref($marc_leader) eq 'ARRAY');
513                            return $marc_leader->[ $marc_record_offset ];
514                    } else {
515                            return;
516                    }
517            }
518    }
519    
520    =head2 marc_fixed
521    
522    Create control/indentifier fields with values in fixed positions
523    
524      marc_fixed('008', 00, '070402');
525      marc_fixed('008', 39, '|');
526    
527    Positions not specified will be filled with spaces (C<0x20>).
528    
529    There will be no effort to extend last specified value to full length of
530    field in standard.
531    
532    =cut
533    
534    sub marc_fixed {
535            my ($f, $pos, $val) = @_;
536            die "need marc(field, position, value)" unless defined($f) && defined($pos);
537    
538            confess "need val" unless defined $val;
539    
540            my $update = 0;
541    
542            map {
543                    if ($_->[0] eq $f) {
544                            my $old = $_->[1];
545                            if (length($old) <= $pos) {
546                                    $_->[1] .= ' ' x ( $pos - length($old) ) . $val;
547                                    warn "## marc_fixed($f,$pos,'$val') append '$old' -> '$_->[1]'\n" if ($debug > 1);
548                            } else {
549                                    $_->[1] = substr($old, 0, $pos) . $val . substr($old, $pos + length($val));
550                                    warn "## marc_fixed($f,$pos,'$val') update '$old' -> '$_->[1]'\n" if ($debug > 1);
551                            }
552                            $update++;
553                    }
554            } @{ $marc_record->[ $marc_record_offset ] };
555    
556            if (! $update) {
557                    my $v = ' ' x $pos . $val;
558                    push @{ $marc_record->[ $marc_record_offset ] }, [ $f, $v ];
559                    warn "## marc_fixed($f,$pos,'val') created '$v'\n" if ($debug > 1);
560          }          }
561  }  }
562    
# Line 621  sub marc_duplicate { Line 688  sub marc_duplicate {
688           my $m = $marc_record->[ -1 ];           my $m = $marc_record->[ -1 ];
689           die "can't duplicate record which isn't defined" unless ($m);           die "can't duplicate record which isn't defined" unless ($m);
690           push @{ $marc_record }, dclone( $m );           push @{ $marc_record }, dclone( $m );
691           warn "## marc_duplicate = ", dump(@$marc_record), $/ if ($debug > 1);           push @{ $marc_leader }, dclone( marc_leader() );
692             warn "## marc_duplicate = ", dump(@$marc_leader, @$marc_record), $/ if ($debug > 1);
693           $marc_record_offset = $#{ $marc_record };           $marc_record_offset = $#{ $marc_record };
694           warn "## marc_record_offset = $marc_record_offset", $/ if ($debug > 1);           warn "## marc_record_offset = $marc_record_offset", $/ if ($debug > 1);
695    
696  }  }
697    
698  =head2 marc_remove  =head2 marc_remove
# Line 635  Remove some field or subfield from MARC Line 704  Remove some field or subfield from MARC
704    
705  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.
706    
707      marc_remove('*');
708    
709    Will remove all fields in current MARC record.
710    
711  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
712  should probably just remove that subfield definition if you are not  should probably just remove that subfield definition if you are not
713  using C<marc_duplicate>).  using C<marc_duplicate>).
# Line 652  sub marc_remove { Line 725  sub marc_remove {
725    
726          warn "### marc_remove before = ", dump( $marc ), $/ if ($debug > 2);          warn "### marc_remove before = ", dump( $marc ), $/ if ($debug > 2);
727    
728          my $i = 0;          if ($f eq '*') {
729          foreach ( 0 .. $#{ $marc } ) {  
730                  last unless (defined $marc->[$i]);                  delete( $marc_record->[ $marc_record_offset ] );
731                  warn "#### working on ",dump( @{ $marc->[$i] }), $/ if ($debug > 3);                  warn "## full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 1);
732                  if ($marc->[$i]->[0] eq $f) {  
733                          if (! defined $sf) {          } else {
734                                  # remove whole field  
735                                  splice @$marc, $i, 1;                  my $i = 0;
736                                  warn "#### slice \@\$marc, $i, 1 = ",dump( @{ $marc }), $/ if ($debug > 3);                  foreach ( 0 .. $#{ $marc } ) {
737                                  $i--;                          last unless (defined $marc->[$i]);
738                          } else {                          warn "#### working on ",dump( @{ $marc->[$i] }), $/ if ($debug > 3);
739                                  foreach my $j ( 0 .. (( $#{ $marc->[$i] } - 3 ) / 2) ) {                          if ($marc->[$i]->[0] eq $f) {
740                                          my $o = ($j * 2) + 3;                                  if (! defined $sf) {
741                                          if ($marc->[$i]->[$o] eq $sf) {                                          # remove whole field
742                                                  # remove subfield                                          splice @$marc, $i, 1;
743                                                  splice @{$marc->[$i]}, $o, 2;                                          warn "#### slice \@\$marc, $i, 1 = ",dump( @{ $marc }), $/ if ($debug > 3);
744                                                  warn "#### slice \@{\$marc->[$i]}, $o, 2 = ", dump( @{ $marc }), $/ if ($debug > 3);                                          $i--;
745                                                  # is record now empty?                                  } else {
746                                                  if ($#{ $marc->[$i] } == 2) {                                          foreach my $j ( 0 .. (( $#{ $marc->[$i] } - 3 ) / 2) ) {
747                                                          splice @$marc, $i, 1;                                                  my $o = ($j * 2) + 3;
748                                                          warn "#### slice \@\$marc, $i, 1 = ", dump( @{ $marc }), $/ if ($debug > 3);                                                  if ($marc->[$i]->[$o] eq $sf) {
749                                                          $i--;                                                          # remove subfield
750                                                  };                                                          splice @{$marc->[$i]}, $o, 2;
751                                                            warn "#### slice \@{\$marc->[$i]}, $o, 2 = ", dump( @{ $marc }), $/ if ($debug > 3);
752                                                            # is record now empty?
753                                                            if ($#{ $marc->[$i] } == 2) {
754                                                                    splice @$marc, $i, 1;
755                                                                    warn "#### slice \@\$marc, $i, 1 = ", dump( @{ $marc }), $/ if ($debug > 3);
756                                                                    $i--;
757                                                            };
758                                                    }
759                                          }                                          }
760                                  }                                  }
761                          }                          }
762                            $i++;
763                  }                  }
                 $i++;  
         }  
764    
765          warn "### marc_remove($f", $sf ? ",$sf" : "", ") after = ", dump( $marc ), $/ if ($debug > 2);                  warn "### marc_remove($f", $sf ? ",$sf" : "", ") after = ", dump( $marc ), $/ if ($debug > 2);
766    
767          $marc_record->[ $marc_record_offset ] = $marc;                  $marc_record->[ $marc_record_offset ] = $marc;
768            }
769    
770          warn "## full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 1);          warn "## full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 1);
771  }  }
# Line 759  sub marc_original_order { Line 840  sub marc_original_order {
840          warn "## marc_record = ", dump( $marc_record ),$/ if ($debug > 1);          warn "## marc_record = ", dump( $marc_record ),$/ if ($debug > 1);
841  }  }
842    
843    =head2 marc_count
844    
845    Return number of MARC records created using L</marc_duplicate>.
846    
847      print "created ", marc_count(), " records";
848    
849    =cut
850    
851    sub marc_count {
852            return $#{ $marc_record };
853    }
854    
855    
856  =head1 Functions to extract data from input  =head1 Functions to extract data from input
857    
# Line 781  sub _pack_subfields_hash { Line 874  sub _pack_subfields_hash {
874    
875          my ($h,$include_subfields) = @_;          my ($h,$include_subfields) = @_;
876    
877            # sanity and ease of use
878            return $h if (ref($h) ne 'HASH');
879    
880          if ( defined($h->{subfields}) ) {          if ( defined($h->{subfields}) ) {
881                  my $sfs = delete $h->{subfields} || die "no subfields?";                  my $sfs = delete $h->{subfields} || die "no subfields?";
882                  my @out;                  my @out;
# Line 880  syntaxtic sugar for Line 976  syntaxtic sugar for
976    @v = rec('200')    @v = rec('200')
977    @v = rec('200','a')    @v = rec('200','a')
978    
979    If rec() returns just single value, it will
980    return scalar, not array.
981    
982  =cut  =cut
983    
984  sub rec {  sub rec {
# Line 889  sub rec { Line 988  sub rec {
988          } elsif ($#_ == 1) {          } elsif ($#_ == 1) {
989                  @out = rec2(@_);                  @out = rec2(@_);
990          }          }
991          if (@out) {          if ($#out == 0 && ! wantarray) {
992                    return $out[0];
993            } elsif (@out) {
994                  return @out;                  return @out;
995          } else {          } else {
996                  return '';                  return '';
# Line 925  Prefix all values with a string Line 1026  Prefix all values with a string
1026  =cut  =cut
1027    
1028  sub prefix {  sub prefix {
1029          my $p = shift or return;          my $p = shift;
1030            return @_ unless defined( $p );
1031          return map { $p . $_ } grep { defined($_) } @_;          return map { $p . $_ } grep { defined($_) } @_;
1032  }  }
1033    
# Line 938  suffix all values with a string Line 1040  suffix all values with a string
1040  =cut  =cut
1041    
1042  sub suffix {  sub suffix {
1043          my $s = shift or die "suffix needs string as first argument";          my $s = shift;
1044            return @_ unless defined( $s );
1045          return map { $_ . $s } grep { defined($_) } @_;          return map { $_ . $s } grep { defined($_) } @_;
1046  }  }
1047    
# Line 951  surround all values with a two strings Line 1054  surround all values with a two strings
1054  =cut  =cut
1055    
1056  sub surround {  sub surround {
1057          my $p = shift or die "surround need prefix as first argument";          my $p = shift;
1058          my $s = shift or die "surround needs suffix as second argument";          my $s = shift;
1059            $p = '' unless defined( $p );
1060            $s = '' unless defined( $s );
1061          return map { $p . $_ . $s } grep { defined($_) } @_;          return map { $p . $_ . $s } grep { defined($_) } @_;
1062  }  }
1063    
# Line 1017  Easy as pie, right? Line 1122  Easy as pie, right?
1122  sub lookup {  sub lookup {
1123          my ($what, $database, $input, $key, $having) = @_;          my ($what, $database, $input, $key, $having) = @_;
1124    
1125          confess "lookup needs 5 arguments: what, database, input, key, having" unless ($#_ == 4);          confess "lookup needs 5 arguments: what, database, input, key, having\n" unless ($#_ == 4);
1126    
1127          warn "## lookup ($database, $input, $key)", $/ if ($debug > 1);          warn "## lookup ($database, $input, $key)", $/ if ($debug > 1);
1128          return unless (defined($lookup->{$database}->{$input}->{$key}));          return unless (defined($lookup->{$database}->{$input}->{$key}));
# Line 1031  sub lookup { Line 1136  sub lookup {
1136    
1137          foreach my $h ( @having ) {          foreach my $h ( @having ) {
1138                  if (defined($lookup->{$database}->{$input}->{$key}->{$h})) {                  if (defined($lookup->{$database}->{$input}->{$key}->{$h})) {
1139                          warn "lookup for $database/$input/$key/$h return ",dump($lookup->{$database}->{$input}->{$key}->{$h}),"\n";                          warn "lookup for $database/$input/$key/$h return ",dump($lookup->{$database}->{$input}->{$key}->{$h}),"\n" if ($debug);
1140                          $mfns->{$_}++ foreach keys %{ $lookup->{$database}->{$input}->{$key}->{$h} };                          $mfns->{$_}++ foreach keys %{ $lookup->{$database}->{$input}->{$key}->{$h} };
1141                  }                  }
1142          }          }
# Line 1040  sub lookup { Line 1145  sub lookup {
1145    
1146          my @mfns = sort keys %$mfns;          my @mfns = sort keys %$mfns;
1147    
1148          warn "# lookup loading $database/$input/$key mfn ", join(",",@mfns)," having ",dump(@having),"\n";          warn "# lookup loading $database/$input/$key mfn ", join(",",@mfns)," having ",dump(@having),"\n" if ($debug);
1149    
1150          my $old_rec = $rec;          my $old_rec = $rec;
1151          my @out;          my @out;
# Line 1048  sub lookup { Line 1153  sub lookup {
1153          foreach my $mfn (@mfns) {          foreach my $mfn (@mfns) {
1154                  $rec = $load_row_coderef->( $database, $input, $mfn );                  $rec = $load_row_coderef->( $database, $input, $mfn );
1155    
1156                  warn "got $database/$input/$mfn = ", dump($rec), $/;                  warn "got $database/$input/$mfn = ", dump($rec), $/ if ($debug);
1157    
1158                  my @vals = $what->();                  my @vals = $what->();
1159    
1160                  push @out, ( @vals );                  push @out, ( @vals );
1161    
1162                  warn "lookup for mfn $mfn returned ", dump(@vals), $/;                  warn "lookup for mfn $mfn returned ", dump(@vals), $/ if ($debug);
1163          }          }
1164    
1165  #       if (ref($lookup->{$k}) eq 'ARRAY') {  #       if (ref($lookup->{$k}) eq 'ARRAY') {
# Line 1065  sub lookup { Line 1170  sub lookup {
1170    
1171          $rec = $old_rec;          $rec = $old_rec;
1172    
1173          warn "## lookup returns = ", dump(@out), $/;          warn "## lookup returns = ", dump(@out), $/ if ($debug);
1174    
1175          if ($#out == 0) {          if ($#out == 0) {
1176                  return $out[0];                  return $out[0];
# Line 1243  sub split_rec_on { Line 1348  sub split_rec_on {
1348          }          }
1349  }  }
1350    
1351    my $hash;
1352    
1353    =head2 set
1354    
1355      set( key => 'value' );
1356    
1357    =cut
1358    
1359    sub set {
1360            my ($k,$v) = @_;
1361            warn "## set ( $k => ", dump($v), " )", $/ if ( $debug );
1362            $hash->{$k} = $v;
1363    };
1364    
1365    =head2 get
1366    
1367      get( 'key' );
1368    
1369    =cut
1370    
1371    sub get {
1372            my $k = shift || return;
1373            my $v = $hash->{$k};
1374            warn "## get $k = ", dump( $v ), $/ if ( $debug );
1375            return $v;
1376    }
1377    
1378    =head2 count
1379    
1380      if ( count( @result ) == 1 ) {
1381            # do something if only 1 result is there
1382      }
1383    
1384    =cut
1385    
1386    sub count {
1387            warn "## count ",dump(@_),$/ if ( $debug );
1388            return @_ . '';
1389    }
1390    
1391  # END  # END
1392  1;  1;

Legend:
Removed from v.741  
changed lines
  Added in v.889

  ViewVC Help
Powered by ViewVC 1.1.26