/[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 618 by dpavlin, Fri Aug 25 12:31:01 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 641  sub marc_remove { Line 642  sub marc_remove {
642          warn "## full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 1);          warn "## full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 1);
643  }  }
644    
645    =head2 marc_original_order
646    
647    Copy all subfields preserving original order to marc field.
648    
649      marc_original_order( marc_field_number, original_input_field_number );
650    
651    Please note that field numbers are consistent with other commands (marc
652    field number first), but somewhat counter-intuitive (destination and then
653    source).
654    
655    You might want to use this command if you are just renaming subfields or
656    using pre-processing modify_record in C<config.yml> and don't need any
657    post-processing or want to preserve order of original subfields.
658    
659    
660    =cut
661    
662    sub marc_original_order {
663    
664            my ($to, $from) = @_;
665            die "marc_original_order needs from and to fields\n" unless ($from && $to);
666    
667            return unless defined($rec->{$from});
668    
669            my $r = $rec->{$from};
670            die "record field $from isn't array\n" unless (ref($r) eq 'ARRAY');
671    
672            my ($i1,$i2) = defined($marc_indicators->{$to}) ? @{ $marc_indicators->{$to} } : (' ',' ');
673            warn "## marc_original_order($to,$from) source = ", dump( $r ),$/ if ($debug > 1);
674    
675            foreach my $d (@$r) {
676    
677                    if (! defined($d->{subfields}) && ref($d->{subfields}) ne 'ARRAY') {
678                            warn "# marc_original_order($to,$from): field $from doesn't have subfields specification\n";
679                            next;
680                    }
681            
682                    my @sfs = @{ $d->{subfields} };
683    
684                    die "field $from doesn't have even number of subfields specifications\n" unless($#sfs % 2 == 1);
685    
686                    warn "#--> d: ",dump($d), "\n#--> sfs: ",dump(@sfs),$/ if ($debug > 2);
687    
688                    my $m = [ $to, $i1, $i2 ];
689    
690                    while (my $sf = shift @sfs) {
691    
692                            warn "#--> sf: ",dump($sf), $/ if ($debug > 2);
693                            my $offset = shift @sfs;
694                            die "corrupted sufields specification for field $from\n" unless defined($offset);
695    
696                            my $v;
697                            if (ref($d->{$sf}) eq 'ARRAY') {
698                                    $v = $d->{$sf}->[$offset] if (defined($d->{$sf}->[$offset]));
699                            } elsif ($offset == 0) {
700                                    $v = $d->{$sf};
701                            } else {
702                                    die "field $from subfield '$sf' need occurence $offset which doesn't exist", dump($d->{$sf});
703                            }
704                            push @$m, ( $sf, $v ) if (defined($v));
705                    }
706    
707                    if ($#{$m} > 2) {
708                            push @{ $marc_record->[ $marc_record_offset ] }, $m;
709                    }
710            }
711    
712            warn "## marc_record = ", dump( $marc_record ),$/ if ($debug > 1);
713    }
714    
715    
716  =head1 Functions to extract data from input  =head1 Functions to extract data from input
717    
718  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 996  sub split_rec_on {
996          my $v = shift @r;          my $v = shift @r;
997          warn "### first rec($fld,$sf) = ",dump($v),$/ if ($debug > 2);          warn "### first rec($fld,$sf) = ",dump($v),$/ if ($debug > 2);
998    
999          return '' if( ! defined($v) || $v =~ /^\s*$/);          return '' if ( ! defined($v) || $v =~ /^\s*$/);
1000    
1001          my @s = split( $regex, $v );          my @s = split( $regex, $v );
1002          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.618
  ViewVC Help
Powered by ViewVC 1.1.26