lib/WebPAC/Normalize.pm

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

        tag search display
        marc marc_indicators marc_repeatable_subfield

        rec1 rec2 rec
        regex prefix suffix surround
        first lookup join_with
/;

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.06

=cut

our $VERSION = '0.06';

=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 if there is second occurence of same subfield or
if any of indicators are different. This is sane for most cases except for
non-repeatable fields with repeatable subfields.

You can change behaviour of that using C<marc_repeatable_subfield>.

=cut

sub _get_marc_fields {


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

                }

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

=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

Save value for MARC field

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

=cut

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

        my $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} } : (' ',' ');
                push @{ $marc_record }, [ $f, $i1, $i2, $sf => $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);
}


=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;
        return unless (defined($rec) && defined($rec->{$f}));
        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 '' } @_);
}

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