/[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 813 by dpavlin, Sun Apr 1 21:47:47 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_count          marc_duplicate marc_remove marc_count
14          marc_original_order          marc_original_order
15    
# Line 42  WebPAC::Normalize - describe normalisato Line 42  WebPAC::Normalize - describe normalisato
42    
43  =head1 VERSION  =head1 VERSION
44    
45  Version 0.27  Version 0.29
46    
47  =cut  =cut
48    
49  our $VERSION = '0.27';  our $VERSION = '0.29';
50    
51  =head1 SYNOPSIS  =head1 SYNOPSIS
52    
# Line 517  sub marc_leader { Line 517  sub marc_leader {
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    
563  =head2 marc  =head2 marc
564    
565  Save value for MARC field  Save value for MARC field
# Line 831  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 980  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 993  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 1006  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.813  
changed lines
  Added in v.889

  ViewVC Help
Powered by ViewVC 1.1.26