/[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 1018 - (show annotations)
Fri Nov 9 23:46:44 2007 UTC (15 years, 2 months ago) by dpavlin
File size: 36044 byte(s)
consider only one-char subfields (to correctly skip subfields key which
contains order of subfields), die on subfields which doesn't have
rename mapping defined

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

  ViewVC Help
Powered by ViewVC 1.1.26