7 |
_debug |
_debug |
8 |
_pack_subfields_hash |
_pack_subfields_hash |
9 |
|
|
10 |
|
to |
11 |
search_display search display sorted |
search_display search display sorted |
12 |
|
|
13 |
rec1 rec2 rec |
rec1 rec2 rec |
21 |
get set |
get set |
22 |
count |
count |
23 |
|
|
24 |
|
row |
25 |
|
rec_array |
26 |
|
|
27 |
/; |
/; |
28 |
|
|
29 |
use warnings; |
use warnings; |
50 |
marc_template |
marc_template |
51 |
/); |
/); |
52 |
|
|
53 |
|
use Storable qw/dclone/; |
54 |
|
|
55 |
=head1 NAME |
=head1 NAME |
56 |
|
|
57 |
WebPAC::Normalize - describe normalisaton rules using sets |
WebPAC::Normalize - describe normalisaton rules using sets |
58 |
|
|
59 |
=cut |
=cut |
60 |
|
|
61 |
our $VERSION = '0.35'; |
our $VERSION = '0.36'; |
62 |
|
|
63 |
=head1 SYNOPSIS |
=head1 SYNOPSIS |
64 |
|
|
123 |
$load_row_coderef = $arg->{load_row_coderef}; |
$load_row_coderef = $arg->{load_row_coderef}; |
124 |
|
|
125 |
no strict 'subs'; |
no strict 'subs'; |
126 |
no warnings 'redefine'; |
no warnings 'all'; |
127 |
eval "$arg->{rules};"; |
eval "$arg->{rules};"; |
128 |
die "error evaling $arg->{rules}: $@\n" if ($@); |
die "error evaling [$@] using rules " . $arg->{rules} . "\n" if ($@); |
129 |
|
|
130 |
return _get_ds(); |
return _get_ds(); |
131 |
} |
} |
145 |
$WebPAC::Normalize::MARC::rec = $rec; |
$WebPAC::Normalize::MARC::rec = $rec; |
146 |
} |
} |
147 |
|
|
148 |
=head2 |
=head2 _get_rec |
149 |
|
|
150 |
my $rec = _get_rec(); |
my $rec = _get_rec(); |
151 |
|
|
153 |
|
|
154 |
sub _get_rec { $rec }; |
sub _get_rec { $rec }; |
155 |
|
|
156 |
|
=head2 _set_rec |
157 |
|
|
158 |
|
_set_rec( $rec ); |
159 |
|
|
160 |
|
=cut |
161 |
|
|
162 |
|
sub _set_rec { $rec = $_[0] } |
163 |
|
|
164 |
=head2 _set_config |
=head2 _set_config |
165 |
|
|
166 |
Set current config hash |
Set current config hash |
283 |
|
|
284 |
Those functions generally have to first in your normalization file. |
Those functions generally have to first in your normalization file. |
285 |
|
|
286 |
|
=head2 to |
287 |
|
|
288 |
|
Generic way to set values for some name |
289 |
|
|
290 |
|
to('field-name', 'name-value' => rec('200','a') ); |
291 |
|
|
292 |
|
There are many helpers defined below which might be easier to use. |
293 |
|
|
294 |
|
=cut |
295 |
|
|
296 |
|
sub to { |
297 |
|
my $type = shift or confess "need type -- BUG?"; |
298 |
|
my $name = shift or confess "needs name as first argument"; |
299 |
|
my @o = grep { defined($_) && $_ ne '' } @_; |
300 |
|
return unless (@o); |
301 |
|
$out->{$name}->{$type} = \@o; |
302 |
|
} |
303 |
|
|
304 |
=head2 search_display |
=head2 search_display |
305 |
|
|
306 |
Define output for L<search> and L<display> at the same time |
Define output for L<search> and L<display> at the same time |
307 |
|
|
308 |
search_display('Title', rec('200','a') ); |
search_display('Title', rec('200','a') ); |
309 |
|
|
|
|
|
310 |
=cut |
=cut |
311 |
|
|
312 |
sub search_display { |
sub search_display { |
319 |
|
|
320 |
=head2 tag |
=head2 tag |
321 |
|
|
322 |
Old name for L<search_display>, but supported |
Old name for L<search_display>, it will probably be removed at one point. |
323 |
|
|
324 |
=cut |
=cut |
325 |
|
|
335 |
|
|
336 |
=cut |
=cut |
337 |
|
|
338 |
sub _field { |
sub display { to( 'display', @_ ) } |
|
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}->{$type} = \@o; |
|
|
} |
|
|
|
|
|
sub display { _field( 'display', @_ ) } |
|
339 |
|
|
340 |
=head2 search |
=head2 search |
341 |
|
|
345 |
|
|
346 |
=cut |
=cut |
347 |
|
|
348 |
sub search { _field( 'search', @_ ) } |
sub search { to( 'search', @_ ) } |
349 |
|
|
350 |
=head2 sorted |
=head2 sorted |
351 |
|
|
355 |
|
|
356 |
=cut |
=cut |
357 |
|
|
358 |
sub sorted { _field( 'sorted', @_ ) } |
sub sorted { to( 'sorted', @_ ) } |
359 |
|
|
360 |
|
=head2 row |
361 |
|
|
362 |
|
Insert new row of data into output module |
363 |
|
|
364 |
|
row( column => 'foo', column2 => 'bar' ); |
365 |
|
|
366 |
|
=cut |
367 |
|
|
368 |
|
use Data::Dump qw/dump/; |
369 |
|
|
370 |
|
sub row { |
371 |
|
die "array doesn't have odd number of elements but $#_: ",dump( @_ ) if $#_ % 2 == 1; |
372 |
|
my $table = shift @_; |
373 |
|
push @{ $out->{'_rows'}->{$table} }, {@_}; |
374 |
|
} |
375 |
|
|
376 |
|
|
377 |
=head1 Functions to extract data from input |
=head1 Functions to extract data from input |
393 |
|
|
394 |
warn "## _pack_subfields_hash( ",dump(@_), " )\n" if ($debug > 1); |
warn "## _pack_subfields_hash( ",dump(@_), " )\n" if ($debug > 1); |
395 |
|
|
396 |
my ($h,$include_subfields) = @_; |
my ($hash,$include_subfields) = @_; |
397 |
|
|
398 |
# sanity and ease of use |
# sanity and ease of use |
399 |
return $h if (ref($h) ne 'HASH'); |
return $hash if (ref($hash) ne 'HASH'); |
400 |
|
|
401 |
|
my $h = dclone( $hash ); |
402 |
|
|
403 |
if ( defined($h->{subfields}) ) { |
if ( defined($h->{subfields}) ) { |
404 |
my $sfs = delete $h->{subfields} || die "no subfields?"; |
my $sfs = delete $h->{subfields} || die "no subfields?"; |
489 |
} else { |
} else { |
490 |
$_->{$sf}; |
$_->{$sf}; |
491 |
} |
} |
492 |
} grep { ref($_) eq 'HASH' && $_->{$sf} } @{ $rec->{$f} }; |
} grep { ref($_) eq 'HASH' && defined $_->{$sf} } @{ $rec->{$f} }; |
493 |
} |
} |
494 |
|
|
495 |
=head2 rec |
=head2 rec |
958 |
return @_ . ''; |
return @_ . ''; |
959 |
} |
} |
960 |
|
|
961 |
|
=head2 rec_array |
962 |
|
|
963 |
|
Always return field as array |
964 |
|
|
965 |
|
foreach my $d ( rec_array('field') ) { |
966 |
|
warn $d; |
967 |
|
} |
968 |
|
|
969 |
|
=cut |
970 |
|
|
971 |
|
sub rec_array { |
972 |
|
my $d = $rec->{ $_[0] }; |
973 |
|
return @$d if ref($d) eq 'ARRAY'; |
974 |
|
return ($d); |
975 |
|
} |
976 |
|
|
977 |
# END |
# END |
978 |
1; |
1; |