r842@llin: dpavlin | 2006-07-23 22:23:52 +0200

[webpac2] / lib / WebPAC / Normalize.pm

diff --git a/lib/WebPAC/Normalize.pm b/lib/WebPAC/Normalize.pm
index 67d397b..1a144f8 100644 (file)
--- a/lib/WebPAC/Normalize.pm
+++ b/lib/WebPAC/Normalize.pm
@@ -35,11 +35,11 @@ WebPAC::Normalize - describe normalisaton rules using sets
 
 =head1 VERSION
 
-Version 0.11
+Version 0.15
 
 =cut
 
-our $VERSION = '0.11';
+our $VERSION = '0.15';
 
 =head1 SYNOPSIS
 
@@ -69,6 +69,7 @@ Return data structure
        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
@@ -90,6 +91,7 @@ sub data_structure {
        no strict 'subs';
        _set_lookup( $arg->{lookup} );
        _set_rec( $arg->{row} );
+       _set_config( $arg->{config} );
        _clean_ds( %{ $arg } );
        eval "$arg->{rules}";
        die "error evaling $arg->{rules}: $@\n" if ($@);
@@ -111,6 +113,34 @@ sub _set_rec {
        $rec = shift or die "no record hash";
 }
 
+=head2 _set_config
+
+Set current config hash
+
+  _set_config( $config );
+
+Magic keys are:
+
+=over 4
+
+=item _
+
+Code of current database
+
+=item _mfn
+
+Current MFN
+
+=back
+
+=cut
+
+my $config;
+
+sub _set_config {
+       $config = shift;
+}
+
 =head2 _get_ds
 
 Return hash formatted as data structure
@@ -495,6 +525,9 @@ Save values for each MARC subfield explicitly
        'c', rec('200','c')
   );
 
+If you specify C<+> for subfield, value will be appended
+to previous defined subfield.
+
 =cut
 
 sub marc_compose {
@@ -512,8 +545,12 @@ sub marc_compose {
 
                next unless (defined($v) && $v !~ /^\s*$/);
                from_to($v, 'iso-8859-2', $marc_encoding) if ($marc_encoding);
-               push @$m, ( $sf, $v );
                warn "## ++ marc_compose($f,$sf,$v) ", dump( $m ),$/ if ($debug > 1);
+               if ($sf ne '+') {
+                       push @$m, ( $sf, $v );
+               } else {
+                       $m->[ $#$m ] .= $v;
+               }
        }
 
        warn "## marc_compose current marc = ", dump( $m ),$/ if ($debug > 1);
@@ -649,7 +686,14 @@ sub rec2 {
        my $f = shift;
        return unless (defined($rec && $rec->{$f}));
        my $sf = shift;
-       return map { $_->{$sf} } grep { ref($_) eq 'HASH' && $_->{$sf} } @{ $rec->{$f} };
+       warn "rec2($f,$sf) = ", dump( $rec->{$f} ), $/ if ($debug > 1);
+       return map {
+               if (ref($_->{$sf}) eq 'ARRAY') {
+                       @{ $_->{$sf} };
+               } else {
+                       $_->{$sf};
+               }
+       } grep { ref($_) eq 'HASH' && $_->{$sf} } @{ $rec->{$f} };
 }
 
 =head2 rec
@@ -704,7 +748,7 @@ Prefix all values with a string
 =cut
 
 sub prefix {
-       my $p = shift or die "prefix needs string as first argument";
+       my $p = shift or return;
        return map { $p . $_ } grep { defined($_) } @_;
 }
 
@@ -767,6 +811,78 @@ sub lookup {
        }
 }
 
+=head2 config
+
+Consult config values stored in C<config.yml>
+
+  # return database code (key under databases in yaml)
+  $database_code = config();   # use _ from hash
+  $database_name = config('name');
+  $database_input_name = config('input name');
+  $tag = config('input normalize tag');
+
+Up to three levels are supported.
+
+=cut
+
+sub config {
+       return unless ($config);
+
+       my $p = shift;
+
+       $p ||= '';
+
+       my $v;
+
+       warn "### getting config($p)\n" if ($debug > 1);
+
+       my @p = split(/\s+/,$p);
+       if ($#p < 0) {
+               $v = $config->{ '_' };  # special, database code
+       } else {
+
+               my $c = dclone( $config );
+
+               foreach my $k (@p) {
+                       warn "### k: $k c = ",dump($c),$/ if ($debug > 1);
+                       if (ref($c) eq 'ARRAY') {
+                               $c = shift @$c;
+                               warn "config($p) taking first occurence of '$k', probably not what you wanted!\n";
+                               last;
+                       }
+
+                       if (! defined($c->{$k}) ) {
+                               $c = undef;
+                               last;
+                       } else {
+                               $c = $c->{$k};
+                       }
+               }
+               $v = $c if ($c);
+
+       }
+
+       warn "## config( '$p' ) = ",dump( $v ),$/ if ($v && $debug);
+       warn "config( '$p' ) is empty\n" if (! $v);
+
+       return $v;
+}
+
+=head2 id
+
+Returns unique id of this record
+
+  $id = id();
+
+Returns C<42/2> for 2nd occurence of MFN 42.
+
+=cut
+
+sub id {
+       my $mfn = $config->{_mfn} || die "no _mfn in config data";
+       return $mfn . $#{$marc_record} ? $#{$marc_record} + 1 : '';
+}
+
 =head2 join_with
 
 Joins walues with some delimiter