/[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 372 - (show annotations)
Sun Jan 8 21:50:34 2006 UTC (17 years ago) by dpavlin
File size: 17619 byte(s)
 r412@llin:  dpavlin | 2006-01-08 22:50:49 +0100
 more refactoring: joined paste_to_arr and fill_in_to_arr to _rec_to_arr

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 # do actual replacement of placeholders
475 # repeatable fields
476 if ($format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found,$rec_size)/ges) {
477 $just_single = 0;
478 }
479
480 # non-repeatable fields
481 if ($format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found,$rec_size)/ges) {
482 return if ($i > 0 && $just_single);
483 }
484
485 if ($found) {
486 $log->debug("format: $format");
487 if ($eval_code) {
488 my $eval = $self->fill_in($rec,$eval_code,$i);
489 return if (! $self->_eval($eval));
490 }
491 if ($filter_name && $self->{'filter'}->{$filter_name}) {
492 $log->debug("filter '$filter_name' for $format");
493 $format = $self->{'filter'}->{$filter_name}->($format);
494 return unless(defined($format));
495 $log->debug("filter result: $format");
496 }
497 # do we have lookups?
498 if ($self->{'lookup'}) {
499 if ($self->{'lookup'}->can('lookup')) {
500 my @lookup = $self->{lookup}->lookup($format);
501 $log->debug("lookup $format", join(", ", @lookup));
502 return @lookup;
503 } else {
504 $log->warn("Have lookup object but can't invoke lookup method");
505 }
506 } else {
507 return $format;
508 }
509 } else {
510 return;
511 }
512 }
513
514
515 =head2 _rec_to_arr
516
517 Similar to C<parse> and C<fill_in>, but returns array of all repeatable fields. Usable
518 for fields which have lookups, so they shouldn't be parsed but rather
519 C<paste>d or C<fill_id>ed. Last argument is name of operation: C<paste> or C<fill_in>.
520
521 my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]','paste');
522
523 =cut
524
525 sub _rec_to_arr {
526 my $self = shift;
527
528 my ($rec, $format_utf8, $code) = @_;
529
530 my $log = $self->_get_logger();
531
532 $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
533 return if (! $format_utf8);
534
535 my $i = 0;
536 my $max = 0;
537 my @arr;
538 my $rec_size = {};
539
540 while ($i <= $max) {
541 my $v = $self->$code($rec,$format_utf8,$i++,\$rec_size) || next;
542 push @arr, $v;
543 if ($rec_size) {
544 foreach my $f (keys %{ $rec_size }) {
545 $max = $rec_size->{$f} if ($rec_size->{$f} > $max);
546 }
547 warn "max set to $max, rec_size = ", Dumper($rec_size);
548 undef $rec_size;
549 }
550 }
551
552 $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
553
554 return @arr;
555 }
556
557
558 =head2 get_data
559
560 Returns value from record.
561
562 my $text = $self->get_data(\$rec,$f,$sf,$i,\$found,\$rec_size);
563
564 Required arguments are:
565
566 =over 8
567
568 =item C<$rec>
569
570 record reference
571
572 =item C<$f>
573
574 field
575
576 =item C<$sf>
577
578 optional subfield
579
580 =item C<$i>
581
582 index offset for repeatable values ( 0 ... $rec_size->{'400^a'} )
583
584 =item C<$found>
585
586 optional variable that will be incremeted if preset
587
588 =item C<$rec_size>
589
590 hash to hold maximum occurances of C<field^subfield> combinations
591 (which can be accessed using keys in same format)
592
593 =back
594
595 Returns value or empty string, updates C<$found> and C<rec_size>
596 if present.
597
598 =cut
599
600 sub get_data {
601 my $self = shift;
602
603 my ($rec,$f,$sf,$i,$found,$cache) = @_;
604
605 return '' unless ($$rec->{$f} && ref($$rec->{$f}) eq 'ARRAY');
606
607 if (defined($$cache)) {
608 $$cache->{ $f . ( $sf ? '^' . $sf : '' ) } ||= scalar @{ $$rec->{$f} };
609 }
610
611 return '' unless ($$rec->{$f}->[$i]);
612
613 {
614 no strict 'refs';
615 if (defined($sf)) {
616 $$found++ if (defined($$found) && $$rec->{$f}->[$i]->{$sf});
617 return $$rec->{$f}->[$i]->{$sf};
618 } else {
619 $$found++ if (defined($$found));
620 # it still might have subfields, just
621 # not specified, so we'll dump some debug info
622 if ($$rec->{$f}->[$i] =~ /HASH/o) {
623 my $out;
624 foreach my $k (keys %{$$rec->{$f}->[$i]}) {
625 $out .= '$' . $k .':' . $$rec->{$f}->[$i]->{$k}." ";
626 }
627 return $out;
628 } else {
629 return $$rec->{$f}->[$i];
630 }
631 }
632 }
633 }
634
635
636 =head2 apply_format
637
638 Apply format specified in tag with C<format_name="name"> and
639 C<format_delimiter=";;">.
640
641 my $text = $webpac->apply_format($format_name,$format_delimiter,$data);
642
643 Formats can contain C<lookup{...}> if you need them.
644
645 =cut
646
647 sub apply_format {
648 my $self = shift;
649
650 my ($name,$delimiter,$data) = @_;
651
652 my $log = $self->_get_logger();
653
654 if (! $self->{'import_xml'}->{'format'}->{$name}) {
655 $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});
656 return $data;
657 }
658
659 $log->warn("no delimiter for format $name") if (! $delimiter);
660
661 my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");
662
663 my @data = split(/\Q$delimiter\E/, $data);
664
665 my $out = sprintf($format, @data);
666 $log->debug("using format $name [$format] on $data to produce: $out");
667
668 if ($self->{'lookup_regex'} && $out =~ $self->{'lookup_regex'}) {
669 return $self->{'lookup'}->lookup($out);
670 } else {
671 return $out;
672 }
673
674 }
675
676 =head2 sort_arr
677
678 Sort array ignoring case and html in data
679
680 my @sorted = $webpac->sort_arr(@unsorted);
681
682 =cut
683
684 sub sort_arr {
685 my $self = shift;
686
687 my $log = $self->_get_logger();
688
689 # FIXME add Schwartzian Transformation?
690
691 my @sorted = sort {
692 $a =~ s#<[^>]+/*>##;
693 $b =~ s#<[^>]+/*>##;
694 lc($b) cmp lc($a)
695 } @_;
696 $log->debug("sorted values: ",sub { join(", ",@sorted) });
697
698 return @sorted;
699 }
700
701
702 =head1 INTERNAL METHODS
703
704 =head2 _sort_by_order
705
706 Sort xml tags data structure accoding to C<order=""> attribute.
707
708 =cut
709
710 sub _sort_by_order {
711 my $self = shift;
712
713 my $va = $self->{'import_xml'}->{'indexer'}->{$a}->{'order'} ||
714 $self->{'import_xml'}->{'indexer'}->{$a};
715 my $vb = $self->{'import_xml'}->{'indexer'}->{$b}->{'order'} ||
716 $self->{'import_xml'}->{'indexer'}->{$b};
717
718 return $va <=> $vb;
719 }
720
721 =head2 _x
722
723 Convert strings from C<conf/normalize/*.xml> encoding into application
724 specific encoding (optinally specified using C<code_page> to C<new>
725 constructor).
726
727 my $text = $n->_x('normalize text string');
728
729 This is a stub so that other modules doesn't have to implement it.
730
731 =cut
732
733 sub _x {
734 my $self = shift;
735 return shift;
736 }
737
738
739 =head1 AUTHOR
740
741 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
742
743 =head1 COPYRIGHT & LICENSE
744
745 Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.
746
747 This program is free software; you can redistribute it and/or modify it
748 under the same terms as Perl itself.
749
750 =cut
751
752 1; # End of WebPAC::Normalize

  ViewVC Help
Powered by ViewVC 1.1.26