/[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 397 - (show annotations)
Wed Feb 15 15:54:12 2006 UTC (18 years, 1 month ago) by dpavlin
File size: 17757 byte(s)
 r458@llin:  dpavlin | 2006-02-15 17:01:53 +0100
 fix warnings

1 package WebPAC::Normalize;
2
3 use warnings;
4 use strict;
5 use blib;
6 use WebPAC::Common;
7 use base 'WebPAC::Common';
8 use Data::Dumper;
9
10 =head1 NAME
11
12 WebPAC::Normalize - data mungling for normalisation
13
14 =head1 VERSION
15
16 Version 0.08
17
18 =cut
19
20 our $VERSION = '0.08';
21
22 =head1 SYNOPSIS
23
24 This package contains code that mungle data to produce normalized format.
25
26 It contains several assumptions:
27
28 =over
29
30 =item *
31
32 format of fields is defined using C<v123^a> notation for repeatable fields
33 or C<s123^a> for single (or first) value, where C<123> is field number and
34 C<a> is subfield.
35
36 =item *
37
38 source data records (C<$rec>) have unique identifiers in field C<000>
39
40 =item *
41
42 optional C<eval{length('v123^a') == 3}> tag at B<beginning of format> will be
43 perl code that is evaluated before producing output (value of field will be
44 interpolated before that)
45
46 =item *
47
48 optional C<filter{filter_name}> at B<begining of format> will apply perl
49 code defined as code ref on format after field substitution to producing
50 output
51
52 There is one built-in filter called C<regex> which can be use like this:
53
54 filter{regex(s/foo/bar/)}
55
56 =item *
57
58 optional C<lookup{...}> will be then performed. See C<WebPAC::Lookups>.
59
60 =item *
61
62 at end, optional C<format>s rules are resolved. Format rules are similar to
63 C<sprintf> and can also contain C<lookup{...}> which is performed after
64 values are inserted in format.
65
66 =back
67
68 This also describes order in which transformations are applied (eval,
69 filter, lookup, format) which is important to undestand when deciding how to
70 solve your data mungling and normalisation process.
71
72
73
74
75 =head1 FUNCTIONS
76
77 =head2 new
78
79 Create new normalisation object
80
81 my $n = new WebPAC::Normalize::Something(
82 filter => {
83 'filter_name_1' => sub {
84 # filter code
85 return length($_);
86 }, ...
87 },
88 db => $db_obj,
89 lookup_regex => $lookup->regex,
90 lookup => $lookup_obj,
91 prefix => 'foobar',
92 );
93
94 Parametar C<filter> defines user supplied snippets of perl code which can
95 be use with C<filter{...}> notation.
96
97 C<prefix> is used to form filename for database record (to support multiple
98 source files which are joined in one database).
99
100 Recommended parametar C<lookup_regex> is used to enable parsing of lookups
101 in structures. If you pass this parametar, you must also pass C<lookup>
102 which is C<WebPAC::Lookup> object.
103
104 =cut
105
106 sub new {
107 my $class = shift;
108 my $self = {@_};
109 bless($self, $class);
110
111 my $r = $self->{'lookup_regex'} ? 1 : 0;
112 my $l = $self->{'lookup'} ? 1 : 0;
113
114 my $log = $self->_get_logger();
115
116 # those two must be in pair
117 if ( ($r & $l) != ($r || $l) ) {
118 my $log = $self->_get_logger();
119 $log->logdie("lookup_regex and lookup must be in pair");
120 }
121
122 $log->logdie("lookup must be WebPAC::Lookup object") if ($self->{'lookup'} && ! $self->{'lookup'}->isa('WebPAC::Lookup'));
123
124 $log->warn("no prefix defined. please check that!") unless ($self->{'prefix'});
125
126 $log->debug("using lookup regex: ", $self->{lookup_regex}) if ($r && $l);
127
128 if (! $self->{filter} || ! $self->{filter}->{regex}) {
129 $log->debug("adding built-in filter regex");
130 $self->{filter}->{regex} = sub {
131 my ($val, $regex) = @_;
132 eval "\$val =~ $regex";
133 return $val;
134 };
135 }
136
137 $self ? return $self : return undef;
138 }
139
140
141 =head2 data_structure
142
143 Create in-memory data structure which represents normalized layout from
144 C<conf/normalize/*.xml>.
145
146 This structures are used to produce output.
147
148 my $ds = $webpac->data_structure($rec);
149
150 =cut
151
152 sub data_structure {
153 my $self = shift;
154
155 my $log = $self->_get_logger();
156
157 my $rec = shift;
158 $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
159
160 $log->debug("data_structure rec = ", sub { Dumper($rec) });
161
162 $log->logdie("need unique ID (mfn) in field 000 of record " . Dumper($rec) ) unless (defined($rec->{'000'}));
163
164 my $id = $rec->{'000'}->[0] || $log->logdie("field 000 isn't array!");
165
166 my $cache_file;
167
168 if ($self->{'db'}) {
169 my $ds = $self->{'db'}->load_ds( id => $id, prefix => $self->{prefix} );
170 $log->debug("load_ds( rec = ", sub { Dumper($rec) }, ") = ", sub { Dumper($ds) });
171 return $ds if ($ds);
172 $log->debug("cache miss, creating");
173 }
174
175 my @sorted_tags;
176 if ($self->{tags_by_order}) {
177 @sorted_tags = @{$self->{tags_by_order}};
178 } else {
179 @sorted_tags = sort { $self->_sort_by_order } keys %{$self->{'import_xml'}->{'indexer'}};
180 $self->{tags_by_order} = \@sorted_tags;
181 }
182
183 my $ds;
184
185 $log->debug("tags: ",sub { join(", ",@sorted_tags) });
186
187 foreach my $field (@sorted_tags) {
188
189 my $row;
190
191 #print "field $field [",$self->{'tag'},"] = ",Dumper($self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}});
192
193 foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
194 my $format;
195
196 $log->logdie("expected tag HASH and got $tag") unless (ref($tag) eq 'HASH');
197 $format = $tag->{'value'} || $tag->{'content'};
198
199 my @v;
200 if ($self->{'lookup_regex'} && $format =~ $self->{'lookup_regex'}) {
201 @v = $self->_rec_to_arr($rec,$format,'fill_in');
202 } else {
203 @v = $self->_rec_to_arr($rec,$format,'parse');
204 }
205 if (! @v) {
206 $log->debug("$field <",$self->{tag},"> format: $format no values");
207 next;
208 } else {
209 $log->debug("$field <",$self->{tag},"> format: $format values: ", join(",", @v));
210 }
211
212 if ($tag->{'sort'}) {
213 @v = $self->sort_arr(@v);
214 }
215
216 # use format?
217 if ($tag->{'format_name'}) {
218 @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
219 }
220
221 # delimiter will join repeatable fields
222 if ($tag->{'delimiter'}) {
223 @v = ( join($tag->{'delimiter'}, @v) );
224 }
225
226 # default types
227 my @types = qw(display search);
228 # override by type attribute
229 @types = ( $tag->{'type'} ) if ($tag->{'type'});
230
231 foreach my $type (@types) {
232 # append to previous line?
233 $log->debug("tag $field / $type [",sub { join(",",@v) }, "] ", $row->{'append'} || 'no append');
234 if ($tag->{'append'}) {
235
236 # I will delimit appended part with
237 # delimiter (or ,)
238 my $d = $tag->{'delimiter'};
239 # default delimiter
240 $d ||= " ";
241
242 my $last = pop @{$row->{$type}};
243 $d = "" if (! $last);
244 $last .= $d . join($d, @v);
245 push @{$row->{$type}}, $last;
246
247 } else {
248 push @{$row->{$type}}, @v;
249 }
250 }
251
252
253 }
254
255 if ($row) {
256 $row->{'tag'} = $field;
257
258 # TODO: name_sigular, name_plural
259 my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
260 my $row_name = $name ? $self->_x($name) : $field;
261
262 # post-sort all values in field
263 if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {
264 $log->warn("sort at field tag not implemented");
265 }
266
267 $ds->{$row_name} = $row;
268
269 $log->debug("row $field: ",sub { Dumper($row) });
270 }
271
272 }
273
274 $self->{'db'}->save_ds(
275 id => $id,
276 ds => $ds,
277 prefix => $self->{prefix},
278 ) if ($self->{'db'});
279
280 $log->debug("ds: ", sub { Dumper($ds) });
281
282 $log->logconfess("data structure returned is not array any more!") if wantarray;
283
284 return $ds;
285
286 }
287
288 =head2 parse
289
290 Perform smart parsing of string, skipping delimiters for fields which aren't
291 defined. It can also eval code in format starting with C<eval{...}> and
292 return output or nothing depending on eval code.
293
294 my $text = $webpac->parse($rec,'eval{"v901^a" eq "Deskriptor"}descriptor: v250^a', $i);
295
296 Filters are implemented here. While simple form of filters looks like this:
297
298 filter{name_of_filter}
299
300 but, filters can also have variable number of parametars like this:
301
302 filter{name_of_filter(param,param,param)}
303
304 =cut
305
306 my $warn_once;
307
308 sub parse {
309 my $self = shift;
310
311 my ($rec, $format_utf8, $i, $rec_size) = @_;
312
313 return if (! $format_utf8);
314
315 my $log = $self->_get_logger();
316
317 $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
318
319 $i = 0 if (! $i);
320
321 my $format = $self->_x($format_utf8) || $log->logconfess("can't convert '$format_utf8' from UTF-8 to ",$self->{'code_page'});
322
323 my @out;
324
325 $log->debug("format: $format [$i]");
326
327 my $eval_code;
328 # remove eval{...} from beginning
329 $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
330
331 my $filter_name;
332 # remove filter{...} from beginning
333 $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
334
335 # did we found any (att all) field from format in row?
336 my $found_any;
337 # prefix before first field which we preserve it $found_any
338 my $prefix;
339
340 my $f_step = 1;
341
342 while ($format =~ s/^(.*?)(v|s)(\d+)(?:\^(\w))?//s) {
343
344 my $del = $1 || '';
345 $prefix = $del if ($f_step == 1);
346
347 my $fld_type = lc($2);
348
349 # repeatable index
350 my $r = $i;
351 if ($fld_type eq 's') {
352 if ($found_any->{'v'}) {
353 $r = 0;
354 } else {
355 return;
356 }
357 }
358
359 my $found = 0;
360 my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found,$rec_size);
361
362 if ($found) {
363 $found_any->{$fld_type} += $found;
364
365 # we will skip delimiter before first occurence of field!
366 push @out, $del unless($found_any->{$fld_type} == 1);
367 push @out, $tmp;
368 }
369 $f_step++;
370 }
371
372 # test if any fields found?
373 return if (! $found_any->{'v'} && ! $found_any->{'s'});
374
375 my $out = join('',@out);
376
377 if ($out) {
378 # add rest of format (suffix)
379 $out .= $format;
380
381 # add prefix if not there
382 $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);
383
384 $log->debug("result: $out");
385 }
386
387 if ($eval_code) {
388 my $eval = $self->fill_in($rec,$eval_code,$i) || return;
389 $log->debug("about to eval{$eval} format: $out");
390 return if (! $self->_eval($eval));
391 }
392
393 if ($filter_name) {
394 my @filter_args;
395 if ($filter_name =~ s/(\w+)\((.*)\)/$1/) {
396 @filter_args = split(/,/, $2);
397 }
398 if ($self->{'filter'}->{$filter_name}) {
399 $log->debug("about to filter{$filter_name} format: $out with arguments: ", join(",", @filter_args));
400 unshift @filter_args, $out;
401 $out = $self->{'filter'}->{$filter_name}->(@filter_args);
402 return unless(defined($out));
403 $log->debug("filter result: $out");
404 } elsif (! $warn_once->{$filter_name}) {
405 $log->warn("trying to use undefined filter $filter_name");
406 $warn_once->{$filter_name}++;
407 }
408 }
409
410 return $out;
411 }
412
413 =head2 fill_in
414
415 Workhourse of all: takes record from in-memory structure of database and
416 strings with placeholders and returns string or array of with substituted
417 values from record.
418
419 my $text = $webpac->fill_in($rec,'v250^a');
420
421 Optional argument is ordinal number for repeatable fields. By default,
422 it's assume to be first repeatable field (fields are perl array, so first
423 element is 0).
424 Following example will read second value from repeatable field.
425
426 my $text = $webpac->fill_in($rec,'Title: v250^a',1);
427
428 This function B<does not> perform parsing of format to inteligenty skip
429 delimiters before fields which aren't used.
430
431 This method will automatically decode UTF-8 string to local code page
432 if needed.
433
434 There is optional parametar C<$record_size> which can be used to get sizes of
435 all C<field^subfield> combinations in this format.
436
437 my $text = $webpac->fill_in($rec,'got: v900^a v900^x',0,\$rec_size);
438
439 =cut
440
441 sub fill_in {
442 my $self = shift;
443
444 my $log = $self->_get_logger();
445
446 my ($rec,$format,$i,$rec_size) = @_;
447
448 $log->logconfess("need data record") unless ($rec);
449 $log->logconfess("need format to parse") unless($format);
450
451 # iteration (for repeatable fields)
452 $i ||= 0;
453
454 $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));
455
456 # FIXME remove for speedup?
457 $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
458
459 if (utf8::is_utf8($format)) {
460 $format = $self->_x($format);
461 }
462
463 my $found = 0;
464 my $just_single = 1;
465
466 my $eval_code;
467 # remove eval{...} from beginning
468 $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
469
470 my $filter_name;
471 # remove filter{...} from beginning
472 $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
473
474 {
475 # fix warnings
476 no warnings 'uninitialized';
477
478 # do actual replacement of placeholders
479 # repeatable fields
480 if ($format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found,$rec_size)/ges) {
481 $just_single = 0;
482 }
483
484 # non-repeatable fields
485 if ($format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found,$rec_size)/ges) {
486 return if ($i > 0 && $just_single);
487 }
488 }
489
490 if ($found) {
491 $log->debug("format: $format");
492 if ($eval_code) {
493 my $eval = $self->fill_in($rec,$eval_code,$i);
494 return if (! $self->_eval($eval));
495 }
496 if ($filter_name && $self->{'filter'}->{$filter_name}) {
497 $log->debug("filter '$filter_name' for $format");
498 $format = $self->{'filter'}->{$filter_name}->($format);
499 return unless(defined($format));
500 $log->debug("filter result: $format");
501 }
502 # do we have lookups?
503 if ($self->{'lookup'}) {
504 if ($self->{'lookup'}->can('lookup')) {
505 my @lookup = $self->{lookup}->lookup($format);
506 $log->debug("lookup $format", join(", ", @lookup));
507 return @lookup;
508 } else {
509 $log->warn("Have lookup object but can't invoke lookup method");
510 }
511 } else {
512 return $format;
513 }
514 } else {
515 return;
516 }
517 }
518
519
520 =head2 _rec_to_arr
521
522 Similar to C<parse> and C<fill_in>, but returns array of all repeatable fields. Usable
523 for fields which have lookups, so they shouldn't be parsed but rather
524 C<paste>d or C<fill_id>ed. Last argument is name of operation: C<paste> or C<fill_in>.
525
526 my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]','paste');
527
528 =cut
529
530 sub _rec_to_arr {
531 my $self = shift;
532
533 my ($rec, $format_utf8, $code) = @_;
534
535 my $log = $self->_get_logger();
536
537 $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
538 return if (! $format_utf8);
539
540 $log->debug("using $code on $format_utf8");
541
542 my $i = 0;
543 my $max = 0;
544 my @arr;
545 my $rec_size = {};
546
547 while ($i <= $max) {
548 my @v = $self->$code($rec,$format_utf8,$i++,\$rec_size);
549 if ($rec_size) {
550 foreach my $f (keys %{ $rec_size }) {
551 $max = $rec_size->{$f} if ($rec_size->{$f} > $max);
552 }
553 $log->debug("max set to $max");
554 undef $rec_size;
555 }
556 if (@v) {
557 push @arr, @v;
558 } else {
559 push @arr, '' if ($max > $i);
560 }
561 }
562
563 $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
564
565 return @arr;
566 }
567
568
569 =head2 get_data
570
571 Returns value from record.
572
573 my $text = $self->get_data(\$rec,$f,$sf,$i,\$found,\$rec_size);
574
575 Required arguments are:
576
577 =over 8
578
579 =item C<$rec>
580
581 record reference
582
583 =item C<$f>
584
585 field
586
587 =item C<$sf>
588
589 optional subfield
590
591 =item C<$i>
592
593 index offset for repeatable values ( 0 ... $rec_size->{'400^a'} )
594
595 =item C<$found>
596
597 optional variable that will be incremeted if preset
598
599 =item C<$rec_size>
600
601 hash to hold maximum occurances of C<field^subfield> combinations
602 (which can be accessed using keys in same format)
603
604 =back
605
606 Returns value or empty string, updates C<$found> and C<rec_size>
607 if present.
608
609 =cut
610
611 sub get_data {
612 my $self = shift;
613
614 my ($rec,$f,$sf,$i,$found,$cache) = @_;
615
616 return '' unless ($$rec->{$f} && ref($$rec->{$f}) eq 'ARRAY');
617
618 if (defined($$cache)) {
619 $$cache->{ $f . ( $sf ? '^' . $sf : '' ) } ||= scalar @{ $$rec->{$f} };
620 }
621
622 return '' unless ($$rec->{$f}->[$i]);
623
624 {
625 no strict 'refs';
626 if (defined($sf)) {
627 $$found++ if (defined($$found) && $$rec->{$f}->[$i]->{$sf});
628 return $$rec->{$f}->[$i]->{$sf};
629 } else {
630 $$found++ if (defined($$found));
631 # it still might have subfields, just
632 # not specified, so we'll dump some debug info
633 if ($$rec->{$f}->[$i] =~ /HASH/o) {
634 my $out;
635 foreach my $k (keys %{$$rec->{$f}->[$i]}) {
636 $out .= '$' . $k .':' . $$rec->{$f}->[$i]->{$k}." ";
637 }
638 return $out;
639 } else {
640 return $$rec->{$f}->[$i];
641 }
642 }
643 }
644 }
645
646
647 =head2 apply_format
648
649 Apply format specified in tag with C<format_name="name"> and
650 C<format_delimiter=";;">.
651
652 my $text = $webpac->apply_format($format_name,$format_delimiter,$data);
653
654 Formats can contain C<lookup{...}> if you need them.
655
656 =cut
657
658 sub apply_format {
659 my $self = shift;
660
661 my ($name,$delimiter,$data) = @_;
662
663 my $log = $self->_get_logger();
664
665 if (! $self->{'import_xml'}->{'format'}->{$name}) {
666 $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});
667 return $data;
668 }
669
670 $log->warn("no delimiter for format $name") if (! $delimiter);
671
672 my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");
673
674 my @data = split(/\Q$delimiter\E/, $data);
675
676 my $out = sprintf($format, @data);
677 $log->debug("using format $name [$format] on $data to produce: $out");
678
679 if ($self->{'lookup_regex'} && $out =~ $self->{'lookup_regex'}) {
680 return $self->{'lookup'}->lookup($out);
681 } else {
682 return $out;
683 }
684
685 }
686
687 =head2 sort_arr
688
689 Sort array ignoring case and html in data
690
691 my @sorted = $webpac->sort_arr(@unsorted);
692
693 =cut
694
695 sub sort_arr {
696 my $self = shift;
697
698 my $log = $self->_get_logger();
699
700 # FIXME add Schwartzian Transformation?
701
702 my @sorted = sort {
703 $a =~ s#<[^>]+/*>##;
704 $b =~ s#<[^>]+/*>##;
705 lc($b) cmp lc($a)
706 } @_;
707 $log->debug("sorted values: ",sub { join(", ",@sorted) });
708
709 return @sorted;
710 }
711
712
713 =head1 INTERNAL METHODS
714
715 =head2 _sort_by_order
716
717 Sort xml tags data structure accoding to C<order=""> attribute.
718
719 =cut
720
721 sub _sort_by_order {
722 my $self = shift;
723
724 my $va = $self->{'import_xml'}->{'indexer'}->{$a}->{'order'} ||
725 $self->{'import_xml'}->{'indexer'}->{$a};
726 my $vb = $self->{'import_xml'}->{'indexer'}->{$b}->{'order'} ||
727 $self->{'import_xml'}->{'indexer'}->{$b};
728
729 return $va <=> $vb;
730 }
731
732 =head2 _x
733
734 Convert strings from C<conf/normalize/*.xml> encoding into application
735 specific encoding (optinally specified using C<code_page> to C<new>
736 constructor).
737
738 my $text = $n->_x('normalize text string');
739
740 This is a stub so that other modules doesn't have to implement it.
741
742 =cut
743
744 sub _x {
745 my $self = shift;
746 return shift;
747 }
748
749
750 =head1 AUTHOR
751
752 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
753
754 =head1 COPYRIGHT & LICENSE
755
756 Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.
757
758 This program is free software; you can redistribute it and/or modify it
759 under the same terms as Perl itself.
760
761 =cut
762
763 1; # End of WebPAC::Normalize

  ViewVC Help
Powered by ViewVC 1.1.26