/[webpac2]/trunk/lib/WebPAC/Normalize.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /trunk/lib/WebPAC/Normalize.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 785 - (show annotations)
Wed Dec 6 23:44:36 2006 UTC (16 years, 2 months ago) by dpavlin
File size: 27993 byte(s)
added get and set to create in-memory hash

1 package WebPAC::Normalize;
2 use Exporter 'import';
3 @EXPORT = qw/
4 _set_rec _set_lookup
5 _set_load_row
6 _get_ds _clean_ds
7 _debug
8 _pack_subfields_hash
9
10 tag search display
11 marc marc_indicators marc_repeatable_subfield
12 marc_compose marc_leader
13 marc_duplicate marc_remove
14 marc_original_order
15
16 rec1 rec2 rec
17 regex prefix suffix surround
18 first lookup join_with
19 save_into_lookup
20
21 split_rec_on
22
23 get set
24 /;
25
26 use warnings;
27 use strict;
28
29 #use base qw/WebPAC::Common/;
30 use Data::Dump qw/dump/;
31 use Storable qw/dclone/;
32 use Carp qw/confess/;
33
34 # debugging warn(s)
35 my $debug = 0;
36
37
38 =head1 NAME
39
40 WebPAC::Normalize - describe normalisaton rules using sets
41
42 =head1 VERSION
43
44 Version 0.24
45
46 =cut
47
48 our $VERSION = '0.24';
49
50 =head1 SYNOPSIS
51
52 This module uses C<conf/normalize/*.pl> files to perform normalisation
53 from input records using perl functions which are specialized for set
54 processing.
55
56 Sets are implemented as arrays, and normalisation file is valid perl, which
57 means that you check it's validity before running WebPAC using
58 C<perl -c normalize.pl>.
59
60 Normalisation can generate multiple output normalized data. For now, supported output
61 types (on the left side of definition) are: C<tag>, C<display>, C<search> and
62 C<marc>.
63
64 =head1 FUNCTIONS
65
66 Functions which start with C<_> are private and used by WebPAC internally.
67 All other functions are available for use within normalisation rules.
68
69 =head2 data_structure
70
71 Return data structure
72
73 my $ds = WebPAC::Normalize::data_structure(
74 lookup => $lookup_hash,
75 row => $row,
76 rules => $normalize_pl_config,
77 marc_encoding => 'utf-8',
78 config => $config,
79 load_row_coderef => sub {
80 my ($database,$input,$mfn) = shift;
81 $store->load_row( database => $database, input => $input, id => $mfn );
82 },
83 );
84
85 Options C<row>, C<rules> and C<log> are mandatory while all
86 other are optional.
87
88 C<load_row_coderef> is closure only used when executing lookups, so they will
89 die if it's not defined.
90
91 This function will B<die> if normalizastion can't be evaled.
92
93 Since this function isn't exported you have to call it with
94 C<WebPAC::Normalize::data_structure>.
95
96 =cut
97
98 my $load_row_coderef;
99
100 sub data_structure {
101 my $arg = {@_};
102
103 die "need row argument" unless ($arg->{row});
104 die "need normalisation argument" unless ($arg->{rules});
105
106 no strict 'subs';
107 _set_lookup( $arg->{lookup} ) if defined($arg->{lookup});
108 _set_rec( $arg->{row} );
109 _set_config( $arg->{config} ) if defined($arg->{config});
110 _clean_ds( %{ $arg } );
111 $load_row_coderef = $arg->{load_row_coderef};
112
113 eval "$arg->{rules}";
114 die "error evaling $arg->{rules}: $@\n" if ($@);
115
116 return _get_ds();
117 }
118
119 =head2 _set_rec
120
121 Set current record hash
122
123 _set_rec( $rec );
124
125 =cut
126
127 my $rec;
128
129 sub _set_rec {
130 $rec = shift or die "no record hash";
131 }
132
133 =head2 _set_config
134
135 Set current config hash
136
137 _set_config( $config );
138
139 Magic keys are:
140
141 =over 4
142
143 =item _
144
145 Code of current database
146
147 =item _mfn
148
149 Current MFN
150
151 =back
152
153 =cut
154
155 my $config;
156
157 sub _set_config {
158 $config = shift;
159 }
160
161 =head2 _get_ds
162
163 Return hash formatted as data structure
164
165 my $ds = _get_ds();
166
167 =cut
168
169 my ($out, $marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators, $leader);
170 my ($marc_record_offset, $marc_fetch_offset) = (0, 0);
171
172 sub _get_ds {
173 return $out;
174 }
175
176 =head2 _clean_ds
177
178 Clean data structure hash for next record
179
180 _clean_ds();
181
182 =cut
183
184 sub _clean_ds {
185 my $a = {@_};
186 ($out,$marc_record, $marc_encoding, $marc_repeatable_subfield, $marc_indicators, $leader) = ();
187 ($marc_record_offset, $marc_fetch_offset) = (0,0);
188 $marc_encoding = $a->{marc_encoding};
189 }
190
191 =head2 _set_lookup
192
193 Set current lookup hash
194
195 _set_lookup( $lookup );
196
197 =cut
198
199 my $lookup;
200
201 sub _set_lookup {
202 $lookup = shift;
203 }
204
205 =head2 _get_lookup
206
207 Get current lookup hash
208
209 my $lookup = _get_lookup();
210
211 =cut
212
213 sub _get_lookup {
214 return $lookup;
215 }
216
217 =head2 _set_load_row
218
219 Setup code reference which will return L<data_structure> from
220 L<WebPAC::Store>
221
222 _set_load_row(sub {
223 my ($database,$input,$mfn) = @_;
224 $store->load_row( database => $database, input => $input, id => $mfn );
225 });
226
227 =cut
228
229 sub _set_load_row {
230 my $coderef = shift;
231 confess "argument isn't CODE" unless ref($coderef) eq 'CODE';
232
233 $load_row_coderef = $coderef;
234 }
235
236 =head2 _get_marc_fields
237
238 Get all fields defined by calls to C<marc>
239
240 $marc->add_fields( WebPAC::Normalize:_get_marc_fields() );
241
242 We are using I<magic> which detect repeatable fields only from
243 sequence of field/subfield data generated by normalization.
244
245 Repeatable field is created when there is second occurence of same subfield or
246 if any of indicators are different.
247
248 This is sane for most cases. Something like:
249
250 900a-1 900b-1 900c-1
251 900a-2 900b-2
252 900a-3
253
254 will be created from any combination of:
255
256 900a-1 900a-2 900a-3 900b-1 900b-2 900c-1
257
258 and following rules:
259
260 marc('900','a', rec('200','a') );
261 marc('900','b', rec('200','b') );
262 marc('900','c', rec('200','c') );
263
264 which might not be what you have in mind. If you need repeatable subfield,
265 define it using C<marc_repeatable_subfield> like this:
266
267 marc_repeatable_subfield('900','a');
268 marc('900','a', rec('200','a') );
269 marc('900','b', rec('200','b') );
270 marc('900','c', rec('200','c') );
271
272 will create:
273
274 900a-1 900a-2 900a-3 900b-1 900c-1
275 900b-2
276
277 There is also support for returning next or specific using:
278
279 while (my $mf = WebPAC::Normalize:_get_marc_fields( fetch_next => 1 ) ) {
280 # do something with $mf
281 }
282
283 will always return fields from next MARC record or
284
285 my $mf = WebPAC::Normalize::_get_marc_fields( offset => 42 );
286
287 will return 42th copy record (if it exists).
288
289 =cut
290
291 sub _get_marc_fields {
292
293 my $arg = {@_};
294 warn "### _get_marc_fields arg: ", dump($arg), $/ if ($debug > 2);
295 my $offset = $marc_fetch_offset;
296 if ($arg->{offset}) {
297 $offset = $arg->{offset};
298 } elsif($arg->{fetch_next}) {
299 $marc_fetch_offset++;
300 }
301
302 return if (! $marc_record || ref($marc_record) ne 'ARRAY');
303
304 warn "### full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 2);
305
306 my $marc_rec = $marc_record->[ $offset ];
307
308 warn "## _get_marc_fields (at offset: $offset) -- marc_record = ", dump( @$marc_rec ), $/ if ($debug > 1);
309
310 return if (! $marc_rec || ref($marc_rec) ne 'ARRAY' || $#{ $marc_rec } < 0);
311
312 # first, sort all existing fields
313 # XXX might not be needed, but modern perl might randomize elements in hash
314 my @sorted_marc_record = sort {
315 $a->[0] . ( $a->[3] || '' ) cmp $b->[0] . ( $b->[3] || '')
316 } @{ $marc_rec };
317
318 @sorted_marc_record = @{ $marc_rec }; ### FIXME disable sorting
319
320 # output marc fields
321 my @m;
322
323 # count unique field-subfields (used for offset when walking to next subfield)
324 my $u;
325 map { $u->{ $_->[0] . ( $_->[3] || '') }++ } @sorted_marc_record;
326
327 if ($debug) {
328 warn "## marc_repeatable_subfield = ", dump( $marc_repeatable_subfield ), $/ if ( $marc_repeatable_subfield );
329 warn "## marc_record[$offset] = ", dump( $marc_rec ), $/;
330 warn "## sorted_marc_record = ", dump( \@sorted_marc_record ), $/;
331 warn "## subfield count = ", dump( $u ), $/;
332 }
333
334 my $len = $#sorted_marc_record;
335 my $visited;
336 my $i = 0;
337 my $field;
338
339 foreach ( 0 .. $len ) {
340
341 # find next element which isn't visited
342 while ($visited->{$i}) {
343 $i = ($i + 1) % ($len + 1);
344 }
345
346 # mark it visited
347 $visited->{$i}++;
348
349 my $row = dclone( $sorted_marc_record[$i] );
350
351 # field and subfield which is key for
352 # marc_repeatable_subfield and u
353 my $fsf = $row->[0] . ( $row->[3] || '' );
354
355 if ($debug > 1) {
356
357 print "### field so far [", $#$field, "] : ", dump( $field ), " ", $field ? 'T' : 'F', $/;
358 print "### this [$i]: ", dump( $row ),$/;
359 print "### sf: ", $row->[3], " vs ", $field->[3],
360 $marc_repeatable_subfield->{ $row->[0] . $row->[3] } ? ' (repeatable)' : '', $/,
361 if ($#$field >= 0);
362
363 }
364
365 # if field exists
366 if ( $#$field >= 0 ) {
367 if (
368 $row->[0] ne $field->[0] || # field
369 $row->[1] ne $field->[1] || # i1
370 $row->[2] ne $field->[2] # i2
371 ) {
372 push @m, $field;
373 warn "## saved/1 ", dump( $field ),$/ if ($debug);
374 $field = $row;
375
376 } elsif (
377 ( $row->[3] lt $field->[-2] ) # subfield which is not next (e.g. a after c)
378 ||
379 ( $row->[3] eq $field->[-2] && # same subfield, but not repeatable
380 ! $marc_repeatable_subfield->{ $fsf }
381 )
382 ) {
383 push @m, $field;
384 warn "## saved/2 ", dump( $field ),$/ if ($debug);
385 $field = $row;
386
387 } else {
388 # append new subfields to existing field
389 push @$field, ( $row->[3], $row->[4] );
390 }
391 } else {
392 # insert first field
393 $field = $row;
394 }
395
396 if (! $marc_repeatable_subfield->{ $fsf }) {
397 # make step to next subfield
398 $i = ($i + $u->{ $fsf } ) % ($len + 1);
399 }
400 }
401
402 if ($#$field >= 0) {
403 push @m, $field;
404 warn "## saved/3 ", dump( $field ),$/ if ($debug);
405 }
406
407 return \@m;
408 }
409
410 =head2 _debug
411
412 Change level of debug warnings
413
414 _debug( 2 );
415
416 =cut
417
418 sub _debug {
419 my $l = shift;
420 return $debug unless defined($l);
421 warn "debug level $l",$/ if ($l > 0);
422 $debug = $l;
423 }
424
425 =head1 Functions to create C<data_structure>
426
427 Those functions generally have to first in your normalization file.
428
429 =head2 tag
430
431 Define new tag for I<search> and I<display>.
432
433 tag('Title', rec('200','a') );
434
435
436 =cut
437
438 sub tag {
439 my $name = shift or die "tag needs name as first argument";
440 my @o = grep { defined($_) && $_ ne '' } @_;
441 return unless (@o);
442 $out->{$name}->{tag} = $name;
443 $out->{$name}->{search} = \@o;
444 $out->{$name}->{display} = \@o;
445 }
446
447 =head2 display
448
449 Define tag just for I<display>
450
451 @v = display('Title', rec('200','a') );
452
453 =cut
454
455 sub display {
456 my $name = shift or die "display needs name as first argument";
457 my @o = grep { defined($_) && $_ ne '' } @_;
458 return unless (@o);
459 $out->{$name}->{tag} = $name;
460 $out->{$name}->{display} = \@o;
461 }
462
463 =head2 search
464
465 Prepare values just for I<search>
466
467 @v = search('Title', rec('200','a') );
468
469 =cut
470
471 sub search {
472 my $name = shift or die "search needs name as first argument";
473 my @o = grep { defined($_) && $_ ne '' } @_;
474 return unless (@o);
475 $out->{$name}->{tag} = $name;
476 $out->{$name}->{search} = \@o;
477 }
478
479 =head2 marc_leader
480
481 Setup fields within MARC leader or get leader
482
483 marc_leader('05','c');
484 my $leader = marc_leader();
485
486 =cut
487
488 sub marc_leader {
489 my ($offset,$value) = @_;
490
491 if ($offset) {
492 $leader->{ $offset } = $value;
493 } else {
494 return $leader;
495 }
496 }
497
498 =head2 marc
499
500 Save value for MARC field
501
502 marc('900','a', rec('200','a') );
503 marc('001', rec('000') );
504
505 =cut
506
507 sub marc {
508 my $f = shift or die "marc needs field";
509 die "marc field must be numer" unless ($f =~ /^\d+$/);
510
511 my $sf;
512 if ($f >= 10) {
513 $sf = shift or die "marc needs subfield";
514 }
515
516 foreach (@_) {
517 my $v = $_; # make var read-write for Encode
518 next unless (defined($v) && $v !~ /^\s*$/);
519 my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');
520 if (defined $sf) {
521 push @{ $marc_record->[ $marc_record_offset ] }, [ $f, $i1, $i2, $sf => $v ];
522 } else {
523 push @{ $marc_record->[ $marc_record_offset ] }, [ $f, $v ];
524 }
525 }
526 }
527
528 =head2 marc_repeatable_subfield
529
530 Save values for MARC repetable subfield
531
532 marc_repeatable_subfield('910', 'z', rec('909') );
533
534 =cut
535
536 sub marc_repeatable_subfield {
537 my ($f,$sf) = @_;
538 die "marc_repeatable_subfield need field and subfield!\n" unless ($f && $sf);
539 $marc_repeatable_subfield->{ $f . $sf }++;
540 marc(@_);
541 }
542
543 =head2 marc_indicators
544
545 Set both indicators for MARC field
546
547 marc_indicators('900', ' ', 1);
548
549 Any indicator value other than C<0-9> will be treated as undefined.
550
551 =cut
552
553 sub marc_indicators {
554 my $f = shift || die "marc_indicators need field!\n";
555 my ($i1,$i2) = @_;
556 die "marc_indicators($f, ...) need i1!\n" unless(defined($i1));
557 die "marc_indicators($f, $i1, ...) need i2!\n" unless(defined($i2));
558
559 $i1 = ' ' if ($i1 !~ /^\d$/);
560 $i2 = ' ' if ($i2 !~ /^\d$/);
561 @{ $marc_indicators->{$f} } = ($i1,$i2);
562 }
563
564 =head2 marc_compose
565
566 Save values for each MARC subfield explicitly
567
568 marc_compose('900',
569 'a', rec('200','a')
570 'b', rec('201','a')
571 'a', rec('200','b')
572 'c', rec('200','c')
573 );
574
575 If you specify C<+> for subfield, value will be appended
576 to previous defined subfield.
577
578 =cut
579
580 sub marc_compose {
581 my $f = shift or die "marc_compose needs field";
582 die "marc_compose field must be numer" unless ($f =~ /^\d+$/);
583
584 my ($i1,$i2) = defined($marc_indicators->{$f}) ? @{ $marc_indicators->{$f} } : (' ',' ');
585 my $m = [ $f, $i1, $i2 ];
586
587 warn "### marc_compose input subfields = ", dump(@_),$/ if ($debug > 2);
588
589 if ($#_ % 2 != 1) {
590 die "ERROR: marc_compose",dump($f,@_)," not valid (must be even).\nDo you need to add first() or join() around some argument?\n";
591 }
592
593 while (@_) {
594 my $sf = shift;
595 my $v = shift;
596
597 next unless (defined($v) && $v !~ /^\s*$/);
598 warn "## ++ marc_compose($f,$sf,$v) ", dump( $m ),$/ if ($debug > 1);
599 if ($sf ne '+') {
600 push @$m, ( $sf, $v );
601 } else {
602 $m->[ $#$m ] .= $v;
603 }
604 }
605
606 warn "## marc_compose current marc = ", dump( $m ),$/ if ($debug > 1);
607
608 push @{ $marc_record->[ $marc_record_offset ] }, $m if ($#{$m} > 2);
609 }
610
611 =head2 marc_duplicate
612
613 Generate copy of current MARC record and continue working on copy
614
615 marc_duplicate();
616
617 Copies can be accessed using C<< _get_marc_fields( fetch_next => 1 ) >> or
618 C<< _get_marc_fields( offset => 42 ) >>.
619
620 =cut
621
622 sub marc_duplicate {
623 my $m = $marc_record->[ -1 ];
624 die "can't duplicate record which isn't defined" unless ($m);
625 push @{ $marc_record }, dclone( $m );
626 warn "## marc_duplicate = ", dump(@$marc_record), $/ if ($debug > 1);
627 $marc_record_offset = $#{ $marc_record };
628 warn "## marc_record_offset = $marc_record_offset", $/ if ($debug > 1);
629 }
630
631 =head2 marc_remove
632
633 Remove some field or subfield from MARC record.
634
635 marc_remove('200');
636 marc_remove('200','a');
637
638 This will erase field C<200> or C<200^a> from current MARC record.
639
640 This is useful after calling C<marc_duplicate> or on it's own (but, you
641 should probably just remove that subfield definition if you are not
642 using C<marc_duplicate>).
643
644 FIXME: support fields < 10.
645
646 =cut
647
648 sub marc_remove {
649 my ($f, $sf) = @_;
650
651 die "marc_remove needs record number" unless defined($f);
652
653 my $marc = $marc_record->[ $marc_record_offset ];
654
655 warn "### marc_remove before = ", dump( $marc ), $/ if ($debug > 2);
656
657 my $i = 0;
658 foreach ( 0 .. $#{ $marc } ) {
659 last unless (defined $marc->[$i]);
660 warn "#### working on ",dump( @{ $marc->[$i] }), $/ if ($debug > 3);
661 if ($marc->[$i]->[0] eq $f) {
662 if (! defined $sf) {
663 # remove whole field
664 splice @$marc, $i, 1;
665 warn "#### slice \@\$marc, $i, 1 = ",dump( @{ $marc }), $/ if ($debug > 3);
666 $i--;
667 } else {
668 foreach my $j ( 0 .. (( $#{ $marc->[$i] } - 3 ) / 2) ) {
669 my $o = ($j * 2) + 3;
670 if ($marc->[$i]->[$o] eq $sf) {
671 # remove subfield
672 splice @{$marc->[$i]}, $o, 2;
673 warn "#### slice \@{\$marc->[$i]}, $o, 2 = ", dump( @{ $marc }), $/ if ($debug > 3);
674 # is record now empty?
675 if ($#{ $marc->[$i] } == 2) {
676 splice @$marc, $i, 1;
677 warn "#### slice \@\$marc, $i, 1 = ", dump( @{ $marc }), $/ if ($debug > 3);
678 $i--;
679 };
680 }
681 }
682 }
683 }
684 $i++;
685 }
686
687 warn "### marc_remove($f", $sf ? ",$sf" : "", ") after = ", dump( $marc ), $/ if ($debug > 2);
688
689 $marc_record->[ $marc_record_offset ] = $marc;
690
691 warn "## full marc_record = ", dump( @{ $marc_record }), $/ if ($debug > 1);
692 }
693
694 =head2 marc_original_order
695
696 Copy all subfields preserving original order to marc field.
697
698 marc_original_order( marc_field_number, original_input_field_number );
699
700 Please note that field numbers are consistent with other commands (marc
701 field number first), but somewhat counter-intuitive (destination and then
702 source).
703
704 You might want to use this command if you are just renaming subfields or
705 using pre-processing modify_record in C<config.yml> and don't need any
706 post-processing or want to preserve order of original subfields.
707
708
709 =cut
710
711 sub marc_original_order {
712
713 my ($to, $from) = @_;
714 die "marc_original_order needs from and to fields\n" unless ($from && $to);
715
716 return unless defined($rec->{$from});
717
718 my $r = $rec->{$from};
719 die "record field $from isn't array\n" unless (ref($r) eq 'ARRAY');
720
721 my ($i1,$i2) = defined($marc_indicators->{$to}) ? @{ $marc_indicators->{$to} } : (' ',' ');
722 warn "## marc_original_order($to,$from) source = ", dump( $r ),$/ if ($debug > 1);
723
724 foreach my $d (@$r) {
725
726 if (! defined($d->{subfields}) && ref($d->{subfields}) ne 'ARRAY') {
727 warn "# marc_original_order($to,$from): field $from doesn't have subfields specification\n";
728 next;
729 }
730
731 my @sfs = @{ $d->{subfields} };
732
733 die "field $from doesn't have even number of subfields specifications\n" unless($#sfs % 2 == 1);
734
735 warn "#--> d: ",dump($d), "\n#--> sfs: ",dump(@sfs),$/ if ($debug > 2);
736
737 my $m = [ $to, $i1, $i2 ];
738
739 while (my $sf = shift @sfs) {
740
741 warn "#--> sf: ",dump($sf), $/ if ($debug > 2);
742 my $offset = shift @sfs;
743 die "corrupted sufields specification for field $from\n" unless defined($offset);
744
745 my $v;
746 if (ref($d->{$sf}) eq 'ARRAY') {
747 $v = $d->{$sf}->[$offset] if (defined($d->{$sf}->[$offset]));
748 } elsif ($offset == 0) {
749 $v = $d->{$sf};
750 } else {
751 die "field $from subfield '$sf' need occurence $offset which doesn't exist", dump($d->{$sf});
752 }
753 push @$m, ( $sf, $v ) if (defined($v));
754 }
755
756 if ($#{$m} > 2) {
757 push @{ $marc_record->[ $marc_record_offset ] }, $m;
758 }
759 }
760
761 warn "## marc_record = ", dump( $marc_record ),$/ if ($debug > 1);
762 }
763
764
765 =head1 Functions to extract data from input
766
767 This function should be used inside functions to create C<data_structure> described
768 above.
769
770 =head2 _pack_subfields_hash
771
772 @subfields = _pack_subfields_hash( $h );
773 $subfields = _pack_subfields_hash( $h, 1 );
774
775 Return each subfield value in array or pack them all together and return scalar
776 with subfields (denoted by C<^>) and values.
777
778 =cut
779
780 sub _pack_subfields_hash {
781
782 warn "## _pack_subfields_hash( ",dump(@_), " )\n" if ($debug > 1);
783
784 my ($h,$include_subfields) = @_;
785
786 if ( defined($h->{subfields}) ) {
787 my $sfs = delete $h->{subfields} || die "no subfields?";
788 my @out;
789 while (@$sfs) {
790 my $sf = shift @$sfs;
791 push @out, '^' . $sf if ($include_subfields);
792 my $o = shift @$sfs;
793 if ($o == 0 && ref( $h->{$sf} ) ne 'ARRAY' ) {
794 # single element subfields are not arrays
795 #warn "====> $sf $o / $#$sfs ", dump( $sfs, $h->{$sf} ), "\n";
796
797 push @out, $h->{$sf};
798 } else {
799 #warn "====> $sf $o / $#$sfs ", dump( $sfs, $h->{$sf} ), "\n";
800 push @out, $h->{$sf}->[$o];
801 }
802 }
803 if ($include_subfields) {
804 return join('', @out);
805 } else {
806 return @out;
807 }
808 } else {
809 if ($include_subfields) {
810 my $out = '';
811 foreach my $sf (sort keys %$h) {
812 if (ref($h->{$sf}) eq 'ARRAY') {
813 $out .= '^' . $sf . join('^' . $sf, @{ $h->{$sf} });
814 } else {
815 $out .= '^' . $sf . $h->{$sf};
816 }
817 }
818 return $out;
819 } else {
820 # FIXME this should probably be in alphabetical order instead of hash order
821 values %{$h};
822 }
823 }
824 }
825
826 =head2 rec1
827
828 Return all values in some field
829
830 @v = rec1('200')
831
832 TODO: order of values is probably same as in source data, need to investigate that
833
834 =cut
835
836 sub rec1 {
837 my $f = shift;
838 warn "rec1($f) = ", dump( $rec->{$f} ), $/ if ($debug > 1);
839 return unless (defined($rec) && defined($rec->{$f}));
840 warn "rec1($f) = ", dump( $rec->{$f} ), $/ if ($debug > 1);
841 if (ref($rec->{$f}) eq 'ARRAY') {
842 my @out;
843 foreach my $h ( @{ $rec->{$f} } ) {
844 if (ref($h) eq 'HASH') {
845 push @out, ( _pack_subfields_hash( $h ) );
846 } else {
847 push @out, $h;
848 }
849 }
850 return @out;
851 } elsif( defined($rec->{$f}) ) {
852 return $rec->{$f};
853 }
854 }
855
856 =head2 rec2
857
858 Return all values in specific field and subfield
859
860 @v = rec2('200','a')
861
862 =cut
863
864 sub rec2 {
865 my $f = shift;
866 return unless (defined($rec && $rec->{$f}));
867 my $sf = shift;
868 warn "rec2($f,$sf) = ", dump( $rec->{$f} ), $/ if ($debug > 1);
869 return map {
870 if (ref($_->{$sf}) eq 'ARRAY') {
871 @{ $_->{$sf} };
872 } else {
873 $_->{$sf};
874 }
875 } grep { ref($_) eq 'HASH' && $_->{$sf} } @{ $rec->{$f} };
876 }
877
878 =head2 rec
879
880 syntaxtic sugar for
881
882 @v = rec('200')
883 @v = rec('200','a')
884
885 If rec() returns just single value, it will
886 return scalar, not array.
887
888 =cut
889
890 sub rec {
891 my @out;
892 if ($#_ == 0) {
893 @out = rec1(@_);
894 } elsif ($#_ == 1) {
895 @out = rec2(@_);
896 }
897 if ($#out == 0 && ! wantarray) {
898 return $out[0];
899 } elsif (@out) {
900 return @out;
901 } else {
902 return '';
903 }
904 }
905
906 =head2 regex
907
908 Apply regex to some or all values
909
910 @v = regex( 's/foo/bar/g', @v );
911
912 =cut
913
914 sub regex {
915 my $r = shift;
916 my @out;
917 #warn "r: $r\n", dump(\@_);
918 foreach my $t (@_) {
919 next unless ($t);
920 eval "\$t =~ $r";
921 push @out, $t if ($t && $t ne '');
922 }
923 return @out;
924 }
925
926 =head2 prefix
927
928 Prefix all values with a string
929
930 @v = prefix( 'my_', @v );
931
932 =cut
933
934 sub prefix {
935 my $p = shift or return;
936 return map { $p . $_ } grep { defined($_) } @_;
937 }
938
939 =head2 suffix
940
941 suffix all values with a string
942
943 @v = suffix( '_my', @v );
944
945 =cut
946
947 sub suffix {
948 my $s = shift or die "suffix needs string as first argument";
949 return map { $_ . $s } grep { defined($_) } @_;
950 }
951
952 =head2 surround
953
954 surround all values with a two strings
955
956 @v = surround( 'prefix_', '_suffix', @v );
957
958 =cut
959
960 sub surround {
961 my $p = shift or die "surround need prefix as first argument";
962 my $s = shift or die "surround needs suffix as second argument";
963 return map { $p . $_ . $s } grep { defined($_) } @_;
964 }
965
966 =head2 first
967
968 Return first element
969
970 $v = first( @v );
971
972 =cut
973
974 sub first {
975 my $r = shift;
976 return $r;
977 }
978
979 =head2 lookup
980
981 Consult lookup hashes for some value
982
983 @v = lookup(
984 sub {
985 'ffkk/peri/mfn'.rec('000')
986 },
987 'ffkk','peri','200-a-200-e',
988 sub {
989 first(rec(200,'a')).' '.first(rec('200','e'))
990 }
991 );
992
993 Code like above will be B<automatically generated> using L<WebPAC::Parse> from
994 normal lookup definition in C<conf/lookup/something.pl> which looks like:
995
996 lookup(
997 # which results to return from record recorded in lookup
998 sub { 'ffkk/peri/mfn' . rec('000') },
999 # from which database and input
1000 'ffkk','peri',
1001 # such that following values match
1002 sub { first(rec(200,'a')) . ' ' . first(rec('200','e')) },
1003 # if this part is missing, we will try to match same fields
1004 # from lookup record and current one, or you can override
1005 # which records to use from current record using
1006 sub { rec('900','x') . ' ' . rec('900','y') },
1007 )
1008
1009 You can think about this lookup as SQL (if that helps):
1010
1011 select
1012 sub { what }
1013 from
1014 database, input
1015 where
1016 sub { filter from lookuped record }
1017 having
1018 sub { optional filter on current record }
1019
1020 Easy as pie, right?
1021
1022 =cut
1023
1024 sub lookup {
1025 my ($what, $database, $input, $key, $having) = @_;
1026
1027 confess "lookup needs 5 arguments: what, database, input, key, having\n" unless ($#_ == 4);
1028
1029 warn "## lookup ($database, $input, $key)", $/ if ($debug > 1);
1030 return unless (defined($lookup->{$database}->{$input}->{$key}));
1031
1032 confess "lookup really need load_row_coderef added to data_structure\n" unless ($load_row_coderef);
1033
1034 my $mfns;
1035 my @having = $having->();
1036
1037 warn "## having = ", dump( @having ) if ($debug > 2);
1038
1039 foreach my $h ( @having ) {
1040 if (defined($lookup->{$database}->{$input}->{$key}->{$h})) {
1041 warn "lookup for $database/$input/$key/$h return ",dump($lookup->{$database}->{$input}->{$key}->{$h}),"\n" if ($debug);
1042 $mfns->{$_}++ foreach keys %{ $lookup->{$database}->{$input}->{$key}->{$h} };
1043 }
1044 }
1045
1046 return unless ($mfns);
1047
1048 my @mfns = sort keys %$mfns;
1049
1050 warn "# lookup loading $database/$input/$key mfn ", join(",",@mfns)," having ",dump(@having),"\n" if ($debug);
1051
1052 my $old_rec = $rec;
1053 my @out;
1054
1055 foreach my $mfn (@mfns) {
1056 $rec = $load_row_coderef->( $database, $input, $mfn );
1057
1058 warn "got $database/$input/$mfn = ", dump($rec), $/ if ($debug);
1059
1060 my @vals = $what->();
1061
1062 push @out, ( @vals );
1063
1064 warn "lookup for mfn $mfn returned ", dump(@vals), $/ if ($debug);
1065 }
1066
1067 # if (ref($lookup->{$k}) eq 'ARRAY') {
1068 # return @{ $lookup->{$k} };
1069 # } else {
1070 # return $lookup->{$k};
1071 # }
1072
1073 $rec = $old_rec;
1074
1075 warn "## lookup returns = ", dump(@out), $/ if ($debug);
1076
1077 if ($#out == 0) {
1078 return $out[0];
1079 } else {
1080 return @out;
1081 }
1082 }
1083
1084 =head2 save_into_lookup
1085
1086 Save value into lookup. It associates current database, input
1087 and specific keys with one or more values which will be
1088 associated over MFN.
1089
1090 MFN will be extracted from first occurence current of field 000
1091 in current record, or if it doesn't exist from L<_set_config> C<_mfn>.
1092
1093 my $nr = save_into_lookup($database,$input,$key,sub {
1094 # code which produce one or more values
1095 });
1096
1097 It returns number of items saved.
1098
1099 This function shouldn't be called directly, it's called from code created by
1100 L<WebPAC::Parser>.
1101
1102 =cut
1103
1104 sub save_into_lookup {
1105 my ($database,$input,$key,$coderef) = @_;
1106 die "save_into_lookup needs database" unless defined($database);
1107 die "save_into_lookup needs input" unless defined($input);
1108 die "save_into_lookup needs key" unless defined($key);
1109 die "save_into_lookup needs CODE" unless ( defined($coderef) && ref($coderef) eq 'CODE' );
1110
1111 warn "## save_into_lookup rec = ", dump($rec), " config = ", dump($config), $/ if ($debug > 2);
1112
1113 my $mfn =
1114 defined($rec->{'000'}->[0]) ? $rec->{'000'}->[0] :
1115 defined($config->{_mfn}) ? $config->{_mfn} :
1116 die "mfn not defined or zero";
1117
1118 my $nr = 0;
1119
1120 foreach my $v ( $coderef->() ) {
1121 $lookup->{$database}->{$input}->{$key}->{$v}->{$mfn}++;
1122 warn "# saved lookup $database/$input/$key [$v] $mfn\n" if ($debug > 1);
1123 $nr++;
1124 }
1125
1126 return $nr;
1127 }
1128
1129 =head2 config
1130
1131 Consult config values stored in C<config.yml>
1132
1133 # return database code (key under databases in yaml)
1134 $database_code = config(); # use _ from hash
1135 $database_name = config('name');
1136 $database_input_name = config('input name');
1137 $tag = config('input normalize tag');
1138
1139 Up to three levels are supported.
1140
1141 =cut
1142
1143 sub config {
1144 return unless ($config);
1145
1146 my $p = shift;
1147
1148 $p ||= '';
1149
1150 my $v;
1151
1152 warn "### getting config($p)\n" if ($debug > 1);
1153
1154 my @p = split(/\s+/,$p);
1155 if ($#p < 0) {
1156 $v = $config->{ '_' }; # special, database code
1157 } else {
1158
1159 my $c = dclone( $config );
1160
1161 foreach my $k (@p) {
1162 warn "### k: $k c = ",dump($c),$/ if ($debug > 1);
1163 if (ref($c) eq 'ARRAY') {
1164 $c = shift @$c;
1165 warn "config($p) taking first occurence of '$k', probably not what you wanted!\n";
1166 last;
1167 }
1168
1169 if (! defined($c->{$k}) ) {
1170 $c = undef;
1171 last;
1172 } else {
1173 $c = $c->{$k};
1174 }
1175 }
1176 $v = $c if ($c);
1177
1178 }
1179
1180 warn "## config( '$p' ) = ",dump( $v ),$/ if ($v && $debug);
1181 warn "config( '$p' ) is empty\n" if (! $v);
1182
1183 return $v;
1184 }
1185
1186 =head2 id
1187
1188 Returns unique id of this record
1189
1190 $id = id();
1191
1192 Returns C<42/2> for 2nd occurence of MFN 42.
1193
1194 =cut
1195
1196 sub id {
1197 my $mfn = $config->{_mfn} || die "no _mfn in config data";
1198 return $mfn . $#{$marc_record} ? $#{$marc_record} + 1 : '';
1199 }
1200
1201 =head2 join_with
1202
1203 Joins walues with some delimiter
1204
1205 $v = join_with(", ", @v);
1206
1207 =cut
1208
1209 sub join_with {
1210 my $d = shift;
1211 warn "### join_with('$d',",dump(@_),")\n" if ($debug > 2);
1212 my $v = join($d, grep { defined($_) && $_ ne '' } @_);
1213 return '' unless defined($v);
1214 return $v;
1215 }
1216
1217 =head2 split_rec_on
1218
1219 Split record subfield on some regex and take one of parts out
1220
1221 $a_before_semi_column =
1222 split_rec_on('200','a', /\s*;\s*/, $part);
1223
1224 C<$part> is optional number of element. First element is
1225 B<1>, not 0!
1226
1227 If there is no C<$part> parameter or C<$part> is 0, this function will
1228 return all values produced by splitting.
1229
1230 =cut
1231
1232 sub split_rec_on {
1233 die "split_rec_on need (fld,sf,regex[,part]" if ($#_ < 2);
1234
1235 my ($fld, $sf, $regex, $part) = @_;
1236 warn "### regex ", ref($regex), $regex, $/ if ($debug > 2);
1237
1238 my @r = rec( $fld, $sf );
1239 my $v = shift @r;
1240 warn "### first rec($fld,$sf) = ",dump($v),$/ if ($debug > 2);
1241
1242 return '' if ( ! defined($v) || $v =~ /^\s*$/);
1243
1244 my @s = split( $regex, $v );
1245 warn "## split_rec_on($fld,$sf,$regex,$part) = ",dump(@s),$/ if ($debug > 1);
1246 if ($part && $part > 0) {
1247 return $s[ $part - 1 ];
1248 } else {
1249 return @s;
1250 }
1251 }
1252
1253 my $hash;
1254
1255 =head2 set
1256
1257 set( key => 'value' );
1258
1259 =cut
1260
1261 sub set {
1262 my ($k,$v) = @_;
1263 warn "## set ( $k => ", dump($v), " )", $/;
1264 $hash->{$k} = $v;
1265 };
1266
1267 =head2 get
1268
1269 get( 'key' );
1270
1271 =cut
1272
1273 sub get {
1274 my $k = shift || return;
1275 my $v = $hash->{$k};
1276 warn "## get $k = ", dump( $v ), $/;
1277 return $v;
1278 }
1279
1280
1281 # END
1282 1;

  ViewVC Help
Powered by ViewVC 1.1.26