/[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 740 by dpavlin, Sat Oct 7 16:33:37 2006 UTC revision 810 by dpavlin, Sun Apr 1 21:47:38 2007 UTC
# 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.26
46    
47  =cut  =cut
48    
49  our $VERSION = '0.22';  our $VERSION = '0.26';
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);  my ($out, $marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators, $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) = ();          ($out,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators, $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 487  sub marc_leader { Line 490  sub marc_leader {
490          my ($offset,$value) = @_;          my ($offset,$value) = @_;
491    
492          if ($offset) {          if ($offset) {
493                  $out->{' leader'}->{ $offset } = $value;                  $leader->{ $offset } = $value;
494          } else {          } else {
495                  return $out->{' leader'};                  return $leader;
496          }          }
497  }  }
498    
# Line 635  Remove some field or subfield from MARC Line 638  Remove some field or subfield from MARC
638    
639  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.
640    
641      marc_remove('*');
642    
643    Will remove all fields in current MARC record.
644    
645  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
646  should probably just remove that subfield definition if you are not  should probably just remove that subfield definition if you are not
647  using C<marc_duplicate>).  using C<marc_duplicate>).
# Line 652  sub marc_remove { Line 659  sub marc_remove {
659    
660          warn "### marc_remove before = ", dump( $marc ), $/ if ($debug > 2);          warn "### marc_remove before = ", dump( $marc ), $/ if ($debug > 2);
661    
662          my $i = 0;          if ($f eq '*') {
663          foreach ( 0 .. $#{ $marc } ) {  
664                  last unless (defined $marc->[$i]);                  delete( $marc_record->[ $marc_record_offset ] );
665                  warn "#### working on ",dump( @{ $marc->[$i] }), $/ if ($debug > 3);                  warn "## full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 1);
666                  if ($marc->[$i]->[0] eq $f) {  
667                          if (! defined $sf) {          } else {
668                                  # remove whole field  
669                                  splice @$marc, $i, 1;                  my $i = 0;
670                                  warn "#### slice \@\$marc, $i, 1 = ",dump( @{ $marc }), $/ if ($debug > 3);                  foreach ( 0 .. $#{ $marc } ) {
671                                  $i--;                          last unless (defined $marc->[$i]);
672                          } else {                          warn "#### working on ",dump( @{ $marc->[$i] }), $/ if ($debug > 3);
673                                  foreach my $j ( 0 .. (( $#{ $marc->[$i] } - 3 ) / 2) ) {                          if ($marc->[$i]->[0] eq $f) {
674                                          my $o = ($j * 2) + 3;                                  if (! defined $sf) {
675                                          if ($marc->[$i]->[$o] eq $sf) {                                          # remove whole field
676                                                  # remove subfield                                          splice @$marc, $i, 1;
677                                                  splice @{$marc->[$i]}, $o, 2;                                          warn "#### slice \@\$marc, $i, 1 = ",dump( @{ $marc }), $/ if ($debug > 3);
678                                                  warn "#### slice \@{\$marc->[$i]}, $o, 2 = ", dump( @{ $marc }), $/ if ($debug > 3);                                          $i--;
679                                                  # is record now empty?                                  } else {
680                                                  if ($#{ $marc->[$i] } == 2) {                                          foreach my $j ( 0 .. (( $#{ $marc->[$i] } - 3 ) / 2) ) {
681                                                          splice @$marc, $i, 1;                                                  my $o = ($j * 2) + 3;
682                                                          warn "#### slice \@\$marc, $i, 1 = ", dump( @{ $marc }), $/ if ($debug > 3);                                                  if ($marc->[$i]->[$o] eq $sf) {
683                                                          $i--;                                                          # remove subfield
684                                                  };                                                          splice @{$marc->[$i]}, $o, 2;
685                                                            warn "#### slice \@{\$marc->[$i]}, $o, 2 = ", dump( @{ $marc }), $/ if ($debug > 3);
686                                                            # is record now empty?
687                                                            if ($#{ $marc->[$i] } == 2) {
688                                                                    splice @$marc, $i, 1;
689                                                                    warn "#### slice \@\$marc, $i, 1 = ", dump( @{ $marc }), $/ if ($debug > 3);
690                                                                    $i--;
691                                                            };
692                                                    }
693                                          }                                          }
694                                  }                                  }
695                          }                          }
696                            $i++;
697                  }                  }
                 $i++;  
         }  
698    
699          warn "### marc_remove($f", $sf ? ",$sf" : "", ") after = ", dump( $marc ), $/ if ($debug > 2);                  warn "### marc_remove($f", $sf ? ",$sf" : "", ") after = ", dump( $marc ), $/ if ($debug > 2);
700    
701          $marc_record->[ $marc_record_offset ] = $marc;                  $marc_record->[ $marc_record_offset ] = $marc;
702            }
703    
704          warn "## full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 1);          warn "## full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 1);
705  }  }
# Line 880  syntaxtic sugar for Line 895  syntaxtic sugar for
895    @v = rec('200')    @v = rec('200')
896    @v = rec('200','a')    @v = rec('200','a')
897    
898    If rec() returns just single value, it will
899    return scalar, not array.
900    
901  =cut  =cut
902    
903  sub rec {  sub rec {
# Line 889  sub rec { Line 907  sub rec {
907          } elsif ($#_ == 1) {          } elsif ($#_ == 1) {
908                  @out = rec2(@_);                  @out = rec2(@_);
909          }          }
910          if (@out) {          if ($#out == 0 && ! wantarray) {
911                    return $out[0];
912            } elsif (@out) {
913                  return @out;                  return @out;
914          } else {          } else {
915                  return '';                  return '';
# Line 1017  Easy as pie, right? Line 1037  Easy as pie, right?
1037  sub lookup {  sub lookup {
1038          my ($what, $database, $input, $key, $having) = @_;          my ($what, $database, $input, $key, $having) = @_;
1039    
1040          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);
1041    
1042          warn "## lookup ($database, $input, $key)", $/ if ($debug > 1);          warn "## lookup ($database, $input, $key)", $/ if ($debug > 1);
1043          return unless (defined($lookup->{$database}->{$input}->{$key}));          return unless (defined($lookup->{$database}->{$input}->{$key}));
# Line 1031  sub lookup { Line 1051  sub lookup {
1051    
1052          foreach my $h ( @having ) {          foreach my $h ( @having ) {
1053                  if (defined($lookup->{$database}->{$input}->{$key}->{$h})) {                  if (defined($lookup->{$database}->{$input}->{$key}->{$h})) {
1054                          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);
1055                          $mfns->{$_}++ foreach keys %{ $lookup->{$database}->{$input}->{$key}->{$h} };                          $mfns->{$_}++ foreach keys %{ $lookup->{$database}->{$input}->{$key}->{$h} };
1056                  }                  }
1057          }          }
# Line 1040  sub lookup { Line 1060  sub lookup {
1060    
1061          my @mfns = sort keys %$mfns;          my @mfns = sort keys %$mfns;
1062    
1063          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);
1064    
1065          my $old_rec = $rec;          my $old_rec = $rec;
1066          my @out;          my @out;
# Line 1048  sub lookup { Line 1068  sub lookup {
1068          foreach my $mfn (@mfns) {          foreach my $mfn (@mfns) {
1069                  $rec = $load_row_coderef->( $database, $input, $mfn );                  $rec = $load_row_coderef->( $database, $input, $mfn );
1070    
1071                  warn "got $database/$input/$mfn = ", dump($rec), $/;                  warn "got $database/$input/$mfn = ", dump($rec), $/ if ($debug);
1072    
1073                  my @vals = $what->();                  my @vals = $what->();
1074    
1075                  push @out, ( @vals );                  push @out, ( @vals );
1076    
1077                  warn "lookup for mfn $mfn returned ", dump(@vals), $/;                  warn "lookup for mfn $mfn returned ", dump(@vals), $/ if ($debug);
1078          }          }
1079    
1080  #       if (ref($lookup->{$k}) eq 'ARRAY') {  #       if (ref($lookup->{$k}) eq 'ARRAY') {
# Line 1065  sub lookup { Line 1085  sub lookup {
1085    
1086          $rec = $old_rec;          $rec = $old_rec;
1087    
1088          warn "## lookup returns = ", dump(@out), $/;          warn "## lookup returns = ", dump(@out), $/ if ($debug);
1089    
1090          if ($#out == 0) {          if ($#out == 0) {
1091                  return $out[0];                  return $out[0];
# Line 1243  sub split_rec_on { Line 1263  sub split_rec_on {
1263          }          }
1264  }  }
1265    
1266    my $hash;
1267    
1268    =head2 set
1269    
1270      set( key => 'value' );
1271    
1272    =cut
1273    
1274    sub set {
1275            my ($k,$v) = @_;
1276            warn "## set ( $k => ", dump($v), " )", $/ if ( $debug );
1277            $hash->{$k} = $v;
1278    };
1279    
1280    =head2 get
1281    
1282      get( 'key' );
1283    
1284    =cut
1285    
1286    sub get {
1287            my $k = shift || return;
1288            my $v = $hash->{$k};
1289            warn "## get $k = ", dump( $v ), $/ if ( $debug );
1290            return $v;
1291    }
1292    
1293    =head2 count
1294    
1295      if ( count( @result ) == 1 ) {
1296            # do something if only 1 result is there
1297      }
1298    
1299    =cut
1300    
1301    sub count {
1302            warn "## count ",dump(@_),$/ if ( $debug );
1303            return @_ . '';
1304    }
1305    
1306  # END  # END
1307  1;  1;

Legend:
Removed from v.740  
changed lines
  Added in v.810

  ViewVC Help
Powered by ViewVC 1.1.26