/[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 1216 - (show annotations)
Tue Jun 2 13:17:24 2009 UTC (14 years, 9 months ago) by dpavlin
File size: 18311 byte(s)
fix pod example for rec_array

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 to
11 search_display search display sorted
12
13 rec1 rec2 rec
14 frec frec_eq frec_ne
15 regex prefix suffix surround
16 first lookup join_with
17 save_into_lookup
18
19 split_rec_on
20
21 get set
22 count
23
24 row
25 rec_array
26
27 /;
28
29 use warnings;
30 use strict;
31
32 #use base qw/WebPAC::Common/;
33 use Data::Dump qw/dump/;
34 use Carp qw/confess/;
35
36 # debugging warn(s)
37 my $debug = 0;
38 _debug( $debug );
39
40 # FIXME
41 use WebPAC::Normalize::ISBN;
42 push @EXPORT, ( 'isbn_10', 'isbn_13' );
43
44 use WebPAC::Normalize::MARC;
45 push @EXPORT, ( qw/
46 marc marc_indicators marc_repeatable_subfield
47 marc_compose marc_leader marc_fixed
48 marc_duplicate marc_remove marc_count
49 marc_original_order
50 marc_template
51 /);
52
53 use Storable qw/dclone/;
54
55 =head1 NAME
56
57 WebPAC::Normalize - describe normalisaton rules using sets
58
59 =cut
60
61 our $VERSION = '0.36';
62
63 =head1 SYNOPSIS
64
65 This module uses C<conf/normalize/*.pl> files to perform normalisation
66 from input records using perl functions which are specialized for set
67 processing.
68
69 Sets are implemented as arrays, and normalisation file is valid perl, which
70 means that you check it's validity before running WebPAC using
71 C<perl -c normalize.pl>.
72
73 Normalisation can generate multiple output normalized data. For now, supported output
74 types (on the left side of definition) are: C<search_display>, C<display>, C<search> and
75 C<marc>.
76
77 =head1 FUNCTIONS
78
79 Functions which start with C<_> are private and used by WebPAC internally.
80 All other functions are available for use within normalisation rules.
81
82 =head2 data_structure
83
84 Return data structure
85
86 my $ds = WebPAC::Normalize::data_structure(
87 lookup => $lookup_hash,
88 row => $row,
89 rules => $normalize_pl_config,
90 marc_encoding => 'utf-8',
91 config => $config,
92 load_row_coderef => sub {
93 my ($database,$input,$mfn) = @_;
94 $store->load_row( database => $database, input => $input, id => $mfn );
95 },
96 );
97
98 Options C<row>, C<rules> and C<log> are mandatory while all
99 other are optional.
100
101 C<load_row_coderef> is closure only used when executing lookups, so they will
102 die if it's not defined.
103
104 This function will B<die> if normalizastion can't be evaled.
105
106 Since this function isn't exported you have to call it with
107 C<WebPAC::Normalize::data_structure>.
108
109 =cut
110
111 my $load_row_coderef;
112
113 sub data_structure {
114 my $arg = {@_};
115
116 die "need row argument" unless ($arg->{row});
117 die "need normalisation argument" unless ($arg->{rules});
118
119 _set_lookup( $arg->{lookup} ) if defined($arg->{lookup});
120 _set_ds( $arg->{row} );
121 _set_config( $arg->{config} ) if defined($arg->{config});
122 _clean_ds( %{ $arg } );
123 $load_row_coderef = $arg->{load_row_coderef};
124
125 no strict 'subs';
126 no warnings 'redefine';
127 eval "$arg->{rules};";
128 die "error evaling $arg->{rules}: $@\n" if ($@);
129
130 return _get_ds();
131 }
132
133 =head2 _set_ds
134
135 Set current record hash
136
137 _set_ds( $rec );
138
139 =cut
140
141 my $rec;
142
143 sub _set_ds {
144 $rec = shift or die "no record hash";
145 $WebPAC::Normalize::MARC::rec = $rec;
146 }
147
148 =head2
149
150 my $rec = _get_rec();
151
152 =cut
153
154 sub _get_rec { $rec };
155
156 =head2 _set_config
157
158 Set current config hash
159
160 _set_config( $config );
161
162 Magic keys are:
163
164 =over 4
165
166 =item _
167
168 Code of current database
169
170 =item _mfn
171
172 Current MFN
173
174 =back
175
176 =cut
177
178 my $config;
179
180 sub _set_config {
181 $config = shift;
182 }
183
184 =head2 _get_ds
185
186 Return hash formatted as data structure
187
188 my $ds = _get_ds();
189
190 =cut
191
192 my $out;
193
194 sub _get_ds {
195 #warn "## out = ",dump($out);
196 return $out;
197 }
198
199 =head2 _clean_ds
200
201 Clean data structure hash for next record
202
203 _clean_ds();
204
205 =cut
206
207 sub _clean_ds {
208 my $a = {@_};
209 $out = undef;
210 WebPAC::Normalize::MARC::_clean();
211 }
212
213 =head2 _set_lookup
214
215 Set current lookup hash
216
217 _set_lookup( $lookup );
218
219 =cut
220
221 my $lookup;
222
223 sub _set_lookup {
224 $lookup = shift;
225 }
226
227 =head2 _get_lookup
228
229 Get current lookup hash
230
231 my $lookup = _get_lookup();
232
233 =cut
234
235 sub _get_lookup {
236 return $lookup;
237 }
238
239 =head2 _set_load_row
240
241 Setup code reference which will return L<data_structure> from
242 L<WebPAC::Store>
243
244 _set_load_row(sub {
245 my ($database,$input,$mfn) = @_;
246 $store->load_row( database => $database, input => $input, id => $mfn );
247 });
248
249 =cut
250
251 sub _set_load_row {
252 my $coderef = shift;
253 confess "argument isn't CODE" unless ref($coderef) eq 'CODE';
254
255 $load_row_coderef = $coderef;
256 }
257
258 =head2 _debug
259
260 Change level of debug warnings
261
262 _debug( 2 );
263
264 =cut
265
266 sub _debug {
267 my $l = shift;
268 return $debug unless defined($l);
269 warn "debug level $l",$/ if ($l > 0);
270 $debug = $l;
271 $WebPAC::Normalize::MARC::debug = $debug;
272 }
273
274 =head1 Functions to create C<data_structure>
275
276 Those functions generally have to first in your normalization file.
277
278 =head2 to
279
280 Generic way to set values for some name
281
282 to('field-name', 'name-value' => rec('200','a') );
283
284 There are many helpers defined below which might be easier to use.
285
286 =cut
287
288 sub to {
289 my $type = shift or confess "need type -- BUG?";
290 my $name = shift or confess "needs name as first argument";
291 my @o = grep { defined($_) && $_ ne '' } @_;
292 return unless (@o);
293 $out->{$name}->{$type} = \@o;
294 }
295
296 =head2 search_display
297
298 Define output for L<search> and L<display> at the same time
299
300 search_display('Title', rec('200','a') );
301
302 =cut
303
304 sub search_display {
305 my $name = shift or die "search_display needs name as first argument";
306 my @o = grep { defined($_) && $_ ne '' } @_;
307 return unless (@o);
308 $out->{$name}->{search} = \@o;
309 $out->{$name}->{display} = \@o;
310 }
311
312 =head2 tag
313
314 Old name for L<search_display>, it will probably be removed at one point.
315
316 =cut
317
318 sub tag {
319 search_display( @_ );
320 }
321
322 =head2 display
323
324 Define output just for I<display>
325
326 @v = display('Title', rec('200','a') );
327
328 =cut
329
330 sub display { to( 'display', @_ ) }
331
332 =head2 search
333
334 Prepare values just for I<search>
335
336 @v = search('Title', rec('200','a') );
337
338 =cut
339
340 sub search { to( 'search', @_ ) }
341
342 =head2 sorted
343
344 Insert into lists which will be automatically sorted
345
346 sorted('Title', rec('200','a') );
347
348 =cut
349
350 sub sorted { to( 'sorted', @_ ) }
351
352 =head2 row
353
354 Insert new row of data into output module
355
356 row( column => 'foo', column2 => 'bar' );
357
358 =cut
359
360 use Data::Dump qw/dump/;
361
362 sub row {
363 die "array doesn't have odd number of elements but $#_: ",dump( @_ ) if $#_ % 2 == 1;
364 my $table = shift @_;
365 push @{ $out->{'_rows'}->{$table} }, {@_};
366 }
367
368
369 =head1 Functions to extract data from input
370
371 This function should be used inside functions to create C<data_structure> described
372 above.
373
374 =head2 _pack_subfields_hash
375
376 @subfields = _pack_subfields_hash( $h );
377 $subfields = _pack_subfields_hash( $h, 1 );
378
379 Return each subfield value in array or pack them all together and return scalar
380 with subfields (denoted by C<^>) and values.
381
382 =cut
383
384 sub _pack_subfields_hash {
385
386 warn "## _pack_subfields_hash( ",dump(@_), " )\n" if ($debug > 1);
387
388 my ($hash,$include_subfields) = @_;
389
390 # sanity and ease of use
391 return $hash if (ref($hash) ne 'HASH');
392
393 my $h = dclone( $hash );
394
395 if ( defined($h->{subfields}) ) {
396 my $sfs = delete $h->{subfields} || die "no subfields?";
397 my @out;
398 while (@$sfs) {
399 my $sf = shift @$sfs;
400 push @out, '^' . $sf if ($include_subfields);
401 my $o = shift @$sfs;
402 if ($o == 0 && ref( $h->{$sf} ) ne 'ARRAY' ) {
403 # single element subfields are not arrays
404 #warn "====> $sf $o / $#$sfs ", dump( $sfs, $h->{$sf} ), "\n";
405
406 push @out, $h->{$sf};
407 } else {
408 #warn "====> $sf $o / $#$sfs ", dump( $sfs, $h->{$sf} ), "\n";
409 push @out, $h->{$sf}->[$o];
410 }
411 }
412 if ($include_subfields) {
413 return join('', @out);
414 } else {
415 return @out;
416 }
417 } else {
418 if ($include_subfields) {
419 my $out = '';
420 foreach my $sf (sort keys %$h) {
421 if (ref($h->{$sf}) eq 'ARRAY') {
422 $out .= '^' . $sf . join('^' . $sf, @{ $h->{$sf} });
423 } else {
424 $out .= '^' . $sf . $h->{$sf};
425 }
426 }
427 return $out;
428 } else {
429 # FIXME this should probably be in alphabetical order instead of hash order
430 values %{$h};
431 }
432 }
433 }
434
435 =head2 rec1
436
437 Return all values in some field
438
439 @v = rec1('200')
440
441 TODO: order of values is probably same as in source data, need to investigate that
442
443 =cut
444
445 sub rec1 {
446 my $f = shift;
447 warn "rec1($f) = ", dump( $rec->{$f} ), $/ if ($debug > 1);
448 return unless (defined($rec) && defined($rec->{$f}));
449 warn "rec1($f) = ", dump( $rec->{$f} ), $/ if ($debug > 1);
450 if (ref($rec->{$f}) eq 'ARRAY') {
451 my @out;
452 foreach my $h ( @{ $rec->{$f} } ) {
453 if (ref($h) eq 'HASH') {
454 push @out, ( _pack_subfields_hash( $h ) );
455 } else {
456 push @out, $h;
457 }
458 }
459 return @out;
460 } elsif( defined($rec->{$f}) ) {
461 return $rec->{$f};
462 }
463 }
464
465 =head2 rec2
466
467 Return all values in specific field and subfield
468
469 @v = rec2('200','a')
470
471 =cut
472
473 sub rec2 {
474 my $f = shift;
475 return unless (defined($rec && $rec->{$f}));
476 my $sf = shift;
477 warn "rec2($f,$sf) = ", dump( $rec->{$f} ), $/ if ($debug > 1);
478 return map {
479 if (ref($_->{$sf}) eq 'ARRAY') {
480 @{ $_->{$sf} };
481 } else {
482 $_->{$sf};
483 }
484 } grep { ref($_) eq 'HASH' && defined $_->{$sf} } @{ $rec->{$f} };
485 }
486
487 =head2 rec
488
489 syntaxtic sugar for
490
491 @v = rec('200')
492 @v = rec('200','a')
493
494 If rec() returns just single value, it will
495 return scalar, not array.
496
497 =cut
498
499 sub rec {
500 my @out;
501 if ($#_ == 0) {
502 @out = rec1(@_);
503 } elsif ($#_ == 1) {
504 @out = rec2(@_);
505 }
506 if ($#out == 0 && ! wantarray) {
507 return $out[0];
508 } elsif (@out) {
509 return @out;
510 } else {
511 return '';
512 }
513 }
514
515 =head2 frec
516
517 Returns first value from field
518
519 $v = frec('200');
520 $v = frec('200','a');
521
522 =cut
523
524 sub frec {
525 my @out = rec(@_);
526 warn "rec(",dump(@_),") has more than one return value, ignoring\n" if $#out > 0;
527 return shift @out;
528 }
529
530 =head2 frec_eq
531
532 =head2 frec_ne
533
534 Check if first values from two fields are same or different
535
536 if ( frec_eq( 900 => 'a', 910 => 'c' ) ) {
537 # values are same
538 } else {
539 # values are different
540 }
541
542 Strictly speaking C<frec_eq> and C<frec_ne> wouldn't be needed if you
543 could write something like:
544
545 if ( frec( '900','a' ) eq frec( '910','c' ) ) {
546 # yada tada
547 }
548
549 but you can't since our parser L<WebPAC::Parser> will remove all whitespaces
550 in order to parse text and create invalid function C<eqfrec>.
551
552 =cut
553
554 sub frec_eq {
555 my ( $f1,$sf1, $f2, $sf2 ) = @_;
556 return (rec( $f1, $sf1 ))[0] eq (rec( $f2, $sf2 ))[0];
557 }
558
559 sub frec_ne {
560 return ! frec_eq( @_ );
561 }
562
563 =head2 regex
564
565 Apply regex to some or all values
566
567 @v = regex( 's/foo/bar/g', @v );
568
569 =cut
570
571 sub regex {
572 my $r = shift;
573 my @out;
574 #warn "r: $r\n", dump(\@_);
575 foreach my $t (@_) {
576 next unless ($t);
577 eval "\$t =~ $r";
578 push @out, $t if ($t && $t ne '');
579 }
580 return @out;
581 }
582
583 =head2 prefix
584
585 Prefix all values with a string
586
587 @v = prefix( 'my_', @v );
588
589 =cut
590
591 sub prefix {
592 my $p = shift;
593 return @_ unless defined( $p );
594 return map { $p . $_ } grep { defined($_) } @_;
595 }
596
597 =head2 suffix
598
599 suffix all values with a string
600
601 @v = suffix( '_my', @v );
602
603 =cut
604
605 sub suffix {
606 my $s = shift;
607 return @_ unless defined( $s );
608 return map { $_ . $s } grep { defined($_) } @_;
609 }
610
611 =head2 surround
612
613 surround all values with a two strings
614
615 @v = surround( 'prefix_', '_suffix', @v );
616
617 =cut
618
619 sub surround {
620 my $p = shift;
621 my $s = shift;
622 $p = '' unless defined( $p );
623 $s = '' unless defined( $s );
624 return map { $p . $_ . $s } grep { defined($_) } @_;
625 }
626
627 =head2 first
628
629 Return first element
630
631 $v = first( @v );
632
633 =cut
634
635 sub first {
636 my $r = shift;
637 return $r;
638 }
639
640 =head2 lookup
641
642 Consult lookup hashes for some value
643
644 @v = lookup(
645 sub {
646 'ffkk/peri/mfn'.rec('000')
647 },
648 'ffkk','peri','200-a-200-e',
649 sub {
650 first(rec(200,'a')).' '.first(rec('200','e'))
651 }
652 );
653
654 Code like above will be B<automatically generated> using L<WebPAC::Parse> from
655 normal lookup definition in C<conf/lookup/something.pl> which looks like:
656
657 lookup(
658 # which results to return from record recorded in lookup
659 sub { 'ffkk/peri/mfn' . rec('000') },
660 # from which database and input
661 'ffkk','peri',
662 # such that following values match
663 sub { first(rec(200,'a')) . ' ' . first(rec('200','e')) },
664 # if this part is missing, we will try to match same fields
665 # from lookup record and current one, or you can override
666 # which records to use from current record using
667 sub { rec('900','x') . ' ' . rec('900','y') },
668 )
669
670 You can think about this lookup as SQL (if that helps):
671
672 select
673 sub { what }
674 from
675 database, input
676 where
677 sub { filter from lookuped record }
678 having
679 sub { optional filter on current record }
680
681 Easy as pie, right?
682
683 =cut
684
685 sub lookup {
686 my ($what, $database, $input, $key, $having) = @_;
687
688 confess "lookup needs 5 arguments: what, database, input, key, having\n" unless ($#_ == 4);
689
690 warn "## lookup ($database, $input, $key)", $/ if ($debug > 1);
691 return unless (defined($lookup->{$database}->{$input}->{$key}));
692
693 confess "lookup really need load_row_coderef added to data_structure\n" unless ($load_row_coderef);
694
695 my $mfns;
696 my @having = $having->();
697
698 warn "## having = ", dump( @having ) if ($debug > 2);
699
700 foreach my $h ( @having ) {
701 if (defined($lookup->{$database}->{$input}->{$key}->{$h})) {
702 warn "lookup for $database/$input/$key/$h return ",dump($lookup->{$database}->{$input}->{$key}->{$h}),"\n" if ($debug);
703 $mfns->{$_}++ foreach keys %{ $lookup->{$database}->{$input}->{$key}->{$h} };
704 }
705 }
706
707 return unless ($mfns);
708
709 my @mfns = sort keys %$mfns;
710
711 warn "# lookup loading $database/$input/$key mfn ", join(",",@mfns)," having ",dump(@having),"\n" if ($debug);
712
713 my $old_rec = $rec;
714 my @out;
715
716 foreach my $mfn (@mfns) {
717 $rec = $load_row_coderef->( $database, $input, $mfn );
718
719 warn "got $database/$input/$mfn = ", dump($rec), $/ if ($debug);
720
721 my @vals = $what->();
722
723 push @out, ( @vals );
724
725 warn "lookup for mfn $mfn returned ", dump(@vals), $/ if ($debug);
726 }
727
728 # if (ref($lookup->{$k}) eq 'ARRAY') {
729 # return @{ $lookup->{$k} };
730 # } else {
731 # return $lookup->{$k};
732 # }
733
734 $rec = $old_rec;
735
736 warn "## lookup returns = ", dump(@out), $/ if ($debug);
737
738 if ($#out == 0) {
739 return $out[0];
740 } else {
741 return @out;
742 }
743 }
744
745 =head2 save_into_lookup
746
747 Save value into lookup. It associates current database, input
748 and specific keys with one or more values which will be
749 associated over MFN.
750
751 MFN will be extracted from first occurence current of field 000
752 in current record, or if it doesn't exist from L<_set_config> C<_mfn>.
753
754 my $nr = save_into_lookup($database,$input,$key,sub {
755 # code which produce one or more values
756 });
757
758 It returns number of items saved.
759
760 This function shouldn't be called directly, it's called from code created by
761 L<WebPAC::Parser>.
762
763 =cut
764
765 sub save_into_lookup {
766 my ($database,$input,$key,$coderef) = @_;
767 die "save_into_lookup needs database" unless defined($database);
768 die "save_into_lookup needs input" unless defined($input);
769 die "save_into_lookup needs key" unless defined($key);
770 die "save_into_lookup needs CODE" unless ( defined($coderef) && ref($coderef) eq 'CODE' );
771
772 warn "## save_into_lookup rec = ", dump($rec), " config = ", dump($config), $/ if ($debug > 2);
773
774 my $mfn =
775 defined($rec->{'000'}->[0]) ? $rec->{'000'}->[0] :
776 defined($config->{_mfn}) ? $config->{_mfn} :
777 die "mfn not defined or zero";
778
779 my $nr = 0;
780
781 foreach my $v ( $coderef->() ) {
782 $lookup->{$database}->{$input}->{$key}->{$v}->{$mfn}++;
783 warn "# saved lookup $database/$input/$key [$v] $mfn\n" if ($debug > 1);
784 $nr++;
785 }
786
787 return $nr;
788 }
789
790 =head2 config
791
792 Consult config values stored in C<config.yml>
793
794 # return database code (key under databases in yaml)
795 $database_code = config(); # use _ from hash
796 $database_name = config('name');
797 $database_input_name = config('input name');
798
799 Up to three levels are supported.
800
801 =cut
802
803 sub config {
804 return unless ($config);
805
806 my $p = shift;
807
808 $p ||= '';
809
810 my $v;
811
812 warn "### getting config($p)\n" if ($debug > 1);
813
814 my @p = split(/\s+/,$p);
815 if ($#p < 0) {
816 $v = $config->{ '_' }; # special, database code
817 } else {
818
819 my $c = dclone( $config );
820
821 foreach my $k (@p) {
822 warn "### k: $k c = ",dump($c),$/ if ($debug > 1);
823 if (ref($c) eq 'ARRAY') {
824 $c = shift @$c;
825 warn "config($p) taking first occurence of '$k', probably not what you wanted!\n";
826 last;
827 }
828
829 if (! defined($c->{$k}) ) {
830 $c = undef;
831 last;
832 } else {
833 $c = $c->{$k};
834 }
835 }
836 $v = $c if ($c);
837
838 }
839
840 warn "## config( '$p' ) = ",dump( $v ),$/ if ($v && $debug);
841 warn "config( '$p' ) is empty\n" if (! $v);
842
843 return $v;
844 }
845
846 =head2 id
847
848 Returns unique id of this record
849
850 $id = id();
851
852 Returns C<42/2> for 2nd occurence of MFN 42.
853
854 =cut
855
856 sub id {
857 my $mfn = $config->{_mfn} || die "no _mfn in config data";
858 return $mfn . ( WebPAC::Normalize::MARC::_created_marc_records() || '' );
859 }
860
861 =head2 join_with
862
863 Joins walues with some delimiter
864
865 $v = join_with(", ", @v);
866
867 =cut
868
869 sub join_with {
870 my $d = shift;
871 warn "### join_with('$d',",dump(@_),")\n" if ($debug > 2);
872 my $v = join($d, grep { defined($_) && $_ ne '' } @_);
873 return '' unless defined($v);
874 return $v;
875 }
876
877 =head2 split_rec_on
878
879 Split record subfield on some regex and take one of parts out
880
881 $a_before_semi_column =
882 split_rec_on('200','a', /\s*;\s*/, $part);
883
884 C<$part> is optional number of element. First element is
885 B<1>, not 0!
886
887 If there is no C<$part> parameter or C<$part> is 0, this function will
888 return all values produced by splitting.
889
890 =cut
891
892 sub split_rec_on {
893 die "split_rec_on need (fld,sf,regex[,part]" if ($#_ < 2);
894
895 my ($fld, $sf, $regex, $part) = @_;
896 warn "### regex ", ref($regex), $regex, $/ if ($debug > 2);
897
898 my @r = rec( $fld, $sf );
899 my $v = shift @r;
900 warn "### first rec($fld,$sf) = ",dump($v),$/ if ($debug > 2);
901
902 return '' if ( ! defined($v) || $v =~ /^\s*$/);
903
904 my @s = split( $regex, $v );
905 warn "## split_rec_on($fld,$sf,$regex,$part) = ",dump(@s),$/ if ($debug > 1);
906 if ($part && $part > 0) {
907 return $s[ $part - 1 ];
908 } else {
909 return @s;
910 }
911 }
912
913 my $hash;
914
915 =head2 set
916
917 set( key => 'value' );
918
919 =cut
920
921 sub set {
922 my ($k,$v) = @_;
923 warn "## set ( $k => ", dump($v), " )", $/ if ( $debug );
924 $hash->{$k} = $v;
925 };
926
927 =head2 get
928
929 get( 'key' );
930
931 =cut
932
933 sub get {
934 my $k = shift || return;
935 my $v = $hash->{$k};
936 warn "## get $k = ", dump( $v ), $/ if ( $debug );
937 return $v;
938 }
939
940 =head2 count
941
942 if ( count( @result ) == 1 ) {
943 # do something if only 1 result is there
944 }
945
946 =cut
947
948 sub count {
949 warn "## count ",dump(@_),$/ if ( $debug );
950 return @_ . '';
951 }
952
953 =head2 rec_array
954
955 Always return field as array
956
957 foreach my $d ( rec_array('field') ) {
958 warn $d;
959 }
960
961 =cut
962
963 sub rec_array {
964 my $d = $rec->{ $_[0] };
965 return @$d if ref($d) eq 'ARRAY';
966 return ($d);
967 }
968
969 # END
970 1;

  ViewVC Help
Powered by ViewVC 1.1.26