r1018@llin: dpavlin | 2006-09-26 12:20:52 +0200

[webpac2] / lib / WebPAC / Normalize.pm

diff --git a/lib/WebPAC/Normalize.pm b/lib/WebPAC/Normalize.pm
index b067555..6abf00c 100644 (file)
--- a/lib/WebPAC/Normalize.pm
+++ b/lib/WebPAC/Normalize.pm
@@ -4,6 +4,7 @@ use Exporter 'import';
        _set_rec _set_lookup
        _get_ds _clean_ds
        _debug
+       _pack_subfields_hash
 
        tag search display
        marc marc_indicators marc_repeatable_subfield
@@ -14,6 +15,7 @@ use Exporter 'import';
        rec1 rec2 rec
        regex prefix suffix surround
        first lookup join_with
+       save_into_lookup
 
        split_rec_on
 /;
@@ -23,7 +25,6 @@ use strict;
 
 #use base qw/WebPAC::Common/;
 use Data::Dump qw/dump/;
-use Encode qw/from_to/;
 use Storable qw/dclone/;
 
 # debugging warn(s)
@@ -36,11 +37,11 @@ WebPAC::Normalize - describe normalisaton rules using sets
 
 =head1 VERSION
 
-Version 0.16
+Version 0.20
 
 =cut
 
-our $VERSION = '0.16';
+our $VERSION = '0.20';
 
 =head1 SYNOPSIS
 
@@ -66,14 +67,14 @@ All other functions are available for use within normalisation rules.
 Return data structure
 
   my $ds = WebPAC::Normalize::data_structure(
-       lookup => $lookup->lookup_hash,
+       lookup => $lookup_variable,
        row => $row,
        rules => $normalize_pl_config,
        marc_encoding => 'utf-8',
        config => $config,
   );
 
-Options C<lookup>, C<row>, C<rules> and C<log> are mandatory while all
+Options C<row>, C<rules> and C<log> are mandatory while all
 other are optional.
 
 This function will B<die> if normalizastion can't be evaled.
@@ -90,9 +91,9 @@ sub data_structure {
        die "need normalisation argument" unless ($arg->{rules});
 
        no strict 'subs';
-       _set_lookup( $arg->{lookup} );
+       _set_lookup( $arg->{lookup} ) if (defined( $arg->{lookup} ));
        _set_rec( $arg->{row} );
-       _set_config( $arg->{config} );
+       _set_config( $arg->{config} ) if (defined( $arg->{config} ));
        _clean_ds( %{ $arg } );
        eval "$arg->{rules}";
        die "error evaling $arg->{rules}: $@\n" if ($@);
@@ -186,6 +187,18 @@ sub _set_lookup {
        $lookup = shift;
 }
 
+=head2 _get_lookup
+
+Get current lookup hash
+
+  my $lookup = _get_lookup();
+
+=cut
+
+sub _get_lookup {
+       return $lookup;
+}
+
 =head2 _get_marc_fields
 
 Get all fields defined by calls to C<marc>
@@ -469,7 +482,6 @@ sub marc {
        foreach (@_) {
                my $v = $_;             # make var read-write for Encode
                next unless (defined($v) && $v !~ /^\s*$/);
-               from_to($v, 'iso-8859-2', $marc_encoding) if ($marc_encoding);
                my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');
                if (defined $sf) {
                        push @{ $marc_record->[ $marc_record_offset ] }, [ $f, $i1, $i2, $sf => $v ];
@@ -549,7 +561,6 @@ sub marc_compose {
                my $v = shift;
 
                next unless (defined($v) && $v !~ /^\s*$/);
-               from_to($v, 'iso-8859-2', $marc_encoding) if ($marc_encoding);
                warn "## ++ marc_compose($f,$sf,$v) ", dump( $m ),$/ if ($debug > 1);
                if ($sf ne '+') {
                        push @$m, ( $sf, $v );
@@ -722,6 +733,62 @@ sub marc_original_order {
 This function should be used inside functions to create C<data_structure> described
 above.
 
+=head2 _pack_subfields_hash
+
+ @subfields = _pack_subfields_hash( $h );
+ $subfields = _pack_subfields_hash( $h, 1 );
+
+Return each subfield value in array or pack them all together and return scalar
+with subfields (denoted by C<^>) and values.
+
+=cut
+
+sub _pack_subfields_hash {
+
+       warn "## _pack_subfields_hash( ",dump(@_), " )\n" if ($debug > 1);
+
+       my ($h,$include_subfields) = @_;
+
+       if ( defined($h->{subfields}) ) {
+               my $sfs = delete $h->{subfields} || die "no subfields?";
+               my @out;
+               while (@$sfs) {
+                       my $sf = shift @$sfs;
+                       push @out, '^' . $sf if ($include_subfields);
+                       my $o = shift @$sfs;
+                       if ($o == 0 && ref( $h->{$sf} ) ne 'ARRAY' ) {
+                               # single element subfields are not arrays
+#warn "====> $sf $o / $#$sfs ", dump( $sfs, $h->{$sf} ), "\n";
+
+                               push @out, $h->{$sf};
+                       } else {
+#warn "====> $sf $o / $#$sfs ", dump( $sfs, $h->{$sf} ), "\n";
+                               push @out, $h->{$sf}->[$o];
+                       }
+               }
+               if ($include_subfields) {
+                       return join('', @out);
+               } else {
+                       return @out;
+               }
+       } else {
+               if ($include_subfields) {
+                       my $out = '';
+                       foreach my $sf (sort keys %$h) {
+                               if (ref($h->{$sf}) eq 'ARRAY') {
+                                       $out .= '^' . $sf . join('^' . $sf, @{ $h->{$sf} });
+                               } else {
+                                       $out .= '^' . $sf . $h->{$sf};
+                               }
+                       }
+                       return $out;
+               } else {
+                       # FIXME this should probably be in alphabetical order instead of hash order
+                       values %{$h};
+               }
+       }
+}
+
 =head2 rec1
 
 Return all values in some field
@@ -738,13 +805,15 @@ sub rec1 {
        return unless (defined($rec) && defined($rec->{$f}));
        warn "rec1($f) = ", dump( $rec->{$f} ), $/ if ($debug > 1);
        if (ref($rec->{$f}) eq 'ARRAY') {
-               return map { 
-                       if (ref($_) eq 'HASH') {
-                               values %{$_};
+               my @out;
+               foreach my $h ( @{ $rec->{$f} } ) {
+                       if (ref($h) eq 'HASH') {
+                               push @out, ( _pack_subfields_hash( $h ) );
                        } else {
-                               $_;
+                               push @out, $h;
                        }
-               } @{ $rec->{$f} };
+               }
+               return @out;
        } elsif( defined($rec->{$f}) ) {
                return $rec->{$f};
        }
@@ -875,6 +944,8 @@ Consult lookup hashes for some value
   @v = lookup( $v );
   @v = lookup( @v );
 
+FIXME B<currently this one is broken!>
+
 =cut
 
 sub lookup {
@@ -887,6 +958,31 @@ sub lookup {
        }
 }
 
+=head2 save_into_lookup
+
+Save value into lookup.
+
+  save_into_lookup($database,$input,$key,sub {
+       # code which produce one or more values 
+  });
+
+This function shouldn't be called directly, it's called from code created by L<WebPAC::Parser>.
+
+=cut
+
+sub save_into_lookup {
+       my ($database,$input,$key,$coderef) = @_;
+       die "save_into_lookup needs database" unless defined($database);
+       die "save_into_lookup needs input" unless defined($input);
+       die "save_into_lookup needs key" unless defined($key);
+       die "save_into_lookup needs CODE" unless ( defined($coderef) && ref($coderef) eq 'CODE' );
+       my $mfn = $rec->{'000'}->[0] || die "mfn not defined or zero";
+       foreach my $v ( $coderef->() ) {
+               $lookup->{$database}->{$input}->{$key}->{$v}->{$mfn}++;
+               warn "# saved lookup $database/$input/$key [$v] $mfn\n"; #if ($debug > 1);
+       }
+}
+
 =head2 config
 
 Consult config values stored in C<config.yml>