/[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 616 by dpavlin, Wed Aug 23 14:29:43 2006 UTC revision 669 by dpavlin, Mon Sep 11 14:29:01 2006 UTC
# Line 4  use Exporter 'import'; Line 4  use Exporter 'import';
4          _set_rec _set_lookup          _set_rec _set_lookup
5          _get_ds _clean_ds          _get_ds _clean_ds
6          _debug          _debug
7            _pack_subfields_hash
8    
9          tag search display          tag search display
10          marc marc_indicators marc_repeatable_subfield          marc marc_indicators marc_repeatable_subfield
# Line 23  use strict; Line 24  use strict;
24    
25  #use base qw/WebPAC::Common/;  #use base qw/WebPAC::Common/;
26  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
 use Encode qw/from_to/;  
27  use Storable qw/dclone/;  use Storable qw/dclone/;
28    
29  # debugging warn(s)  # debugging warn(s)
# Line 36  WebPAC::Normalize - describe normalisato Line 36  WebPAC::Normalize - describe normalisato
36    
37  =head1 VERSION  =head1 VERSION
38    
39  Version 0.16  Version 0.19
40    
41  =cut  =cut
42    
43  our $VERSION = '0.16';  our $VERSION = '0.19';
44    
45  =head1 SYNOPSIS  =head1 SYNOPSIS
46    
# Line 469  sub marc { Line 469  sub marc {
469          foreach (@_) {          foreach (@_) {
470                  my $v = $_;             # make var read-write for Encode                  my $v = $_;             # make var read-write for Encode
471                  next unless (defined($v) && $v !~ /^\s*$/);                  next unless (defined($v) && $v !~ /^\s*$/);
                 from_to($v, 'iso-8859-2', $marc_encoding) if ($marc_encoding);  
472                  my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');                  my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');
473                  if (defined $sf) {                  if (defined $sf) {
474                          push @{ $marc_record->[ $marc_record_offset ] }, [ $f, $i1, $i2, $sf => $v ];                          push @{ $marc_record->[ $marc_record_offset ] }, [ $f, $i1, $i2, $sf => $v ];
# Line 540  sub marc_compose { Line 539  sub marc_compose {
539    
540          warn "### marc_compose input subfields = ", dump(@_),$/ if ($debug > 2);          warn "### marc_compose input subfields = ", dump(@_),$/ if ($debug > 2);
541    
542            if ($#_ % 2 != 1) {
543                    die "ERROR: marc_compose",dump($f,@_)," not valid (must be even).\nDo you need to add first() or join() around some argument?\n";
544            }
545    
546          while (@_) {          while (@_) {
547                  my $sf = shift or die "marc_compose $f needs subfield";                  my $sf = shift;
548                  my $v = shift;                  my $v = shift;
549    
550                  next unless (defined($v) && $v !~ /^\s*$/);                  next unless (defined($v) && $v !~ /^\s*$/);
                 from_to($v, 'iso-8859-2', $marc_encoding) if ($marc_encoding);  
551                  warn "## ++ marc_compose($f,$sf,$v) ", dump( $m ),$/ if ($debug > 1);                  warn "## ++ marc_compose($f,$sf,$v) ", dump( $m ),$/ if ($debug > 1);
552                  if ($sf ne '+') {                  if ($sf ne '+') {
553                          push @$m, ( $sf, $v );                          push @$m, ( $sf, $v );
# Line 683  sub marc_original_order { Line 685  sub marc_original_order {
685    
686                  die "field $from doesn't have even number of subfields specifications\n" unless($#sfs % 2 == 1);                  die "field $from doesn't have even number of subfields specifications\n" unless($#sfs % 2 == 1);
687    
688  warn "#--> d: ",dump($d), "\n#--> sfs: ",dump(@sfs),$/;                  warn "#--> d: ",dump($d), "\n#--> sfs: ",dump(@sfs),$/ if ($debug > 2);
689    
690                  my $m = [ $to, $i1, $i2 ];                  my $m = [ $to, $i1, $i2 ];
691    
692                  while (my $sf = shift @sfs) {                  while (my $sf = shift @sfs) {
693  warn "#--> sf: ",dump($sf), $/;  
694                            warn "#--> sf: ",dump($sf), $/ if ($debug > 2);
695                          my $offset = shift @sfs;                          my $offset = shift @sfs;
696                          die "corrupted sufields specification for field $from\n" unless defined($offset);                          die "corrupted sufields specification for field $from\n" unless defined($offset);
697    
# Line 709  warn "#--> sf: ",dump($sf), $/; Line 712  warn "#--> sf: ",dump($sf), $/;
712          }          }
713    
714          warn "## marc_record = ", dump( $marc_record ),$/ if ($debug > 1);          warn "## marc_record = ", dump( $marc_record ),$/ if ($debug > 1);
   
         warn "# marc_original_order is partly implemented";  
715  }  }
716    
717    
# Line 719  warn "#--> sf: ",dump($sf), $/; Line 720  warn "#--> sf: ",dump($sf), $/;
720  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
721  above.  above.
722    
723    =head2 _pack_subfields_hash
724    
725     @subfields = _pack_subfields_hash( $h );
726     $subfields = _pack_subfields_hash( $h, 1 );
727    
728    Return each subfield value in array or pack them all together and return scalar
729    with subfields (denoted by C<^>) and values.
730    
731    =cut
732    
733    sub _pack_subfields_hash {
734    
735            warn "## _pack_subfields_hash( ",dump(@_), " )\n" if ($debug > 1);
736    
737            my ($h,$include_subfields) = @_;
738    
739            if ( defined($h->{subfields}) ) {
740                    my $sfs = delete $h->{subfields} || die "no subfields?";
741                    my @out;
742                    while (@$sfs) {
743                            my $sf = shift @$sfs;
744                            push @out, '^' . $sf if ($include_subfields);
745                            my $o = shift @$sfs;
746                            if ($o == 0 && ref( $h->{$sf} ) ne 'ARRAY' ) {
747                                    # single element subfields are not arrays
748    #warn "====> $sf $o / $#$sfs ", dump( $sfs, $h->{$sf} ), "\n";
749    
750                                    push @out, $h->{$sf};
751                            } else {
752    #warn "====> $sf $o / $#$sfs ", dump( $sfs, $h->{$sf} ), "\n";
753                                    push @out, $h->{$sf}->[$o];
754                            }
755                    }
756                    if ($include_subfields) {
757                            return join('', @out);
758                    } else {
759                            return @out;
760                    }
761            } else {
762                    if ($include_subfields) {
763                            my $out = '';
764                            foreach my $sf (sort keys %$h) {
765                                    if (ref($h->{$sf}) eq 'ARRAY') {
766                                            $out .= '^' . $sf . join('^' . $sf, @{ $h->{$sf} });
767                                    } else {
768                                            $out .= '^' . $sf . $h->{$sf};
769                                    }
770                            }
771                            return $out;
772                    } else {
773                            # FIXME this should probably be in alphabetical order instead of hash order
774                            values %{$h};
775                    }
776            }
777    }
778    
779  =head2 rec1  =head2 rec1
780    
781  Return all values in some field  Return all values in some field
# Line 735  sub rec1 { Line 792  sub rec1 {
792          return unless (defined($rec) && defined($rec->{$f}));          return unless (defined($rec) && defined($rec->{$f}));
793          warn "rec1($f) = ", dump( $rec->{$f} ), $/ if ($debug > 1);          warn "rec1($f) = ", dump( $rec->{$f} ), $/ if ($debug > 1);
794          if (ref($rec->{$f}) eq 'ARRAY') {          if (ref($rec->{$f}) eq 'ARRAY') {
795                  return map {                  my @out;
796                          if (ref($_) eq 'HASH') {                  foreach my $h ( @{ $rec->{$f} } ) {
797                                  values %{$_};                          if (ref($h) eq 'HASH') {
798                                    push @out, ( _pack_subfields_hash( $h ) );
799                          } else {                          } else {
800                                  $_;                                  push @out, $h;
801                          }                          }
802                  } @{ $rec->{$f} };                  }
803                    return @out;
804          } elsif( defined($rec->{$f}) ) {          } elsif( defined($rec->{$f}) ) {
805                  return $rec->{$f};                  return $rec->{$f};
806          }          }

Legend:
Removed from v.616  
changed lines
  Added in v.669

  ViewVC Help
Powered by ViewVC 1.1.26