--- trunk/lib/WebPAC/Normalize.pm 2006/07/01 10:19:29 554 +++ trunk/lib/WebPAC/Normalize.pm 2009/05/29 20:32:13 1205 @@ -1,16 +1,26 @@ package WebPAC::Normalize; use Exporter 'import'; -@EXPORT = qw/ - _set_rec _set_lookup +our @EXPORT = qw/ + _set_ds _set_lookup + _set_load_row _get_ds _clean_ds _debug + _pack_subfields_hash - tag search display - marc marc_indicators marc_repeatable_subfield + to + search_display search display sorted rec1 rec2 rec + frec frec_eq frec_ne regex prefix suffix surround first lookup join_with + save_into_lookup + + split_rec_on + + get set + count + /; use warnings; @@ -18,23 +28,34 @@ #use base qw/WebPAC::Common/; use Data::Dump qw/dump/; -use Encode qw/from_to/; +use Carp qw/confess/; # debugging warn(s) my $debug = 0; +_debug( $debug ); +# FIXME +use WebPAC::Normalize::ISBN; +push @EXPORT, ( 'isbn_10', 'isbn_13' ); -=head1 NAME +use WebPAC::Normalize::MARC; +push @EXPORT, ( qw/ + marc marc_indicators marc_repeatable_subfield + marc_compose marc_leader marc_fixed + marc_duplicate marc_remove marc_count + marc_original_order + marc_template +/); -WebPAC::Normalize - describe normalisaton rules using sets +use Storable qw/dclone/; -=head1 VERSION +=head1 NAME -Version 0.07 +WebPAC::Normalize - describe normalisaton rules using sets =cut -our $VERSION = '0.07'; +our $VERSION = '0.36'; =head1 SYNOPSIS @@ -47,7 +68,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 @@ -60,15 +81,23 @@ Return data structure my $ds = WebPAC::Normalize::data_structure( - lookup => $lookup->lookup_hash, + lookup => $lookup_hash, row => $row, rules => $normalize_pl_config, marc_encoding => 'utf-8', + config => $config, + load_row_coderef => sub { + my ($database,$input,$mfn) = @_; + $store->load_row( database => $database, input => $input, id => $mfn ); + }, ); -Options C, C, C and C are mandatory while all +Options C, C and C are mandatory while all other are optional. +C is closure only used when executing lookups, so they will +die if it's not defined. + This function will B if normalizastion can't be evaled. Since this function isn't exported you have to call it with @@ -76,34 +105,83 @@ =cut +my $load_row_coderef; + sub data_structure { my $arg = {@_}; die "need row argument" unless ($arg->{row}); die "need normalisation argument" unless ($arg->{rules}); - no strict 'subs'; - _set_lookup( $arg->{lookup} ); - _set_rec( $arg->{row} ); + _set_lookup( $arg->{lookup} ) if defined($arg->{lookup}); + _set_ds( $arg->{row} ); + _set_config( $arg->{config} ) if defined($arg->{config}); _clean_ds( %{ $arg } ); - eval "$arg->{rules}"; + $load_row_coderef = $arg->{load_row_coderef}; + + no strict 'subs'; + no warnings 'redefine'; + eval "$arg->{rules};"; die "error evaling $arg->{rules}: $@\n" if ($@); 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"; + $WebPAC::Normalize::MARC::rec = $rec; +} + +=head2 + + my $rec = _get_rec(); + +=cut + +sub _get_rec { $rec }; + +sub rec_array { + my $d = $rec->{ $_[0] }; + return @$d if ref($d) eq 'ARRAY'; + die "field $_[0] not array: ",dump( $d ); +} + +=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 @@ -114,9 +192,10 @@ =cut -my ($out,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators); +my $out; sub _get_ds { +#warn "## out = ",dump($out); return $out; } @@ -130,8 +209,8 @@ sub _clean_ds { my $a = {@_}; - ($out,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators) = (); - $marc_encoding = $a->{marc_encoding}; + $out = undef; + WebPAC::Normalize::MARC::_clean(); } =head2 _set_lookup @@ -148,139 +227,35 @@ $lookup = shift; } -=head2 _get_marc_fields - -Get all fields defined by calls to C - - $marc->add_fields( WebPAC::Normalize:_get_marc_fields() ); - -We are using I which detect repeatable fields only from -sequence of field/subfield data generated by normalization. - -Repeatable field is created when there is second occurence of same subfield or -if any of indicators are different. - -This is sane for most cases. Something like: +=head2 _get_lookup - 900a-1 900b-1 900c-1 - 900a-2 900b-2 - 900a-3 +Get current lookup hash -will be created from any combination of: - - 900a-1 900a-2 900a-3 900b-1 900b-2 900c-1 - -and following rules: - - marc('900','a', rec('200','a') ); - marc('900','b', rec('200','b') ); - marc('900','c', rec('200','c') ); - -which might not be what you have in mind. If you need repeatable subfield, -define it using C like this: - -.... + my $lookup = _get_lookup(); =cut -sub _get_marc_fields { - - return if (! $marc_record || ref($marc_record) ne 'ARRAY' || $#{ $marc_record } < 0); - - # first, sort all existing fields - # XXX might not be needed, but modern perl might randomize elements in hash - my @sorted_marc_record = sort { - $a->[0] . $a->[3] cmp $b->[0] . $b->[3] - } @{ $marc_record }; - - # output marc fields - my @m; - - # count unique field-subfields (used for offset when walking to next subfield) - my $u; - map { $u->{ $_->[0] . $_->[3] }++ } @sorted_marc_record; - - if ($debug) { - warn "## marc_repeatable_subfield ", dump( $marc_repeatable_subfield ), $/; - warn "## marc_record ", dump( $marc_record ), $/; - warn "## sorted_marc_record ", dump( \@sorted_marc_record ), $/; - warn "## subfield count ", dump( $u ), $/; - } - - my $len = $#sorted_marc_record; - my $visited; - my $i = 0; - my $field; - - foreach ( 0 .. $len ) { - - # find next element which isn't visited - while ($visited->{$i}) { - $i = ($i + 1) % ($len + 1); - } - - # mark it visited - $visited->{$i}++; - - my $row = $sorted_marc_record[$i]; - - # field and subfield which is key for - # marc_repeatable_subfield and u - my $fsf = $row->[0] . $row->[3]; - - if ($debug > 1) { - - print "### field so far [", $#$field, "] : ", dump( $field ), " ", $field ? 'T' : 'F', $/; - print "### this [$i]: ", dump( $row ),$/; - print "### sf: ", $row->[3], " vs ", $field->[3], - $marc_repeatable_subfield->{ $row->[0] . $row->[3] } ? ' (repeatable)' : '', $/, - if ($#$field >= 0); +sub _get_lookup { + return $lookup; +} - } +=head2 _set_load_row - # if field exists - if ( $#$field >= 0 ) { - if ( - $row->[0] ne $field->[0] || # field - $row->[1] ne $field->[1] || # i1 - $row->[2] ne $field->[2] # i2 - ) { - push @m, $field; - warn "## saved/1 ", dump( $field ),$/ if ($debug); - $field = $row; - - } elsif ( - ( $row->[3] lt $field->[-2] ) # subfield which is not next (e.g. a after c) - || - ( $row->[3] eq $field->[-2] && # same subfield, but not repeatable - ! $marc_repeatable_subfield->{ $fsf } - ) - ) { - push @m, $field; - warn "## saved/2 ", dump( $field ),$/ if ($debug); - $field = $row; +Setup code reference which will return L from +L - } else { - # append new subfields to existing field - push @$field, ( $row->[3], $row->[4] ); - } - } else { - # insert first field - $field = $row; - } + _set_load_row(sub { + my ($database,$input,$mfn) = @_; + $store->load_row( database => $database, input => $input, id => $mfn ); + }); - if (! $marc_repeatable_subfield->{ $fsf }) { - # make step to next subfield - $i = ($i + $u->{ $fsf } ) % ($len + 1); - } - } +=cut - if ($#$field >= 0) { - push @m, $field; - warn "## saved/3 ", dump( $field ),$/ if ($debug); - } +sub _set_load_row { + my $coderef = shift; + confess "argument isn't CODE" unless ref($coderef) eq 'CODE'; - return @m; + $load_row_coderef = $coderef; } =head2 _debug @@ -294,120 +269,103 @@ sub _debug { my $l = shift; return $debug unless defined($l); + warn "debug level $l",$/ if ($l > 0); $debug = $l; + $WebPAC::Normalize::MARC::debug = $debug; } =head1 Functions to create C Those functions generally have to first in your normalization file. -=head2 tag +=head2 to -Define new tag for I and I. +Generic way to set values for some name - tag('Title', rec('200','a') ); + to('field-name', 'name-value' => rec('200','a') ); +There are many helpers defined below which might be easier to use. =cut -sub tag { - my $name = shift or die "tag needs name as first argument"; +sub to { + 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}->{search} = \@o; - $out->{$name}->{display} = \@o; + $out->{$name}->{$type} = \@o; } -=head2 display +=head2 search_display -Define tag just for I +Define output for L and L at the same time - @v = display('Title', rec('200','a') ); + search_display('Title', rec('200','a') ); =cut -sub display { - my $name = shift or die "display 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 search - -Prepare values just for I +=head2 tag - @v = search('Title', rec('200','a') ); +Old name for L, it will probably be removed at one point. =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 tag { + search_display( @_ ); } -=head2 marc +=head2 display -Save value for MARC field +Define output just for I - marc('900','a', rec('200','a') ); + @v = display('Title', rec('200','a') ); =cut -sub marc { - my $f = shift or die "marc needs field"; - die "marc field must be numer" unless ($f =~ /^\d+$/); +sub display { to( 'display', @_ ) } - my $sf = shift or die "marc needs subfield"; +=head2 search - 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} } : (' ',' '); - push @{ $marc_record }, [ $f, $i1, $i2, $sf => $v ]; - } -} +Prepare values just for I -=head2 marc_repeatable_subfield + @v = search('Title', rec('200','a') ); -Save values for MARC repetable subfield +=cut - marc_repeatable_subfield('910', 'z', rec('909') ); +sub search { to( 'search', @_ ) } -=cut +=head2 sorted -sub marc_repeatable_subfield { - my ($f,$sf) = @_; - die "marc_repeatable_subfield need field and subfield!\n" unless ($f && $sf); - $marc_repeatable_subfield->{ $f . $sf }++; - marc(@_); -} +Insert into lists which will be automatically sorted + + sorted('Title', rec('200','a') ); + +=cut -=head2 marc_indicators +sub sorted { to( 'sorted', @_ ) } -Set both indicators for MARC field +=head2 row - marc_indicators('900', ' ', 1); +Insert new row of data into output module -Any indicator value other than C<0-9> will be treated as undefined. + row( column => 'foo', column2 => 'bar' ); =cut -sub marc_indicators { - my $f = shift || die "marc_indicators need field!\n"; - my ($i1,$i2) = @_; - die "marc_indicators($f, ...) need i1!\n" unless(defined($i1)); - die "marc_indicators($f, $i1, ...) need i2!\n" unless(defined($i2)); +use Data::Dump qw/dump/; + +sub row { + die "array doesn't have even number of elements but $#_: ",dump( @_ ) if $#_ % 2 != 1; - $i1 = ' ' if ($i1 !~ /^\d$/); - $i2 = ' ' if ($i2 !~ /^\d$/); - @{ $marc_indicators->{$f} } = ($i1,$i2); + push @{ $out->{'_rows'} }, {@_}; } @@ -416,6 +374,67 @@ This function should be used inside functions to create C 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 ($hash,$include_subfields) = @_; + + # sanity and ease of use + return $hash if (ref($hash) ne 'HASH'); + + my $h = dclone( $hash ); + + 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 @@ -428,15 +447,19 @@ sub rec1 { my $f = shift; + warn "rec1($f) = ", dump( $rec->{$f} ), $/ if ($debug > 1); 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}; } @@ -454,7 +477,14 @@ 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' && defined $_->{$sf} } @{ $rec->{$f} }; } =head2 rec @@ -464,16 +494,75 @@ @v = rec('200') @v = rec('200','a') +If rec() returns just single value, it will +return scalar, not array. + =cut sub rec { + my @out; if ($#_ == 0) { - return rec1(@_); + @out = rec1(@_); } elsif ($#_ == 1) { - return rec2(@_); + @out = rec2(@_); + } + if ($#out == 0 && ! wantarray) { + return $out[0]; + } elsif (@out) { + return @out; + } else { + return ''; } } +=head2 frec + +Returns first value from field + + $v = frec('200'); + $v = frec('200','a'); + +=cut + +sub frec { + my @out = rec(@_); + warn "rec(",dump(@_),") has more than one return value, ignoring\n" if $#out > 0; + return shift @out; +} + +=head2 frec_eq + +=head2 frec_ne + +Check if first values from two fields are same or different + + if ( frec_eq( 900 => 'a', 910 => 'c' ) ) { + # values are same + } else { + # values are different + } + +Strictly speaking C and C wouldn't be needed if you +could write something like: + + if ( frec( '900','a' ) eq frec( '910','c' ) ) { + # yada tada + } + +but you can't since our parser L will remove all whitespaces +in order to parse text and create invalid function C. + +=cut + +sub frec_eq { + my ( $f1,$sf1, $f2, $sf2 ) = @_; + return (rec( $f1, $sf1 ))[0] eq (rec( $f2, $sf2 ))[0]; +} + +sub frec_ne { + return ! frec_eq( @_ ); +} + =head2 regex Apply regex to some or all values @@ -503,7 +592,8 @@ =cut sub prefix { - my $p = shift or die "prefix needs string as first argument"; + my $p = shift; + return @_ unless defined( $p ); return map { $p . $_ } grep { defined($_) } @_; } @@ -516,7 +606,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($_) } @_; } @@ -529,8 +620,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($_) } @_; } @@ -551,19 +644,221 @@ Consult lookup hashes for some value - @v = lookup( $v ); - @v = lookup( @v ); + @v = lookup( + sub { + 'ffkk/peri/mfn'.rec('000') + }, + 'ffkk','peri','200-a-200-e', + sub { + first(rec(200,'a')).' '.first(rec('200','e')) + } + ); + +Code like above will be B using L from +normal lookup definition in C which looks like: + + lookup( + # which results to return from record recorded in lookup + sub { 'ffkk/peri/mfn' . rec('000') }, + # from which database and input + 'ffkk','peri', + # such that following values match + sub { first(rec(200,'a')) . ' ' . first(rec('200','e')) }, + # if this part is missing, we will try to match same fields + # from lookup record and current one, or you can override + # which records to use from current record using + sub { rec('900','x') . ' ' . rec('900','y') }, + ) + +You can think about this lookup as SQL (if that helps): + + select + sub { what } + from + database, input + where + sub { filter from lookuped record } + having + sub { optional filter on current record } + +Easy as pie, right? =cut sub lookup { - my $k = shift or return; - return unless (defined($lookup->{$k})); - if (ref($lookup->{$k}) eq 'ARRAY') { - return @{ $lookup->{$k} }; + my ($what, $database, $input, $key, $having) = @_; + + confess "lookup needs 5 arguments: what, database, input, key, having\n" unless ($#_ == 4); + + warn "## lookup ($database, $input, $key)", $/ if ($debug > 1); + return unless (defined($lookup->{$database}->{$input}->{$key})); + + confess "lookup really need load_row_coderef added to data_structure\n" unless ($load_row_coderef); + + my $mfns; + my @having = $having->(); + + warn "## having = ", dump( @having ) if ($debug > 2); + + foreach my $h ( @having ) { + if (defined($lookup->{$database}->{$input}->{$key}->{$h})) { + warn "lookup for $database/$input/$key/$h return ",dump($lookup->{$database}->{$input}->{$key}->{$h}),"\n" if ($debug); + $mfns->{$_}++ foreach keys %{ $lookup->{$database}->{$input}->{$key}->{$h} }; + } + } + + return unless ($mfns); + + my @mfns = sort keys %$mfns; + + warn "# lookup loading $database/$input/$key mfn ", join(",",@mfns)," having ",dump(@having),"\n" if ($debug); + + my $old_rec = $rec; + my @out; + + foreach my $mfn (@mfns) { + $rec = $load_row_coderef->( $database, $input, $mfn ); + + warn "got $database/$input/$mfn = ", dump($rec), $/ if ($debug); + + my @vals = $what->(); + + push @out, ( @vals ); + + warn "lookup for mfn $mfn returned ", dump(@vals), $/ if ($debug); + } + +# if (ref($lookup->{$k}) eq 'ARRAY') { +# return @{ $lookup->{$k} }; +# } else { +# return $lookup->{$k}; +# } + + $rec = $old_rec; + + warn "## lookup returns = ", dump(@out), $/ if ($debug); + + if ($#out == 0) { + return $out[0]; + } else { + return @out; + } +} + +=head2 save_into_lookup + +Save value into lookup. It associates current database, input +and specific keys with one or more values which will be +associated over MFN. + +MFN will be extracted from first occurence current of field 000 +in current record, or if it doesn't exist from L<_set_config> C<_mfn>. + + my $nr = save_into_lookup($database,$input,$key,sub { + # code which produce one or more values + }); + +It returns number of items saved. + +This function shouldn't be called directly, it's called from code created by +L. + +=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' ); + + warn "## save_into_lookup rec = ", dump($rec), " config = ", dump($config), $/ if ($debug > 2); + + my $mfn = + defined($rec->{'000'}->[0]) ? $rec->{'000'}->[0] : + defined($config->{_mfn}) ? $config->{_mfn} : + die "mfn not defined or zero"; + + my $nr = 0; + + foreach my $v ( $coderef->() ) { + $lookup->{$database}->{$input}->{$key}->{$v}->{$mfn}++; + warn "# saved lookup $database/$input/$key [$v] $mfn\n" if ($debug > 1); + $nr++; + } + + return $nr; +} + +=head2 config + +Consult config values stored in C + + # return database code (key under databases in yaml) + $database_code = config(); # use _ from hash + $database_name = config('name'); + $database_input_name = config('input name'); + +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 { - return $lookup->{$k}; + + 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 . ( WebPAC::Normalize::MARC::_created_marc_records() || '' ); } =head2 join_with @@ -576,7 +871,86 @@ sub join_with { my $d = shift; - return join($d, grep { defined($_) && $_ ne '' } @_); + warn "### join_with('$d',",dump(@_),")\n" if ($debug > 2); + my $v = join($d, grep { defined($_) && $_ ne '' } @_); + return '' unless defined($v); + return $v; +} + +=head2 split_rec_on + +Split record subfield on some regex and take one of parts out + + $a_before_semi_column = + split_rec_on('200','a', /\s*;\s*/, $part); + +C<$part> is optional number of element. First element is +B<1>, not 0! + +If there is no C<$part> parameter or C<$part> is 0, this function will +return all values produced by splitting. + +=cut + +sub split_rec_on { + die "split_rec_on need (fld,sf,regex[,part]" if ($#_ < 2); + + my ($fld, $sf, $regex, $part) = @_; + warn "### regex ", ref($regex), $regex, $/ if ($debug > 2); + + my @r = rec( $fld, $sf ); + my $v = shift @r; + warn "### first rec($fld,$sf) = ",dump($v),$/ if ($debug > 2); + + return '' if ( ! defined($v) || $v =~ /^\s*$/); + + my @s = split( $regex, $v ); + warn "## split_rec_on($fld,$sf,$regex,$part) = ",dump(@s),$/ if ($debug > 1); + if ($part && $part > 0) { + return $s[ $part - 1 ]; + } else { + return @s; + } +} + +my $hash; + +=head2 set + + set( key => 'value' ); + +=cut + +sub set { + my ($k,$v) = @_; + warn "## set ( $k => ", dump($v), " )", $/ if ( $debug ); + $hash->{$k} = $v; +}; + +=head2 get + + get( 'key' ); + +=cut + +sub get { + my $k = shift || return; + my $v = $hash->{$k}; + warn "## get $k = ", dump( $v ), $/ if ( $debug ); + return $v; +} + +=head2 count + + if ( count( @result ) == 1 ) { + # do something if only 1 result is there + } + +=cut + +sub count { + warn "## count ",dump(@_),$/ if ( $debug ); + return @_ . ''; } # END