lib/WebPAC/Normalize.pm

package WebPAC::Normalize;
use Exporter 'import';
@EXPORT = qw/
        _set_rec _set_lookup
        _get_ds _clean_ds
        _debug

        tag search display
        marc marc_indicators marc_repeatable_subfield
        marc_compose marc_leader

        rec1 rec2 rec
        regex prefix suffix surround
        first lookup join_with

        split_rec_on
/;

use warnings;
use strict;

#use base qw/WebPAC::Common/;
use Data::Dump qw/dump/;
use Encode qw/from_to/;

# debugging warn(s)
my $debug = 0;


=head1 NAME

WebPAC::Normalize - describe normalisaton rules using sets

=head1 VERSION

Version 0.09

=cut

our $VERSION = '0.09';

=head1 SYNOPSIS

This module uses C<conf/normalize/*.pl> files to perform normalisation
from input records using perl functions which are specialized for set
processing.

Sets are implemented as arrays, and normalisation file is valid perl, which
means that you check it's validity before running WebPAC using
C<perl -c normalize.pl>.

Normalisation can generate multiple output normalized data. For now, supported output
types (on the left side of definition) are: C<tag>, C<display>, C<search> and
C<marc>.

=head1 FUNCTIONS

Functions which start with C<_> are private and used by WebPAC internally.
All other functions are available for use within normalisation rules.

=head2 data_structure

Return data structure

  my $ds = WebPAC::Normalize::data_structure(
        lookup => $lookup->lookup_hash,
        row => $row,
        rules => $normalize_pl_config,
        marc_encoding => 'utf-8',
  );

Options C<lookup>, 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.

Since this function isn't exported you have to call it with 
C<WebPAC::Normalize::data_structure>.

=cut

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} );
        _clean_ds( %{ $arg } );
        eval "$arg->{rules}";
        die "error evaling $arg->{rules}: $@\n" if ($@);

        return _get_ds();
}

=head2 _set_rec

Set current record hash

  _set_rec( $rec );

=cut

my $rec;

sub _set_rec {
        $rec = shift or die "no record hash";
}

=head2 _get_ds

Return hash formatted as data structure

  my $ds = _get_ds();

=cut

my ($out,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators);

sub _get_ds {
        return $out;
}

=head2 _clean_ds

Clean data structure hash for next record

  _clean_ds();

=cut

sub _clean_ds {
        my $a = {@_};
        ($out,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators) = ();
        $marc_encoding = $a->{marc_encoding};
}

=head2 _set_lookup

Set current lookup hash

  _set_lookup( $lookup );

=cut

my $lookup;

sub _set_lookup {
        $lookup = shift;
}

=head2 _get_marc_fields

Get all fields defined by calls to C<marc>

        $marc->add_fields( WebPAC::Normalize:_get_marc_fields() );

We are using I<magic> 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:

  900a-1 900b-1 900c-1
  900a-2 900b-2
  900a-3

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<marc_repeatable_subfield> like this:

....

=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 };

        @sorted_marc_record = @{ $marc_record };        ### FIXME disable sorting
        
        # 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);

                }

                # 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;

                        } else {
                                # append new subfields to existing field
                                push @$field, ( $row->[3], $row->[4] );
                        }
                } else {
                        # insert first field
                        $field = $row;
                }

                if (! $marc_repeatable_subfield->{ $fsf }) {
                        # make step to next subfield
                        $i = ($i + $u->{ $fsf } ) % ($len + 1);
                }
        }

        if ($#$field >= 0) {
                push @m, $field;
                warn "## saved/3 ", dump( $field ),$/ if ($debug);
        }

        return @m;
}

=head2 _debug

Change level of debug warnings

  _debug( 2 );

=cut

sub _debug {
        my $l = shift;
        return $debug unless defined($l);
        warn "debug level $l",$/ if ($l > 0);
        $debug = $l;
}

=head1 Functions to create C<data_structure>

Those functions generally have to first in your normalization file.

=head2 tag

Define new tag for I<search> and I<display>.

  tag('Title', rec('200','a') );


=cut

sub tag {
        my $name = shift or die "tag 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 display

Define tag just for I<display>

  @v = display('Title', rec('200','a') );

=cut

sub display {
        my $name = shift or die "display needs name as first argument";
        my @o = grep { defined($_) && $_ ne '' } @_;
        return unless (@o);
        $out->{$name}->{tag} = $name;
        $out->{$name}->{display} = \@o;
}

=head2 search

Prepare values just for I<search>

  @v = search('Title', rec('200','a') );

=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;
}

=head2 marc_leader

Setup fields within MARC leader or get leader

  marc_leader('05','c');
  my $leader = marc_leader();

=cut

sub marc_leader {
        my ($offset,$value) = @_;

        if ($offset) {
                $out->{' leader'}->{ $offset } = $value;
        } else {
                return $out->{' leader'};
        }
}

=head2 marc

Save value for MARC field

  marc('900','a', rec('200','a') );
  marc('001', rec('000') );

=cut

sub marc {
        my $f = shift or die "marc needs field";
        die "marc field must be numer" unless ($f =~ /^\d+$/);

        my $sf;
        if ($f >= 10) {
                $sf = shift or die "marc needs subfield";
        }

        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 }, [ $f, $i1, $i2, $sf => $v ];
                } else {
                        push @{ $marc_record }, [ $f, $v ];
                }
        }
}

=head2 marc_repeatable_subfield

Save values for MARC repetable subfield

  marc_repeatable_subfield('910', 'z', rec('909') );

=cut

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(@_);
}

=head2 marc_indicators

Set both indicators for MARC field

  marc_indicators('900', ' ', 1);

Any indicator value other than C<0-9> will be treated as undefined.

=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));

        $i1 = ' ' if ($i1 !~ /^\d$/);
        $i2 = ' ' if ($i2 !~ /^\d$/);
        @{ $marc_indicators->{$f} } = ($i1,$i2);
}

=head2 marc_compose

Save values for each MARC subfield explicitly

  marc_compose('900',
        'a', rec('200','a')
        'b', rec('201','a')
        'a', rec('200','b')
        'c', rec('200','c')
  );

=cut

sub marc_compose {
        my $f = shift or die "marc_compose needs field";
        die "marc_compose field must be numer" unless ($f =~ /^\d+$/);

        my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');
        my $m = [ $f, $i1, $i2 ];

        while (@_) {
                my $sf = shift or die "marc_compose $f needs subfield";
                my $v = shift;

                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);
        }

        warn "## marc_compose(d) ", dump( $m ),$/ if ($debug > 1);

        push @{ $marc_record }, $m if ($#{$m} > 2);
}


=head1 Functions to extract data from input

This function should be used inside functions to create C<data_structure> described
above.

=head2 rec1

Return all values in some field

  @v = rec1('200')

TODO: order of values is probably same as in source data, need to investigate that

=cut

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 %{$_};
                        } else {
                                $_;
                        }
                } @{ $rec->{$f} };
        } elsif( defined($rec->{$f}) ) {
                return $rec->{$f};
        }
}

=head2 rec2

Return all values in specific field and subfield

  @v = rec2('200','a')

=cut

sub rec2 {
        my $f = shift;
        return unless (defined($rec && $rec->{$f}));
        my $sf = shift;
        return map { $_->{$sf} } grep { ref($_) eq 'HASH' && $_->{$sf} } @{ $rec->{$f} };
}

=head2 rec

syntaxtic sugar for

  @v = rec('200')
  @v = rec('200','a')

=cut

sub rec {
        if ($#_ == 0) {
                return rec1(@_);
        } elsif ($#_ == 1) {
                return rec2(@_);
        }
}

=head2 regex

Apply regex to some or all values

  @v = regex( 's/foo/bar/g', @v );

=cut

sub regex {
        my $r = shift;
        my @out;
        #warn "r: $r\n", dump(\@_);
        foreach my $t (@_) {
                next unless ($t);
                eval "\$t =~ $r";
                push @out, $t if ($t && $t ne '');
        }
        return @out;
}

=head2 prefix

Prefix all values with a string

  @v = prefix( 'my_', @v );

=cut

sub prefix {
        my $p = shift or die "prefix needs string as first argument";
        return map { $p . $_ } grep { defined($_) } @_;
}

=head2 suffix

suffix all values with a string

  @v = suffix( '_my', @v );

=cut

sub suffix {
        my $s = shift or die "suffix needs string as first argument";
        return map { $_ . $s } grep { defined($_) } @_;
}

=head2 surround

surround all values with a two strings

  @v = surround( 'prefix_', '_suffix', @v );

=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";
        return map { $p . $_ . $s } grep { defined($_) } @_;
}

=head2 first

Return first element

  $v = first( @v );

=cut

sub first {
        my $r = shift;
        return $r;
}

=head2 lookup

Consult lookup hashes for some value

  @v = lookup( $v );
  @v = lookup( @v );

=cut

sub lookup {
        my $k = shift or return;
        return unless (defined($lookup->{$k}));
        if (ref($lookup->{$k}) eq 'ARRAY') {
                return @{ $lookup->{$k} };
        } else {
                return $lookup->{$k};
        }
}

=head2 join_with

Joins walues with some delimiter

  $v = join_with(", ", @v);

=cut

sub join_with {
        my $d = shift;
        return join($d, grep { defined($_) && $_ ne '' } @_);
}

=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;
        }
}

# END
1;
1	dpavlin	10	package WebPAC::Normalize;
2	dpavlin	536	use Exporter 'import';
3			@EXPORT = qw/
4	dpavlin	538	_set_rec _set_lookup
5			_get_ds _clean_ds
6	dpavlin	554	_debug
7	dpavlin	538
8	dpavlin	536	tag search display
9	dpavlin	547	marc marc_indicators marc_repeatable_subfield
10	dpavlin	564	marc_compose marc_leader
11	dpavlin	540
12	dpavlin	536	rec1 rec2 rec
13			regex prefix suffix surround
14			first lookup join_with
15	dpavlin	562
16			split_rec_on
17	dpavlin	536	/;
18	dpavlin	10
19			use warnings;
20			use strict;
21	dpavlin	536
22			#use base qw/WebPAC::Common/;
23	dpavlin	550	use Data::Dump qw/dump/;
24	dpavlin	541	use Encode qw/from_to/;
25	dpavlin	10
26	dpavlin	550	# debugging warn(s)
27			my $debug = 0;
28
29
30	dpavlin	10	=head1 NAME
31
32	dpavlin	536	WebPAC::Normalize - describe normalisaton rules using sets
33	dpavlin	10
34			=head1 VERSION
35
36	dpavlin	564	Version 0.09
37	dpavlin	10
38			=cut
39
40	dpavlin	564	our $VERSION = '0.09';
41	dpavlin	10
42			=head1 SYNOPSIS
43
44	dpavlin	536	This module uses C<conf/normalize/*.pl> files to perform normalisation
45			from input records using perl functions which are specialized for set
46			processing.
47	dpavlin	10
48	dpavlin	536	Sets are implemented as arrays, and normalisation file is valid perl, which
49			means that you check it's validity before running WebPAC using
50			C<perl -c normalize.pl>.
51	dpavlin	15
52	dpavlin	536	Normalisation can generate multiple output normalized data. For now, supported output
53	dpavlin	540	types (on the left side of definition) are: C<tag>, C<display>, C<search> and
54	dpavlin	547	C<marc>.
55	dpavlin	15
56	dpavlin	10	=head1 FUNCTIONS
57
58	dpavlin	538	Functions which start with C<_> are private and used by WebPAC internally.
59			All other functions are available for use within normalisation rules.
60
61	dpavlin	536	=head2 data_structure
62	dpavlin	10
63	dpavlin	536	Return data structure
64	dpavlin	13
65	dpavlin	538	my $ds = WebPAC::Normalize::data_structure(
66	dpavlin	536	lookup => $lookup->lookup_hash,
67			row => $row,
68			rules => $normalize_pl_config,
69	dpavlin	541	marc_encoding => 'utf-8',
70	dpavlin	13	);
71
72	dpavlin	540	Options C<lookup>, C<row>, C<rules> and C<log> are mandatory while all
73			other are optional.
74
75	dpavlin	536	This function will B<die> if normalizastion can't be evaled.
76	dpavlin	15
77	dpavlin	538	Since this function isn't exported you have to call it with
78			C<WebPAC::Normalize::data_structure>.
79
80	dpavlin	10	=cut
81
82	dpavlin	536	sub data_structure {
83			my $arg = {@_};
84	dpavlin	13
85	dpavlin	536	die "need row argument" unless ($arg->{row});
86			die "need normalisation argument" unless ($arg->{rules});
87	dpavlin	31
88	dpavlin	536	no strict 'subs';
89	dpavlin	538	_set_lookup( $arg->{lookup} );
90			_set_rec( $arg->{row} );
91	dpavlin	541	_clean_ds( %{ $arg } );
92	dpavlin	536	eval "$arg->{rules}";
93			die "error evaling $arg->{rules}: $@\n" if ($@);
94	dpavlin	540
95	dpavlin	538	return _get_ds();
96	dpavlin	10	}
97
98	dpavlin	538	=head2 _set_rec
99	dpavlin	13
100	dpavlin	536	Set current record hash
101	dpavlin	433
102	dpavlin	538	_set_rec( $rec );
103	dpavlin	433
104			=cut
105
106	dpavlin	536	my $rec;
107	dpavlin	433
108	dpavlin	538	sub _set_rec {
109	dpavlin	536	$rec = shift or die "no record hash";
110	dpavlin	433	}
111
112	dpavlin	538	=head2 _get_ds
113
114			Return hash formatted as data structure
115
116			my $ds = _get_ds();
117
118			=cut
119
120	dpavlin	547	my ($out,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators);
121	dpavlin	538
122			sub _get_ds {
123			return $out;
124			}
125
126			=head2 _clean_ds
127
128			Clean data structure hash for next record
129
130			_clean_ds();
131
132			=cut
133
134			sub _clean_ds {
135	dpavlin	541	my $a = {@_};
136	dpavlin	550	($out,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators) = ();
137	dpavlin	541	$marc_encoding = $a->{marc_encoding};
138	dpavlin	538	}
139
140			=head2 _set_lookup
141
142			Set current lookup hash
143
144			_set_lookup( $lookup );
145
146			=cut
147
148			my $lookup;
149
150			sub _set_lookup {
151			$lookup = shift;
152			}
153
154	dpavlin	547	=head2 _get_marc_fields
155	dpavlin	540
156	dpavlin	547	Get all fields defined by calls to C<marc>
157	dpavlin	540
158	dpavlin	547	$marc->add_fields( WebPAC::Normalize:_get_marc_fields() );
159	dpavlin	540
160	dpavlin	543	We are using I<magic> which detect repeatable fields only from
161			sequence of field/subfield data generated by normalization.
162
163	dpavlin	554	Repeatable field is created when there is second occurence of same subfield or
164			if any of indicators are different.
165	dpavlin	543
166	dpavlin	554	This is sane for most cases. Something like:
167	dpavlin	543
168	dpavlin	554	900a-1 900b-1 900c-1
169			900a-2 900b-2
170			900a-3
171
172			will be created from any combination of:
173
174			900a-1 900a-2 900a-3 900b-1 900b-2 900c-1
175
176			and following rules:
177
178			marc('900','a', rec('200','a') );
179			marc('900','b', rec('200','b') );
180			marc('900','c', rec('200','c') );
181
182			which might not be what you have in mind. If you need repeatable subfield,
183			define it using C<marc_repeatable_subfield> like this:
184
185			....
186
187	dpavlin	540	=cut
188
189	dpavlin	547	sub _get_marc_fields {
190	dpavlin	550
191	dpavlin	551	return if (! $marc_record \|\| ref($marc_record) ne 'ARRAY' \|\| $#{ $marc_record } < 0);
192	dpavlin	550
193			# first, sort all existing fields
194			# XXX might not be needed, but modern perl might randomize elements in hash
195			my @sorted_marc_record = sort {
196			$a->[0] . $a->[3] cmp $b->[0] . $b->[3]
197			} @{ $marc_record };
198
199	dpavlin	562	@sorted_marc_record = @{ $marc_record }; ### FIXME disable sorting
200
201	dpavlin	550	# output marc fields
202	dpavlin	542	my @m;
203	dpavlin	550
204			# count unique field-subfields (used for offset when walking to next subfield)
205			my $u;
206			map { $u->{ $_->[0] . $_->[3] }++ } @sorted_marc_record;
207
208			if ($debug) {
209			warn "## marc_repeatable_subfield ", dump( $marc_repeatable_subfield ), $/;
210			warn "## marc_record ", dump( $marc_record ), $/;
211			warn "## sorted_marc_record ", dump( \@sorted_marc_record ), $/;
212			warn "## subfield count ", dump( $u ), $/;
213			}
214
215			my $len = $#sorted_marc_record;
216			my $visited;
217			my $i = 0;
218			my $field;
219
220			foreach ( 0 .. $len ) {
221
222			# find next element which isn't visited
223			while ($visited->{$i}) {
224			$i = ($i + 1) % ($len + 1);
225	dpavlin	542	}
226
227	dpavlin	550	# mark it visited
228			$visited->{$i}++;
229
230			my $row = $sorted_marc_record[$i];
231
232			# field and subfield which is key for
233			# marc_repeatable_subfield and u
234			my $fsf = $row->[0] . $row->[3];
235
236			if ($debug > 1) {
237
238			print "### field so far [", $#$field, "] : ", dump( $field ), " ", $field ? 'T' : 'F', $/;
239			print "### this [$i]: ", dump( $row ),$/;
240			print "### sf: ", $row->[3], " vs ", $field->[3],
241			$marc_repeatable_subfield->{ $row->[0] . $row->[3] } ? ' (repeatable)' : '', $/,
242			if ($#$field >= 0);
243
244			}
245
246			# if field exists
247			if ( $#$field >= 0 ) {
248			if (
249			$row->[0] ne $field->[0] \|\| # field
250			$row->[1] ne $field->[1] \|\| # i1
251			$row->[2] ne $field->[2] # i2
252			) {
253			push @m, $field;
254			warn "## saved/1 ", dump( $field ),$/ if ($debug);
255			$field = $row;
256
257			} elsif (
258			( $row->[3] lt $field->[-2] ) # subfield which is not next (e.g. a after c)
259			\|\|
260			( $row->[3] eq $field->[-2] && # same subfield, but not repeatable
261			! $marc_repeatable_subfield->{ $fsf }
262			)
263			) {
264			push @m, $field;
265			warn "## saved/2 ", dump( $field ),$/ if ($debug);
266			$field = $row;
267
268			} else {
269			# append new subfields to existing field
270			push @$field, ( $row->[3], $row->[4] );
271			}
272			} else {
273			# insert first field
274			$field = $row;
275			}
276
277			if (! $marc_repeatable_subfield->{ $fsf }) {
278			# make step to next subfield
279			$i = ($i + $u->{ $fsf } ) % ($len + 1);
280			}
281	dpavlin	542	}
282
283	dpavlin	550	if ($#$field >= 0) {
284			push @m, $field;
285			warn "## saved/3 ", dump( $field ),$/ if ($debug);
286			}
287	dpavlin	542
288			return @m;
289	dpavlin	540	}
290
291	dpavlin	554	=head2 _debug
292
293			Change level of debug warnings
294
295			_debug( 2 );
296
297			=cut
298
299			sub _debug {
300			my $l = shift;
301			return $debug unless defined($l);
302	dpavlin	568	warn "debug level $l",$/ if ($l > 0);
303	dpavlin	554	$debug = $l;
304			}
305
306	dpavlin	540	=head1 Functions to create C<data_structure>
307
308			Those functions generally have to first in your normalization file.
309
310	dpavlin	536	=head2 tag
311	dpavlin	433
312	dpavlin	536	Define new tag for I<search> and I<display>.
313	dpavlin	433
314	dpavlin	536	tag('Title', rec('200','a') );
315	dpavlin	13
316
317			=cut
318
319	dpavlin	536	sub tag {
320			my $name = shift or die "tag needs name as first argument";
321			my @o = grep { defined($_) && $_ ne '' } @_;
322			return unless (@o);
323			$out->{$name}->{tag} = $name;
324			$out->{$name}->{search} = \@o;
325			$out->{$name}->{display} = \@o;
326			}
327	dpavlin	13
328	dpavlin	536	=head2 display
329	dpavlin	13
330	dpavlin	536	Define tag just for I<display>
331	dpavlin	125
332	dpavlin	536	@v = display('Title', rec('200','a') );
333	dpavlin	125
334	dpavlin	536	=cut
335	dpavlin	125
336	dpavlin	536	sub display {
337			my $name = shift or die "display needs name as first argument";
338			my @o = grep { defined($_) && $_ ne '' } @_;
339			return unless (@o);
340			$out->{$name}->{tag} = $name;
341			$out->{$name}->{display} = \@o;
342			}
343	dpavlin	13
344	dpavlin	536	=head2 search
345	dpavlin	13
346	dpavlin	536	Prepare values just for I<search>
347	dpavlin	13
348	dpavlin	536	@v = search('Title', rec('200','a') );
349	dpavlin	433
350	dpavlin	536	=cut
351	dpavlin	13
352	dpavlin	536	sub search {
353			my $name = shift or die "search needs name as first argument";
354			my @o = grep { defined($_) && $_ ne '' } @_;
355			return unless (@o);
356			$out->{$name}->{tag} = $name;
357			$out->{$name}->{search} = \@o;
358	dpavlin	13	}
359
360	dpavlin	564	=head2 marc_leader
361
362			Setup fields within MARC leader or get leader
363
364			marc_leader('05','c');
365			my $leader = marc_leader();
366
367			=cut
368
369			sub marc_leader {
370			my ($offset,$value) = @_;
371
372			if ($offset) {
373			$out->{' leader'}->{ $offset } = $value;
374			} else {
375			return $out->{' leader'};
376			}
377			}
378
379	dpavlin	547	=head2 marc
380	dpavlin	540
381			Save value for MARC field
382
383	dpavlin	547	marc('900','a', rec('200','a') );
384	dpavlin	571	marc('001', rec('000') );
385	dpavlin	540
386			=cut
387
388	dpavlin	547	sub marc {
389			my $f = shift or die "marc needs field";
390			die "marc field must be numer" unless ($f =~ /^\d+$/);
391	dpavlin	540
392	dpavlin	571	my $sf;
393			if ($f >= 10) {
394			$sf = shift or die "marc needs subfield";
395			}
396	dpavlin	540
397	dpavlin	541	foreach (@_) {
398			my $v = $_; # make var read-write for Encode
399	dpavlin	543	next unless (defined($v) && $v !~ /^\s*$/);
400	dpavlin	541	from_to($v, 'iso-8859-2', $marc_encoding) if ($marc_encoding);
401	dpavlin	548	my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');
402	dpavlin	571	if (defined $sf) {
403			push @{ $marc_record }, [ $f, $i1, $i2, $sf => $v ];
404			} else {
405			push @{ $marc_record }, [ $f, $v ];
406			}
407	dpavlin	540	}
408			}
409
410	dpavlin	547	=head2 marc_repeatable_subfield
411
412			Save values for MARC repetable subfield
413
414			marc_repeatable_subfield('910', 'z', rec('909') );
415
416			=cut
417
418			sub marc_repeatable_subfield {
419	dpavlin	550	my ($f,$sf) = @_;
420			die "marc_repeatable_subfield need field and subfield!\n" unless ($f && $sf);
421			$marc_repeatable_subfield->{ $f . $sf }++;
422	dpavlin	547	marc(@_);
423			}
424
425			=head2 marc_indicators
426
427			Set both indicators for MARC field
428
429			marc_indicators('900', ' ', 1);
430
431			Any indicator value other than C<0-9> will be treated as undefined.
432
433			=cut
434
435			sub marc_indicators {
436			my $f = shift \|\| die "marc_indicators need field!\n";
437			my ($i1,$i2) = @_;
438			die "marc_indicators($f, ...) need i1!\n" unless(defined($i1));
439			die "marc_indicators($f, $i1, ...) need i2!\n" unless(defined($i2));
440
441			$i1 = ' ' if ($i1 !~ /^\d$/);
442			$i2 = ' ' if ($i2 !~ /^\d$/);
443	dpavlin	548	@{ $marc_indicators->{$f} } = ($i1,$i2);
444	dpavlin	547	}
445
446	dpavlin	562	=head2 marc_compose
447	dpavlin	547
448	dpavlin	562	Save values for each MARC subfield explicitly
449
450			marc_compose('900',
451			'a', rec('200','a')
452			'b', rec('201','a')
453			'a', rec('200','b')
454			'c', rec('200','c')
455			);
456
457			=cut
458
459			sub marc_compose {
460			my $f = shift or die "marc_compose needs field";
461			die "marc_compose field must be numer" unless ($f =~ /^\d+$/);
462
463			my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');
464			my $m = [ $f, $i1, $i2 ];
465
466			while (@_) {
467			my $sf = shift or die "marc_compose $f needs subfield";
468	dpavlin	565	my $v = shift;
469	dpavlin	562
470			next unless (defined($v) && $v !~ /^\s*$/);
471			from_to($v, 'iso-8859-2', $marc_encoding) if ($marc_encoding);
472			push @$m, ( $sf, $v );
473	dpavlin	568	warn "## ++ marc_compose($f,$sf,$v) ", dump( $m ),$/ if ($debug > 1);
474	dpavlin	562	}
475
476	dpavlin	568	warn "## marc_compose(d) ", dump( $m ),$/ if ($debug > 1);
477	dpavlin	562
478	dpavlin	565	push @{ $marc_record }, $m if ($#{$m} > 2);
479	dpavlin	562	}
480
481
482	dpavlin	540	=head1 Functions to extract data from input
483
484			This function should be used inside functions to create C<data_structure> described
485			above.
486
487	dpavlin	536	=head2 rec1
488	dpavlin	371
489	dpavlin	536	Return all values in some field
490	dpavlin	371
491	dpavlin	536	@v = rec1('200')
492	dpavlin	15
493	dpavlin	536	TODO: order of values is probably same as in source data, need to investigate that
494	dpavlin	15
495	dpavlin	536	=cut
496	dpavlin	15
497	dpavlin	536	sub rec1 {
498			my $f = shift;
499	dpavlin	571	warn "rec1($f) = ", dump( $rec->{$f} ), $/ if ($debug > 1);
500	dpavlin	536	return unless (defined($rec) && defined($rec->{$f}));
501	dpavlin	571	warn "rec1($f) = ", dump( $rec->{$f} ), $/ if ($debug > 1);
502	dpavlin	536	if (ref($rec->{$f}) eq 'ARRAY') {
503			return map {
504			if (ref($_) eq 'HASH') {
505			values %{$_};
506	dpavlin	31	} else {
507	dpavlin	536	$_;
508	dpavlin	31	}
509	dpavlin	536	} @{ $rec->{$f} };
510			} elsif( defined($rec->{$f}) ) {
511			return $rec->{$f};
512	dpavlin	15	}
513			}
514
515	dpavlin	536	=head2 rec2
516	dpavlin	15
517	dpavlin	536	Return all values in specific field and subfield
518	dpavlin	13
519	dpavlin	536	@v = rec2('200','a')
520	dpavlin	13
521			=cut
522
523	dpavlin	536	sub rec2 {
524			my $f = shift;
525			return unless (defined($rec && $rec->{$f}));
526			my $sf = shift;
527			return map { $_->{$sf} } grep { ref($_) eq 'HASH' && $_->{$sf} } @{ $rec->{$f} };
528			}
529	dpavlin	13
530	dpavlin	536	=head2 rec
531	dpavlin	13
532	dpavlin	536	syntaxtic sugar for
533	dpavlin	13
534	dpavlin	536	@v = rec('200')
535			@v = rec('200','a')
536	dpavlin	13
537	dpavlin	536	=cut
538	dpavlin	373
539	dpavlin	536	sub rec {
540			if ($#_ == 0) {
541			return rec1(@_);
542			} elsif ($#_ == 1) {
543			return rec2(@_);
544	dpavlin	13	}
545			}
546
547	dpavlin	536	=head2 regex
548	dpavlin	15
549	dpavlin	536	Apply regex to some or all values
550	dpavlin	15
551	dpavlin	536	@v = regex( 's/foo/bar/g', @v );
552	dpavlin	15
553			=cut
554
555	dpavlin	536	sub regex {
556			my $r = shift;
557			my @out;
558	dpavlin	550	#warn "r: $r\n", dump(\@_);
559	dpavlin	536	foreach my $t (@_) {
560			next unless ($t);
561			eval "\$t =~ $r";
562			push @out, $t if ($t && $t ne '');
563	dpavlin	368	}
564	dpavlin	536	return @out;
565	dpavlin	15	}
566
567	dpavlin	536	=head2 prefix
568	dpavlin	15
569	dpavlin	536	Prefix all values with a string
570	dpavlin	15
571	dpavlin	536	@v = prefix( 'my_', @v );
572	dpavlin	15
573			=cut
574
575	dpavlin	536	sub prefix {
576			my $p = shift or die "prefix needs string as first argument";
577			return map { $p . $_ } grep { defined($_) } @_;
578			}
579	dpavlin	15
580	dpavlin	536	=head2 suffix
581	dpavlin	15
582	dpavlin	536	suffix all values with a string
583	dpavlin	15
584	dpavlin	536	@v = suffix( '_my', @v );
585	dpavlin	15
586	dpavlin	536	=cut
587	dpavlin	15
588	dpavlin	536	sub suffix {
589			my $s = shift or die "suffix needs string as first argument";
590			return map { $_ . $s } grep { defined($_) } @_;
591	dpavlin	15	}
592
593	dpavlin	536	=head2 surround
594	dpavlin	13
595	dpavlin	536	surround all values with a two strings
596	dpavlin	13
597	dpavlin	536	@v = surround( 'prefix_', '_suffix', @v );
598	dpavlin	13
599			=cut
600
601	dpavlin	536	sub surround {
602			my $p = shift or die "surround need prefix as first argument";
603			my $s = shift or die "surround needs suffix as second argument";
604			return map { $p . $_ . $s } grep { defined($_) } @_;
605	dpavlin	13	}
606
607	dpavlin	536	=head2 first
608	dpavlin	13
609	dpavlin	536	Return first element
610	dpavlin	15
611	dpavlin	536	$v = first( @v );
612	dpavlin	13
613			=cut
614
615	dpavlin	536	sub first {
616			my $r = shift;
617			return $r;
618	dpavlin	13	}
619
620	dpavlin	536	=head2 lookup
621	dpavlin	13
622	dpavlin	536	Consult lookup hashes for some value
623	dpavlin	13
624	dpavlin	536	@v = lookup( $v );
625			@v = lookup( @v );
626	dpavlin	13
627			=cut
628
629	dpavlin	536	sub lookup {
630			my $k = shift or return;
631			return unless (defined($lookup->{$k}));
632			if (ref($lookup->{$k}) eq 'ARRAY') {
633			return @{ $lookup->{$k} };
634			} else {
635			return $lookup->{$k};
636			}
637	dpavlin	13	}
638
639	dpavlin	536	=head2 join_with
640	dpavlin	13
641	dpavlin	536	Joins walues with some delimiter
642	dpavlin	10
643	dpavlin	536	$v = join_with(", ", @v);
644	dpavlin	10
645	dpavlin	536	=cut
646	dpavlin	10
647	dpavlin	536	sub join_with {
648			my $d = shift;
649			return join($d, grep { defined($_) && $_ ne '' } @_);
650			}
651	dpavlin	10
652	dpavlin	562	=head2 split_rec_on
653
654			Split record subfield on some regex and take one of parts out
655
656			$a_before_semi_column =
657			split_rec_on('200','a', /\s;\s/, $part);
658
659			C<$part> is optional number of element. First element is
660			B<1>, not 0!
661
662			If there is no C<$part> parameter or C<$part> is 0, this function will
663			return all values produced by splitting.
664
665			=cut
666
667			sub split_rec_on {
668			die "split_rec_on need (fld,sf,regex[,part]" if ($#_ < 2);
669
670			my ($fld, $sf, $regex, $part) = @_;
671	dpavlin	568	warn "### regex ", ref($regex), $regex, $/ if ($debug > 2);
672	dpavlin	562
673			my @r = rec( $fld, $sf );
674			my $v = shift @r;
675	dpavlin	568	warn "### first rec($fld,$sf) = ",dump($v),$/ if ($debug > 2);
676	dpavlin	562
677	dpavlin	566	return '' if( ! defined($v) \|\| $v =~ /^\s*$/);
678
679	dpavlin	562	my @s = split( $regex, $v );
680	dpavlin	568	warn "## split_rec_on($fld,$sf,$regex,$part) = ",dump(@s),$/ if ($debug > 1);
681	dpavlin	566	if ($part && $part > 0) {
682	dpavlin	562	return $s[ $part - 1 ];
683			} else {
684	dpavlin	571	return @s;
685	dpavlin	562	}
686			}
687
688	dpavlin	536	# END
689			1;