1 package WebPAC::Normalize;
8 regex prefix suffix surround
15 #use base qw/WebPAC::Common/;
20 WebPAC::Normalize - describe normalisaton rules using sets
28 our $VERSION = '0.04';
32 This module uses C<conf/normalize/*.pl> files to perform normalisation
33 from input records using perl functions which are specialized for set
36 Sets are implemented as arrays, and normalisation file is valid perl, which
37 means that you check it's validity before running WebPAC using
38 C<perl -c normalize.pl>.
40 Normalisation can generate multiple output normalized data. For now, supported output
41 types (on the left side of definition) are: C<tag>, C<display> and C<search>.
49 my $ds = WebPAC::Normalize(
50 lookup => $lookup->lookup_hash,
52 rules => $normalize_pl_config,
55 This function will B<die> if normalizastion can't be evaled.
62 die "need row argument" unless ($arg->{row});
63 die "need normalisation argument" unless ($arg->{rules});
66 set_lookup( $arg->{lookup} );
67 set_rec( $arg->{row} );
70 die "error evaling $arg->{rules}: $@\n" if ($@);
76 Set current record hash
85 $rec = shift or die "no record hash";
90 Define new tag for I<search> and I<display>.
92 tag('Title', rec('200','a') );
100 my $name = shift or die "tag needs name as first argument";
101 my @o = grep { defined($_) && $_ ne '' } @_;
103 $out->{$name}->{tag} = $name;
104 $out->{$name}->{search} = \@o;
105 $out->{$name}->{display} = \@o;
110 Define tag just for I<display>
112 @v = display('Title', rec('200','a') );
117 my $name = shift or die "display needs name as first argument";
118 my @o = grep { defined($_) && $_ ne '' } @_;
120 $out->{$name}->{tag} = $name;
121 $out->{$name}->{display} = \@o;
126 Prepare values just for I<search>
128 @v = search('Title', rec('200','a') );
133 my $name = shift or die "search needs name as first argument";
134 my @o = grep { defined($_) && $_ ne '' } @_;
136 $out->{$name}->{tag} = $name;
137 $out->{$name}->{search} = \@o;
142 Return hash formatted as data structure
154 Clean data structure hash for next record
166 Set current lookup hash
168 set_lookup( $lookup );
180 Return all values in some field
184 TODO: order of values is probably same as in source data, need to investigate that
190 return unless (defined($rec) && defined($rec->{$f}));
191 if (ref($rec->{$f}) eq 'ARRAY') {
193 if (ref($_) eq 'HASH') {
199 } elsif( defined($rec->{$f}) ) {
206 Return all values in specific field and subfield
214 return unless (defined($rec && $rec->{$f}));
216 return map { $_->{$sf} } grep { ref($_) eq 'HASH' && $_->{$sf} } @{ $rec->{$f} };
238 Apply regex to some or all values
240 @v = regex( 's/foo/bar/g', @v );
247 #warn "r: $r\n",Dumper(\@_);
251 push @out, $t if ($t && $t ne '');
258 Prefix all values with a string
260 @v = prefix( 'my_', @v );
265 my $p = shift or die "prefix needs string as first argument";
266 return map { $p . $_ } grep { defined($_) } @_;
271 suffix all values with a string
273 @v = suffix( '_my', @v );
278 my $s = shift or die "suffix needs string as first argument";
279 return map { $_ . $s } grep { defined($_) } @_;
284 surround all values with a two strings
286 @v = surround( 'prefix_', '_suffix', @v );
291 my $p = shift or die "surround need prefix as first argument";
292 my $s = shift or die "surround needs suffix as second argument";
293 return map { $p . $_ . $s } grep { defined($_) } @_;
311 Consult lookup hashes for some value
319 my $k = shift or return;
320 return unless (defined($lookup->{$k}));
321 if (ref($lookup->{$k}) eq 'ARRAY') {
322 return @{ $lookup->{$k} };
324 return $lookup->{$k};
330 Joins walues with some delimiter
332 $v = join_with(", ", @v);
338 return join($d, grep { defined($_) && $_ ne '' } @_);