/[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 554 by dpavlin, Sat Jul 1 10:19:29 2006 UTC revision 571 by dpavlin, Mon Jul 3 14:30:22 2006 UTC
# Line 7  use Exporter 'import'; Line 7  use Exporter 'import';
7    
8          tag search display          tag search display
9          marc marc_indicators marc_repeatable_subfield          marc marc_indicators marc_repeatable_subfield
10            marc_compose marc_leader
11    
12          rec1 rec2 rec          rec1 rec2 rec
13          regex prefix suffix surround          regex prefix suffix surround
14          first lookup join_with          first lookup join_with
15    
16            split_rec_on
17  /;  /;
18    
19  use warnings;  use warnings;
# Line 30  WebPAC::Normalize - describe normalisato Line 33  WebPAC::Normalize - describe normalisato
33    
34  =head1 VERSION  =head1 VERSION
35    
36  Version 0.07  Version 0.09
37    
38  =cut  =cut
39    
40  our $VERSION = '0.07';  our $VERSION = '0.09';
41    
42  =head1 SYNOPSIS  =head1 SYNOPSIS
43    
# Line 193  sub _get_marc_fields { Line 196  sub _get_marc_fields {
196                  $a->[0] . $a->[3] cmp $b->[0] . $b->[3]                  $a->[0] . $a->[3] cmp $b->[0] . $b->[3]
197          } @{ $marc_record };          } @{ $marc_record };
198    
199            @sorted_marc_record = @{ $marc_record };        ### FIXME disable sorting
200            
201          # output marc fields          # output marc fields
202          my @m;          my @m;
203    
# Line 294  Change level of debug warnings Line 299  Change level of debug warnings
299  sub _debug {  sub _debug {
300          my $l = shift;          my $l = shift;
301          return $debug unless defined($l);          return $debug unless defined($l);
302            warn "debug level $l",$/ if ($l > 0);
303          $debug = $l;          $debug = $l;
304  }  }
305    
# Line 351  sub search { Line 357  sub search {
357          $out->{$name}->{search} = \@o;          $out->{$name}->{search} = \@o;
358  }  }
359    
360    =head2 marc_leader
361    
362    Setup fields within MARC leader or get leader
363    
364      marc_leader('05','c');
365      my $leader = marc_leader();
366    
367    =cut
368    
369    sub marc_leader {
370            my ($offset,$value) = @_;
371    
372            if ($offset) {
373                    $out->{' leader'}->{ $offset } = $value;
374            } else {
375                    return $out->{' leader'};
376            }
377    }
378    
379  =head2 marc  =head2 marc
380    
381  Save value for MARC field  Save value for MARC field
382    
383    marc('900','a', rec('200','a') );    marc('900','a', rec('200','a') );
384      marc('001', rec('000') );
385    
386  =cut  =cut
387    
# Line 363  sub marc { Line 389  sub marc {
389          my $f = shift or die "marc needs field";          my $f = shift or die "marc needs field";
390          die "marc field must be numer" unless ($f =~ /^\d+$/);          die "marc field must be numer" unless ($f =~ /^\d+$/);
391    
392          my $sf = shift or die "marc needs subfield";          my $sf;
393            if ($f >= 10) {
394                    $sf = shift or die "marc needs subfield";
395            }
396    
397          foreach (@_) {          foreach (@_) {
398                  my $v = $_;             # make var read-write for Encode                  my $v = $_;             # make var read-write for Encode
399                  next unless (defined($v) && $v !~ /^\s*$/);                  next unless (defined($v) && $v !~ /^\s*$/);
400                  from_to($v, 'iso-8859-2', $marc_encoding) if ($marc_encoding);                  from_to($v, 'iso-8859-2', $marc_encoding) if ($marc_encoding);
401                  my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');                  my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');
402                  push @{ $marc_record }, [ $f, $i1, $i2, $sf => $v ];                  if (defined $sf) {
403                            push @{ $marc_record }, [ $f, $i1, $i2, $sf => $v ];
404                    } else {
405                            push @{ $marc_record }, [ $f, $v ];
406                    }
407          }          }
408  }  }
409    
# Line 410  sub marc_indicators { Line 443  sub marc_indicators {
443          @{ $marc_indicators->{$f} } = ($i1,$i2);          @{ $marc_indicators->{$f} } = ($i1,$i2);
444  }  }
445    
446    =head2 marc_compose
447    
448    Save values for each MARC subfield explicitly
449    
450      marc_compose('900',
451            'a', rec('200','a')
452            'b', rec('201','a')
453            'a', rec('200','b')
454            'c', rec('200','c')
455      );
456    
457    =cut
458    
459    sub marc_compose {
460            my $f = shift or die "marc_compose needs field";
461            die "marc_compose field must be numer" unless ($f =~ /^\d+$/);
462    
463            my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');
464            my $m = [ $f, $i1, $i2 ];
465    
466            while (@_) {
467                    my $sf = shift or die "marc_compose $f needs subfield";
468                    my $v = shift;
469    
470                    next unless (defined($v) && $v !~ /^\s*$/);
471                    from_to($v, 'iso-8859-2', $marc_encoding) if ($marc_encoding);
472                    push @$m, ( $sf, $v );
473                    warn "## ++ marc_compose($f,$sf,$v) ", dump( $m ),$/ if ($debug > 1);
474            }
475    
476            warn "## marc_compose(d) ", dump( $m ),$/ if ($debug > 1);
477    
478            push @{ $marc_record }, $m if ($#{$m} > 2);
479    }
480    
481    
482  =head1 Functions to extract data from input  =head1 Functions to extract data from input
483    
# Line 428  TODO: order of values is probably same a Line 496  TODO: order of values is probably same a
496    
497  sub rec1 {  sub rec1 {
498          my $f = shift;          my $f = shift;
499            warn "rec1($f) = ", dump( $rec->{$f} ), $/ if ($debug > 1);
500          return unless (defined($rec) && defined($rec->{$f}));          return unless (defined($rec) && defined($rec->{$f}));
501            warn "rec1($f) = ", dump( $rec->{$f} ), $/ if ($debug > 1);
502          if (ref($rec->{$f}) eq 'ARRAY') {          if (ref($rec->{$f}) eq 'ARRAY') {
503                  return map {                  return map {
504                          if (ref($_) eq 'HASH') {                          if (ref($_) eq 'HASH') {
# Line 579  sub join_with { Line 649  sub join_with {
649          return join($d, grep { defined($_) && $_ ne '' } @_);          return join($d, grep { defined($_) && $_ ne '' } @_);
650  }  }
651    
652    =head2 split_rec_on
653    
654    Split record subfield on some regex and take one of parts out
655    
656      $a_before_semi_column =
657            split_rec_on('200','a', /\s*;\s*/, $part);
658    
659    C<$part> is optional number of element. First element is
660    B<1>, not 0!
661    
662    If there is no C<$part> parameter or C<$part> is 0, this function will
663    return all values produced by splitting.
664    
665    =cut
666    
667    sub split_rec_on {
668            die "split_rec_on need (fld,sf,regex[,part]" if ($#_ < 2);
669    
670            my ($fld, $sf, $regex, $part) = @_;
671            warn "### regex ", ref($regex), $regex, $/ if ($debug > 2);
672    
673            my @r = rec( $fld, $sf );
674            my $v = shift @r;
675            warn "### first rec($fld,$sf) = ",dump($v),$/ if ($debug > 2);
676    
677            return '' if( ! defined($v) || $v =~ /^\s*$/);
678    
679            my @s = split( $regex, $v );
680            warn "## split_rec_on($fld,$sf,$regex,$part) = ",dump(@s),$/ if ($debug > 1);
681            if ($part && $part > 0) {
682                    return $s[ $part - 1 ];
683            } else {
684                    return @s;
685            }
686    }
687    
688  # END  # END
689  1;  1;
Legend:
Removed from v.554  
changed lines
  Added in v.571
  ViewVC Help
Powered by ViewVC 1.1.26