--- trunk/lib/WebPAC/Normalize.pm 2007/04/05 21:50:14 817 +++ trunk/lib/WebPAC/Normalize.pm 2007/11/04 11:12:38 983 @@ -1,19 +1,22 @@ package WebPAC::Normalize; use Exporter 'import'; -@EXPORT = qw/ - _set_rec _set_lookup +our @EXPORT = qw/ + _set_ds _set_lookup + get_ds _set_load_row _get_ds _clean_ds _debug _pack_subfields_hash - tag search display + search_display search display sorted + marc marc_indicators marc_repeatable_subfield marc_compose marc_leader marc_fixed marc_duplicate marc_remove marc_count marc_original_order rec1 rec2 rec + frec regex prefix suffix surround first lookup join_with save_into_lookup @@ -22,6 +25,7 @@ get set count + /; use warnings; @@ -35,18 +39,16 @@ # debugging warn(s) my $debug = 0; +use WebPAC::Normalize::ISBN; +push @EXPORT, ( 'isbn_10', 'isbn_13' ); =head1 NAME WebPAC::Normalize - describe normalisaton rules using sets -=head1 VERSION - -Version 0.28 - =cut -our $VERSION = '0.28'; +our $VERSION = '0.32'; =head1 SYNOPSIS @@ -59,7 +61,7 @@ C. Normalisation can generate multiple output normalized data. For now, supported output -types (on the left side of definition) are: C, C, C and +types (on the left side of definition) are: C, C, C and C. =head1 FUNCTIONS @@ -78,7 +80,7 @@ marc_encoding => 'utf-8', config => $config, load_row_coderef => sub { - my ($database,$input,$mfn) = shift; + my ($database,$input,$mfn) = @_; $store->load_row( database => $database, input => $input, id => $mfn ); }, ); @@ -106,7 +108,7 @@ no strict 'subs'; _set_lookup( $arg->{lookup} ) if defined($arg->{lookup}); - _set_rec( $arg->{row} ); + _set_ds( $arg->{row} ); _set_config( $arg->{config} ) if defined($arg->{config}); _clean_ds( %{ $arg } ); $load_row_coderef = $arg->{load_row_coderef}; @@ -117,20 +119,32 @@ return _get_ds(); } -=head2 _set_rec +=head2 _set_ds Set current record hash - _set_rec( $rec ); + _set_ds( $rec ); =cut my $rec; -sub _set_rec { +sub _set_ds { $rec = shift or die "no record hash"; } +=head2 get_ds + +Access to original record from input module + + my $ds = get_rec; + +=cut + +sub get_ds { + return $rec; +} + =head2 _set_config Set current config hash @@ -171,6 +185,7 @@ my ($marc_record_offset, $marc_fetch_offset) = (0, 0); sub _get_ds { +#warn "## out = ",dump($out); return $out; } @@ -442,40 +457,51 @@ Those functions generally have to first in your normalization file. -=head2 tag +=head2 search_display -Define new tag for I and I. +Define output for L and L at the same time - tag('Title', rec('200','a') ); + search_display('Title', rec('200','a') ); =cut -sub tag { - my $name = shift or die "tag needs name as first argument"; +sub search_display { + my $name = shift or die "search_display needs name as first argument"; my @o = grep { defined($_) && $_ ne '' } @_; return unless (@o); - $out->{$name}->{tag} = $name; $out->{$name}->{search} = \@o; $out->{$name}->{display} = \@o; } +=head2 tag + +Old name for L, but supported + +=cut + +sub tag { + search_display( @_ ); +} + =head2 display -Define tag just for I +Define output just for I @v = display('Title', rec('200','a') ); =cut -sub display { - my $name = shift or die "display needs name as first argument"; +sub _field { + my $type = shift or confess "need type -- BUG?"; + my $name = shift or confess "needs name as first argument"; my @o = grep { defined($_) && $_ ne '' } @_; return unless (@o); - $out->{$name}->{tag} = $name; - $out->{$name}->{display} = \@o; + $out->{$name}->{$type} = \@o; } +sub display { _field( 'display', @_ ) } + =head2 search Prepare values just for I @@ -484,13 +510,18 @@ =cut -sub search { - my $name = shift or die "search needs name as first argument"; - my @o = grep { defined($_) && $_ ne '' } @_; - return unless (@o); - $out->{$name}->{tag} = $name; - $out->{$name}->{search} = \@o; -} +sub search { _field( 'search', @_ ) } + +=head2 sorted + +Insert into lists which will be automatically sorted + + sorted('Title', rec('200','a') ); + +=cut + +sub sorted { _field( 'sorted', @_ ) } + =head2 marc_leader @@ -535,12 +566,14 @@ my ($f, $pos, $val) = @_; die "need marc(field, position, value)" unless defined($f) && defined($pos); + confess "need val" unless defined $val; + my $update = 0; map { if ($_->[0] eq $f) { my $old = $_->[1]; - if (length($old) < $pos) { + if (length($old) <= $pos) { $_->[1] .= ' ' x ( $pos - length($old) ) . $val; warn "## marc_fixed($f,$pos,'$val') append '$old' -> '$_->[1]'\n" if ($debug > 1); } else { @@ -872,6 +905,9 @@ my ($h,$include_subfields) = @_; + # sanity and ease of use + return $h if (ref($h) ne 'HASH'); + if ( defined($h->{subfields}) ) { my $sfs = delete $h->{subfields} || die "no subfields?"; my @out; @@ -976,6 +1012,12 @@ =cut +sub frec { + my @out = rec(@_); + warn "rec(",dump(@_),") has more than one return value, ignoring\n" if $#out > 0; + return shift @out; +} + sub rec { my @out; if ($#_ == 0) { @@ -1021,7 +1063,8 @@ =cut sub prefix { - my $p = shift or return; + my $p = shift; + return @_ unless defined( $p ); return map { $p . $_ } grep { defined($_) } @_; } @@ -1034,7 +1077,8 @@ =cut sub suffix { - my $s = shift or die "suffix needs string as first argument"; + my $s = shift; + return @_ unless defined( $s ); return map { $_ . $s } grep { defined($_) } @_; } @@ -1047,8 +1091,10 @@ =cut sub surround { - my $p = shift or die "surround need prefix as first argument"; - my $s = shift or die "surround needs suffix as second argument"; + my $p = shift; + my $s = shift; + $p = '' unless defined( $p ); + $s = '' unless defined( $s ); return map { $p . $_ . $s } grep { defined($_) } @_; } @@ -1223,7 +1269,6 @@ $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.