/[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 812 by dpavlin, Sun Apr 1 21:47:42 2007 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 42  WebPAC::Normalize - describe normalisato Line 42  WebPAC::Normalize - describe normalisato
42    
43  =head1 VERSION  =head1 VERSION
44    
45  Version 0.26  Version 0.29
46    
47  =cut  =cut
48    
49  our $VERSION = '0.26';  our $VERSION = '0.29';
50    
51  =head1 SYNOPSIS  =head1 SYNOPSIS
52    
# Line 289  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 304  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 327  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 408  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 490  sub marc_leader { Line 505  sub marc_leader {
505          my ($offset,$value) = @_;          my ($offset,$value) = @_;
506    
507          if ($offset) {          if ($offset) {
508                  $marc_leader->{ $offset } = $value;                  $marc_leader->[ $marc_record_offset ]->{ $offset } = $value;
509          } else {          } else {
510                  return $marc_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 624  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 774  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 796  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 945  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 958  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 971  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    

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

  ViewVC Help
Powered by ViewVC 1.1.26