/[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 538 - (show annotations)
Thu Jun 29 15:29:19 2006 UTC (16 years, 7 months ago) by dpavlin
File size: 5692 byte(s)
 r722@llin:  dpavlin | 2006-06-26 21:29:56 +0200
 make private funtions with _

1 package WebPAC::Normalize;
2 use Exporter 'import';
3 @EXPORT = qw/
4 _set_rec _set_lookup
5 _get_ds _clean_ds
6
7 tag search display
8 rec1 rec2 rec
9 regex prefix suffix surround
10 first lookup join_with
11 /;
12
13 use warnings;
14 use strict;
15
16 #use base qw/WebPAC::Common/;
17 use Data::Dumper;
18
19 =head1 NAME
20
21 WebPAC::Normalize - describe normalisaton rules using sets
22
23 =head1 VERSION
24
25 Version 0.05
26
27 =cut
28
29 our $VERSION = '0.05';
30
31 =head1 SYNOPSIS
32
33 This module uses C<conf/normalize/*.pl> files to perform normalisation
34 from input records using perl functions which are specialized for set
35 processing.
36
37 Sets are implemented as arrays, and normalisation file is valid perl, which
38 means that you check it's validity before running WebPAC using
39 C<perl -c normalize.pl>.
40
41 Normalisation can generate multiple output normalized data. For now, supported output
42 types (on the left side of definition) are: C<tag>, C<display> and C<search>.
43
44 =head1 FUNCTIONS
45
46 Functions which start with C<_> are private and used by WebPAC internally.
47 All other functions are available for use within normalisation rules.
48
49 =head2 data_structure
50
51 Return data structure
52
53 my $ds = WebPAC::Normalize::data_structure(
54 lookup => $lookup->lookup_hash,
55 row => $row,
56 rules => $normalize_pl_config,
57 );
58
59 This function will B<die> if normalizastion can't be evaled.
60
61 Since this function isn't exported you have to call it with
62 C<WebPAC::Normalize::data_structure>.
63
64 =cut
65
66 sub data_structure {
67 my $arg = {@_};
68
69 die "need row argument" unless ($arg->{row});
70 die "need normalisation argument" unless ($arg->{rules});
71
72 no strict 'subs';
73 _set_lookup( $arg->{lookup} );
74 _set_rec( $arg->{row} );
75 _clean_ds();
76 eval "$arg->{rules}";
77 die "error evaling $arg->{rules}: $@\n" if ($@);
78 return _get_ds();
79 }
80
81 =head2 _set_rec
82
83 Set current record hash
84
85 _set_rec( $rec );
86
87 =cut
88
89 my $rec;
90
91 sub _set_rec {
92 $rec = shift or die "no record hash";
93 }
94
95 =head2 _get_ds
96
97 Return hash formatted as data structure
98
99 my $ds = _get_ds();
100
101 =cut
102
103 my $out;
104
105 sub _get_ds {
106 return $out;
107 }
108
109 =head2 _clean_ds
110
111 Clean data structure hash for next record
112
113 _clean_ds();
114
115 =cut
116
117 sub _clean_ds {
118 $out = undef;
119 }
120
121 =head2 _set_lookup
122
123 Set current lookup hash
124
125 _set_lookup( $lookup );
126
127 =cut
128
129 my $lookup;
130
131 sub _set_lookup {
132 $lookup = shift;
133 }
134
135 =head2 tag
136
137 Define new tag for I<search> and I<display>.
138
139 tag('Title', rec('200','a') );
140
141
142 =cut
143
144 sub tag {
145 my $name = shift or die "tag needs name as first argument";
146 my @o = grep { defined($_) && $_ ne '' } @_;
147 return unless (@o);
148 $out->{$name}->{tag} = $name;
149 $out->{$name}->{search} = \@o;
150 $out->{$name}->{display} = \@o;
151 }
152
153 =head2 display
154
155 Define tag just for I<display>
156
157 @v = display('Title', rec('200','a') );
158
159 =cut
160
161 sub display {
162 my $name = shift or die "display needs name as first argument";
163 my @o = grep { defined($_) && $_ ne '' } @_;
164 return unless (@o);
165 $out->{$name}->{tag} = $name;
166 $out->{$name}->{display} = \@o;
167 }
168
169 =head2 search
170
171 Prepare values just for I<search>
172
173 @v = search('Title', rec('200','a') );
174
175 =cut
176
177 sub search {
178 my $name = shift or die "search needs name as first argument";
179 my @o = grep { defined($_) && $_ ne '' } @_;
180 return unless (@o);
181 $out->{$name}->{tag} = $name;
182 $out->{$name}->{search} = \@o;
183 }
184
185 =head2 rec1
186
187 Return all values in some field
188
189 @v = rec1('200')
190
191 TODO: order of values is probably same as in source data, need to investigate that
192
193 =cut
194
195 sub rec1 {
196 my $f = shift;
197 return unless (defined($rec) && defined($rec->{$f}));
198 if (ref($rec->{$f}) eq 'ARRAY') {
199 return map {
200 if (ref($_) eq 'HASH') {
201 values %{$_};
202 } else {
203 $_;
204 }
205 } @{ $rec->{$f} };
206 } elsif( defined($rec->{$f}) ) {
207 return $rec->{$f};
208 }
209 }
210
211 =head2 rec2
212
213 Return all values in specific field and subfield
214
215 @v = rec2('200','a')
216
217 =cut
218
219 sub rec2 {
220 my $f = shift;
221 return unless (defined($rec && $rec->{$f}));
222 my $sf = shift;
223 return map { $_->{$sf} } grep { ref($_) eq 'HASH' && $_->{$sf} } @{ $rec->{$f} };
224 }
225
226 =head2 rec
227
228 syntaxtic sugar for
229
230 @v = rec('200')
231 @v = rec('200','a')
232
233 =cut
234
235 sub rec {
236 if ($#_ == 0) {
237 return rec1(@_);
238 } elsif ($#_ == 1) {
239 return rec2(@_);
240 }
241 }
242
243 =head2 regex
244
245 Apply regex to some or all values
246
247 @v = regex( 's/foo/bar/g', @v );
248
249 =cut
250
251 sub regex {
252 my $r = shift;
253 my @out;
254 #warn "r: $r\n",Dumper(\@_);
255 foreach my $t (@_) {
256 next unless ($t);
257 eval "\$t =~ $r";
258 push @out, $t if ($t && $t ne '');
259 }
260 return @out;
261 }
262
263 =head2 prefix
264
265 Prefix all values with a string
266
267 @v = prefix( 'my_', @v );
268
269 =cut
270
271 sub prefix {
272 my $p = shift or die "prefix needs string as first argument";
273 return map { $p . $_ } grep { defined($_) } @_;
274 }
275
276 =head2 suffix
277
278 suffix all values with a string
279
280 @v = suffix( '_my', @v );
281
282 =cut
283
284 sub suffix {
285 my $s = shift or die "suffix needs string as first argument";
286 return map { $_ . $s } grep { defined($_) } @_;
287 }
288
289 =head2 surround
290
291 surround all values with a two strings
292
293 @v = surround( 'prefix_', '_suffix', @v );
294
295 =cut
296
297 sub surround {
298 my $p = shift or die "surround need prefix as first argument";
299 my $s = shift or die "surround needs suffix as second argument";
300 return map { $p . $_ . $s } grep { defined($_) } @_;
301 }
302
303 =head2 first
304
305 Return first element
306
307 $v = first( @v );
308
309 =cut
310
311 sub first {
312 my $r = shift;
313 return $r;
314 }
315
316 =head2 lookup
317
318 Consult lookup hashes for some value
319
320 @v = lookup( $v );
321 @v = lookup( @v );
322
323 =cut
324
325 sub lookup {
326 my $k = shift or return;
327 return unless (defined($lookup->{$k}));
328 if (ref($lookup->{$k}) eq 'ARRAY') {
329 return @{ $lookup->{$k} };
330 } else {
331 return $lookup->{$k};
332 }
333 }
334
335 =head2 join_with
336
337 Joins walues with some delimiter
338
339 $v = join_with(", ", @v);
340
341 =cut
342
343 sub join_with {
344 my $d = shift;
345 return join($d, grep { defined($_) && $_ ne '' } @_);
346 }
347
348 # END
349 1;

  ViewVC Help
Powered by ViewVC 1.1.26