/[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 603 by dpavlin, Sun Jul 23 20:19:56 2006 UTC revision 619 by dpavlin, Fri Aug 25 12:31:06 2006 UTC
# Line 9  use Exporter 'import'; Line 9  use Exporter 'import';
9          marc marc_indicators marc_repeatable_subfield          marc marc_indicators marc_repeatable_subfield
10          marc_compose marc_leader          marc_compose marc_leader
11          marc_duplicate marc_remove          marc_duplicate marc_remove
12            marc_original_order
13    
14          rec1 rec2 rec          rec1 rec2 rec
15          regex prefix suffix surround          regex prefix suffix surround
# Line 35  WebPAC::Normalize - describe normalisato Line 36  WebPAC::Normalize - describe normalisato
36    
37  =head1 VERSION  =head1 VERSION
38    
39  Version 0.15  Version 0.16
40    
41  =cut  =cut
42    
43  our $VERSION = '0.15';  our $VERSION = '0.16';
44    
45  =head1 SYNOPSIS  =head1 SYNOPSIS
46    
# Line 539  sub marc_compose { Line 540  sub marc_compose {
540    
541          warn "### marc_compose input subfields = ", dump(@_),$/ if ($debug > 2);          warn "### marc_compose input subfields = ", dump(@_),$/ if ($debug > 2);
542    
543            if ($#_ % 2 != 1) {
544                    die "ERROR: marc_compose",dump($f,@_)," not valid (must be even).\nDo you need to add first() or join() around some argument?\n";
545            }
546    
547          while (@_) {          while (@_) {
548                  my $sf = shift or die "marc_compose $f needs subfield";                  my $sf = shift;
549                  my $v = shift;                  my $v = shift;
550    
551                  next unless (defined($v) && $v !~ /^\s*$/);                  next unless (defined($v) && $v !~ /^\s*$/);
# Line 641  sub marc_remove { Line 646  sub marc_remove {
646          warn "## full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 1);          warn "## full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 1);
647  }  }
648    
649    =head2 marc_original_order
650    
651    Copy all subfields preserving original order to marc field.
652    
653      marc_original_order( marc_field_number, original_input_field_number );
654    
655    Please note that field numbers are consistent with other commands (marc
656    field number first), but somewhat counter-intuitive (destination and then
657    source).
658    
659    You might want to use this command if you are just renaming subfields or
660    using pre-processing modify_record in C<config.yml> and don't need any
661    post-processing or want to preserve order of original subfields.
662    
663    
664    =cut
665    
666    sub marc_original_order {
667    
668            my ($to, $from) = @_;
669            die "marc_original_order needs from and to fields\n" unless ($from && $to);
670    
671            return unless defined($rec->{$from});
672    
673            my $r = $rec->{$from};
674            die "record field $from isn't array\n" unless (ref($r) eq 'ARRAY');
675    
676            my ($i1,$i2) = defined($marc_indicators->{$to}) ? @{ $marc_indicators->{$to} } : (' ',' ');
677            warn "## marc_original_order($to,$from) source = ", dump( $r ),$/ if ($debug > 1);
678    
679            foreach my $d (@$r) {
680    
681                    if (! defined($d->{subfields}) && ref($d->{subfields}) ne 'ARRAY') {
682                            warn "# marc_original_order($to,$from): field $from doesn't have subfields specification\n";
683                            next;
684                    }
685            
686                    my @sfs = @{ $d->{subfields} };
687    
688                    die "field $from doesn't have even number of subfields specifications\n" unless($#sfs % 2 == 1);
689    
690                    warn "#--> d: ",dump($d), "\n#--> sfs: ",dump(@sfs),$/ if ($debug > 2);
691    
692                    my $m = [ $to, $i1, $i2 ];
693    
694                    while (my $sf = shift @sfs) {
695    
696                            warn "#--> sf: ",dump($sf), $/ if ($debug > 2);
697                            my $offset = shift @sfs;
698                            die "corrupted sufields specification for field $from\n" unless defined($offset);
699    
700                            my $v;
701                            if (ref($d->{$sf}) eq 'ARRAY') {
702                                    $v = $d->{$sf}->[$offset] if (defined($d->{$sf}->[$offset]));
703                            } elsif ($offset == 0) {
704                                    $v = $d->{$sf};
705                            } else {
706                                    die "field $from subfield '$sf' need occurence $offset which doesn't exist", dump($d->{$sf});
707                            }
708                            push @$m, ( $sf, $v ) if (defined($v));
709                    }
710    
711                    if ($#{$m} > 2) {
712                            push @{ $marc_record->[ $marc_record_offset ] }, $m;
713                    }
714            }
715    
716            warn "## marc_record = ", dump( $marc_record ),$/ if ($debug > 1);
717    }
718    
719    
720  =head1 Functions to extract data from input  =head1 Functions to extract data from input
721    
722  This function should be used inside functions to create C<data_structure> described  This function should be used inside functions to create C<data_structure> described
# Line 924  sub split_rec_on { Line 1000  sub split_rec_on {
1000          my $v = shift @r;          my $v = shift @r;
1001          warn "### first rec($fld,$sf) = ",dump($v),$/ if ($debug > 2);          warn "### first rec($fld,$sf) = ",dump($v),$/ if ($debug > 2);
1002    
1003          return '' if( ! defined($v) || $v =~ /^\s*$/);          return '' if ( ! defined($v) || $v =~ /^\s*$/);
1004    
1005          my @s = split( $regex, $v );          my @s = split( $regex, $v );
1006          warn "## split_rec_on($fld,$sf,$regex,$part) = ",dump(@s),$/ if ($debug > 1);          warn "## split_rec_on($fld,$sf,$regex,$part) = ",dump(@s),$/ if ($debug > 1);

Legend:
Removed from v.603  
changed lines
  Added in v.619

  ViewVC Help
Powered by ViewVC 1.1.26