/[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

Diff of /trunk/lib/WebPAC/Normalize.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 14 by dpavlin, Sun Jul 17 00:04:25 2005 UTC revision 252 by dpavlin, Thu Dec 15 17:01:04 2005 UTC
# Line 2  package WebPAC::Normalize; Line 2  package WebPAC::Normalize;
2    
3  use warnings;  use warnings;
4  use strict;  use strict;
5    use base 'WebPAC::Common';
6  use Data::Dumper;  use Data::Dumper;
 use Storable;  
7    
8  =head1 NAME  =head1 NAME
9    
10  WebPAC::Normalize - normalisation of source file  WebPAC::Normalize - data mungling for normalisation
11    
12  =head1 VERSION  =head1 VERSION
13    
14  Version 0.01  Version 0.04
15    
16  =cut  =cut
17    
18  our $VERSION = '0.01';  our $VERSION = '0.04';
19    
20  =head1 SYNOPSIS  =head1 SYNOPSIS
21    
22  This package contains code that could be helpful in implementing different  This package contains code that mungle data to produce normalized format.
23  normalisation front-ends.  
24    It contains several assumptions:
25    
26    =over
27    
28    =item *
29    
30    format of fields is defined using C<v123^a> notation for repeatable fields
31    or C<s123^a> for single (or first) value, where C<123> is field number and
32    C<a> is subfield.
33    
34    =item *
35    
36    source data records (C<$rec>) have unique identifiers in field C<000>
37    
38    =item *
39    
40    optional C<eval{length('v123^a') == 3}> tag at B<beginning of format> will be
41    perl code that is evaluated before producing output (value of field will be
42    interpolated before that)
43    
44    =item *
45    
46    optional C<filter{filter_name}> at B<begining of format> will apply perl
47    code defined as code ref on format after field substitution to producing
48    output
49    
50    =item *
51    
52    optional C<lookup{...}> will be then performed. See C<WebPAC::Lookups>.
53    
54    =item *
55    
56    at end, optional C<format>s rules are resolved. Format rules are similar to
57    C<sprintf> and can also contain C<lookup{...}> which is performed after
58    values are inserted in format.
59    
60    =back
61    
62    This also describes order in which transformations are applied (eval,
63    filter, lookup, format) which is important to undestand when deciding how to
64    solve your data mungling and normalisation process.
65    
66    
67    
68    
69  =head1 FUNCTIONS  =head1 FUNCTIONS
70    
# Line 29  normalisation front-ends. Line 73  normalisation front-ends.
73  Create new normalisation object  Create new normalisation object
74    
75    my $n = new WebPAC::Normalize::Something(    my $n = new WebPAC::Normalize::Something(
76          cache_data_structure => './cache/ds/',          filter => {
77                    'filter_name_1' => sub {
78                            # filter code
79                            return length($_);
80                    }, ...
81            },
82            db => $db_obj,
83          lookup_regex => $lookup->regex,          lookup_regex => $lookup->regex,
84            lookup => $lookup_obj,
85            prefix => 'foobar',
86    );    );
87    
88  Optional parameter C<cache_data_structure> defines path to directory  Parametar C<filter> defines user supplied snippets of perl code which can
89  in which cache file for C<data_structure> call will be created.  be use with C<filter{...}> notation.
90    
91    C<prefix> is used to form filename for database record (to support multiple
92    source files which are joined in one database).
93    
94  Recommended parametar C<lookup_regex> is used to enable parsing of lookups  Recommended parametar C<lookup_regex> is used to enable parsing of lookups
95  in structures.  in structures. If you pass this parametar, you must also pass C<lookup>
96    which is C<WebPAC::Lookup> object.
97    
98  =cut  =cut
99    
# Line 46  sub new { Line 102  sub new {
102          my $self = {@_};          my $self = {@_};
103          bless($self, $class);          bless($self, $class);
104    
105          $self->setup_cache_dir( $self->{'cache_data_structure'} );          my $r = $self->{'lookup_regex'} ? 1 : 0;
106            my $l = $self->{'lookup'} ? 1 : 0;
         $self ? return $self : return undef;  
 }  
   
 =head2 setup_cache_dir  
107    
108  Check if specified cache directory exist, and if not, disable caching.          my $log = $self->_get_logger();
   
  $setup_cache_dir('./cache/ds/');  
   
 If you pass false or zero value to this function, it will disable  
 cacheing.  
   
 =cut  
109    
110  sub setup_cache_dir {          # those two must be in pair
111          my $self = shift;          if ( ($r & $l) != ($r || $l) ) {
112                    my $log = $self->_get_logger();
113                    $log->logdie("lookup_regex and lookup must be in pair");
114            }
115    
116          my $dir = shift;          $log->logdie("lookup must be WebPAC::Lookup object") if ($self->{'lookup'} && ! $self->{'lookup'}->isa('WebPAC::Lookup'));
117    
118          my $log = $self->_get_logger();          $log->warn("no prefix defined. please check that!") unless ($self->{'prefix'});
119    
120          if ($dir) {          $log->debug("using lookup regex: ", $self->{lookup_regex}) if ($r && $l);
                 my $msg;  
                 if (! -e $dir) {  
                         $msg = "doesn't exist";  
                 } elsif (! -d $dir) {  
                         $msg = "is not directory";  
                 } elsif (! -w $dir) {  
                         $msg = "not writable";  
                 }  
121    
122                  if ($msg) {          $self ? return $self : return undef;
                         undef $self->{'cache_data_structure'};  
                         $log->warn("cache_data_structure $dir $msg, disabling...");  
                 } else {  
                         $log->debug("using cache dir $dir");  
                 }  
         } else {  
                 $log->debug("disabling cache");  
                 undef $self->{'cache_data_structure'};  
         }  
123  }  }
124    
125    
# Line 99  C<conf/normalize/*.xml>. Line 130  C<conf/normalize/*.xml>.
130    
131  This structures are used to produce output.  This structures are used to produce output.
132    
133   my @ds = $webpac->data_structure($rec);   my $ds = $webpac->data_structure($rec);
   
 B<Note: historical oddity follows>  
   
 This method will also set C<< $webpac->{'currnet_filename'} >> if there is  
 C<< <filename> >> tag and C<< $webpac->{'headline'} >> if there is  
 C<< <headline> >> tag.  
134    
135  =cut  =cut
136    
# Line 117  sub data_structure { Line 142  sub data_structure {
142          my $rec = shift;          my $rec = shift;
143          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
144    
145            $log->debug("data_structure rec = ", sub { Dumper($rec) });
146    
147            $log->logdie("need unique ID (mfn) in field 000 of record ", sub { Dumper($rec) } ) unless (defined($rec->{'000'}));
148    
149            my $id = $rec->{'000'}->[0] || $log->logdie("field 000 isn't array!");
150    
151          my $cache_file;          my $cache_file;
152    
153          if (my $cache_path = $self->{'cache_data_structure'}) {          if ($self->{'db'}) {
154                  my $id = $rec->{'000'};                  my $ds = $self->{'db'}->load_ds( id => $id, prefix => $self->{prefix} );
155                  $id = $rec->{'000'}->[0] if ($id =~ m/^ARRAY/o);                  $log->debug("load_ds( rec = ", sub { Dumper($rec) }, ") = ", sub { Dumper($ds) });
156                  unless (defined($id)) {                  return $ds if ($ds);
157                          $log->warn("Can't use cache_data_structure on records without unique identifier in field 000");                  $log->debug("cache miss, creating");
                         undef $self->{'cache_data_structure'};  
                 } else {  
                         $cache_file = "$cache_path/$id";  
                         if (-r $cache_file) {  
                                 my $ds_ref = retrieve($cache_file);  
                                 if ($ds_ref) {  
                                         $log->debug("cache hit: $cache_file");  
                                         my $ok = 1;  
                                         foreach my $f (qw(current_filename headline)) {  
                                                 if ($ds_ref->{$f}) {  
                                                         $self->{$f} = $ds_ref->{$f};  
                                                 } else {  
                                                         $ok = 0;  
                                                 }  
                                         };  
                                         if ($ok && $ds_ref->{'ds'}) {  
                                                 return @{ $ds_ref->{'ds'} };  
                                         } else {  
                                                 $log->warn("cache_data_structure $cache_path corrupt. Use rm $cache_path/* to re-create it on next run!");  
                                                 undef $self->{'cache_data_structure'};  
                                         }  
                                 }  
                         }  
                 }  
158          }          }
159    
160          undef $self->{'currnet_filename'};          undef $self->{'currnet_filename'};
# Line 161  sub data_structure { Line 168  sub data_structure {
168                  $self->{tags_by_order} = \@sorted_tags;                  $self->{tags_by_order} = \@sorted_tags;
169          }          }
170    
171          my @ds;          my $ds;
172    
173          $log->debug("tags: ",sub { join(", ",@sorted_tags) });          $log->debug("tags: ",sub { join(", ",@sorted_tags) });
174    
# Line 172  sub data_structure { Line 179  sub data_structure {
179  #print "field $field [",$self->{'tag'},"] = ",Dumper($self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}});  #print "field $field [",$self->{'tag'},"] = ",Dumper($self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}});
180    
181                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
182                          my $format = $tag->{'value'} || $tag->{'content'};                          my $format;
183    
184                            $log->logdie("expected tag HASH and got $tag") unless (ref($tag) eq 'HASH');
185                            $format = $tag->{'value'} || $tag->{'content'};
186    
187                          $log->debug("format: $format");                          $log->debug("format: $format");
188    
# Line 193  sub data_structure { Line 203  sub data_structure {
203                                  @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;                                  @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
204                          }                          }
205    
                         if ($field eq 'filename') {  
                                 $self->{'current_filename'} = join('',@v);  
                                 $log->debug("filename: ",$self->{'current_filename'});  
                         } elsif ($field eq 'headline') {  
                                 $self->{'headline'} .= join('',@v);  
                                 $log->debug("headline: ",$self->{'headline'});  
                                 next; # don't return headline in data_structure!  
                         }  
   
206                          # delimiter will join repeatable fields                          # delimiter will join repeatable fields
207                          if ($tag->{'delimiter'}) {                          if ($tag->{'delimiter'}) {
208                                  @v = ( join($tag->{'delimiter'}, @v) );                                  @v = ( join($tag->{'delimiter'}, @v) );
209                          }                          }
210    
211                          # default types                          # default types
212                          my @types = qw(display swish);                          my @types = qw(display search);
213                          # override by type attribute                          # override by type attribute
214                          @types = ( $tag->{'type'} ) if ($tag->{'type'});                          @types = ( $tag->{'type'} ) if ($tag->{'type'});
215    
216                          foreach my $type (@types) {                          foreach my $type (@types) {
217                                  # append to previous line?                                  # append to previous line?
218                                  $log->debug("type: $type ",sub { join(" ",@v) }, $row->{'append'} || 'no append');                                  $log->debug("type: $type ",sub { join(" ",@v) }, " ", $row->{'append'} || 'no append');
219                                  if ($tag->{'append'}) {                                  if ($tag->{'append'}) {
220    
221                                          # I will delimit appended part with                                          # I will delimit appended part with
# Line 241  sub data_structure { Line 242  sub data_structure {
242    
243                          # TODO: name_sigular, name_plural                          # TODO: name_sigular, name_plural
244                          my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};                          my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
245                          $row->{'name'} = $name ? $self->_x($name) : $field;                          my $row_name = $name ? $self->_x($name) : $field;
246    
247                          # post-sort all values in field                          # post-sort all values in field
248                          if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {                          if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {
249                                  $log->warn("sort at field tag not implemented");                                  $log->warn("sort at field tag not implemented");
250                          }                          }
251    
252                          push @ds, $row;                          $ds->{$row_name} = $row;
253    
254                          $log->debug("row $field: ",sub { Dumper($row) });                          $log->debug("row $field: ",sub { Dumper($row) });
255                  }                  }
256    
257          }          }
258    
259          if ($cache_file) {          $self->{'db'}->save_ds(
260                  store {                  id => $id,
261                          ds => \@ds,                  ds => $ds,
262                          current_filename => $self->{'current_filename'},                  prefix => $self->{prefix},
263                          headline => $self->{'headline'},          ) if ($self->{'db'});
                 }, $cache_file;  
                 $log->debug("created storable cache file $cache_file");  
         }  
   
         return @ds;  
   
 }  
   
 =head2 apply_format  
   
 Apply format specified in tag with C<format_name="name"> and  
 C<format_delimiter=";;">.  
   
  my $text = $webpac->apply_format($format_name,$format_delimiter,$data);  
   
 Formats can contain C<lookup{...}> if you need them.  
264    
265  =cut          $log->debug("ds: ", sub { Dumper($ds) });
   
 sub apply_format {  
         my $self = shift;  
266    
267          my ($name,$delimiter,$data) = @_;          $log->logconfess("data structure returned is not array any more!") if wantarray;
268    
269          my $log = $self->_get_logger();          return $ds;
   
         if (! $self->{'import_xml'}->{'format'}->{$name}) {  
                 $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});  
                 return $data;  
         }  
   
         $log->warn("no delimiter for format $name") if (! $delimiter);  
   
         my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");  
   
         my @data = split(/\Q$delimiter\E/, $data);  
   
         my $out = sprintf($format, @data);  
         $log->debug("using format $name [$format] on $data to produce: $out");  
   
         if ($self->{'lookup_regex'} && $out =~ $self->{'lookup_regex'}) {  
                 return $self->lookup($out);  
         } else {  
                 return $out;  
         }  
270    
271  }  }
272    
# Line 427  sub parse_to_arr { Line 389  sub parse_to_arr {
389          return @arr;          return @arr;
390  }  }
391    
392    
393    =head2 fill_in
394    
395    Workhourse of all: takes record from in-memory structure of database and
396    strings with placeholders and returns string or array of with substituted
397    values from record.
398    
399     my $text = $webpac->fill_in($rec,'v250^a');
400    
401    Optional argument is ordinal number for repeatable fields. By default,
402    it's assume to be first repeatable field (fields are perl array, so first
403    element is 0).
404    Following example will read second value from repeatable field.
405    
406     my $text = $webpac->fill_in($rec,'Title: v250^a',1);
407    
408    This function B<does not> perform parsing of format to inteligenty skip
409    delimiters before fields which aren't used.
410    
411    This method will automatically decode UTF-8 string to local code page
412    if needed.
413    
414    =cut
415    
416    sub fill_in {
417            my $self = shift;
418    
419            my $log = $self->_get_logger();
420    
421            my $rec = shift || $log->logconfess("need data record");
422            my $format = shift || $log->logconfess("need format to parse");
423            # iteration (for repeatable fields)
424            my $i = shift || 0;
425    
426            $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));
427    
428            # FIXME remove for speedup?
429            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
430    
431            if (utf8::is_utf8($format)) {
432                    $format = $self->_x($format);
433            }
434    
435            my $found = 0;
436    
437            my $eval_code;
438            # remove eval{...} from beginning
439            $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
440    
441            my $filter_name;
442            # remove filter{...} from beginning
443            $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
444    
445            # do actual replacement of placeholders
446            # repeatable fields
447            $format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;
448            # non-repeatable fields
449            $format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found)/ges;
450    
451            if ($found) {
452                    $log->debug("format: $format");
453                    if ($eval_code) {
454                            my $eval = $self->fill_in($rec,$eval_code,$i);
455                            return if (! $self->_eval($eval));
456                    }
457                    if ($filter_name && $self->{'filter'}->{$filter_name}) {
458                            $log->debug("filter '$filter_name' for $format");
459                            $format = $self->{'filter'}->{$filter_name}->($format);
460                            return unless(defined($format));
461                            $log->debug("filter result: $format");
462                    }
463                    # do we have lookups?
464                    if ($self->{'lookup'}) {
465                            if ($self->{'lookup'}->can('lookup')) {
466                                    my @lookup = $self->{lookup}->lookup($format);
467                                    $log->debug('lookup $format', join(", ", @lookup));
468                                    return @lookup;
469                            } else {
470                                    $log->warn("Have lookup object but can't invoke lookup method");
471                            }
472                    } else {
473                            return $format;
474                    }
475            } else {
476                    return;
477            }
478    }
479    
480    
481  =head2 fill_in_to_arr  =head2 fill_in_to_arr
482    
483  Similar to C<fill_in>, but returns array of all repeatable fields. Usable  Similar to C<fill_in>, but returns array of all repeatable fields. Usable
# Line 459  sub fill_in_to_arr { Line 510  sub fill_in_to_arr {
510          return @arr;          return @arr;
511  }  }
512    
513    
514    =head2 get_data
515    
516    Returns value from record.
517    
518     my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);
519    
520    Arguments are:
521    record reference C<$rec>,
522    field C<$f>,
523    optional subfiled C<$sf>,
524    index for repeatable values C<$i>.
525    
526    Optinal variable C<$found> will be incremeted if there
527    is field.
528    
529    Returns value or empty string.
530    
531    =cut
532    
533    sub get_data {
534            my $self = shift;
535    
536            my ($rec,$f,$sf,$i,$found) = @_;
537    
538            if ($$rec->{$f}) {
539                    return '' if (! $$rec->{$f}->[$i]);
540                    no strict 'refs';
541                    if ($sf && $$rec->{$f}->[$i]->{$sf}) {
542                            $$found++ if (defined($$found));
543                            return $$rec->{$f}->[$i]->{$sf};
544                    } elsif (! $sf && $$rec->{$f}->[$i]) {
545                            $$found++ if (defined($$found));
546                            # it still might have subfield, just
547                            # not specified, so we'll dump all
548                            if ($$rec->{$f}->[$i] =~ /HASH/o) {
549                                    my $out;
550                                    foreach my $k (keys %{$$rec->{$f}->[$i]}) {
551                                            $out .= $$rec->{$f}->[$i]->{$k}." ";
552                                    }
553                                    return $out;
554                            } else {
555                                    return $$rec->{$f}->[$i];
556                            }
557                    } else {
558                            return '';
559                    }
560            } else {
561                    return '';
562            }
563    }
564    
565    
566    =head2 apply_format
567    
568    Apply format specified in tag with C<format_name="name"> and
569    C<format_delimiter=";;">.
570    
571     my $text = $webpac->apply_format($format_name,$format_delimiter,$data);
572    
573    Formats can contain C<lookup{...}> if you need them.
574    
575    =cut
576    
577    sub apply_format {
578            my $self = shift;
579    
580            my ($name,$delimiter,$data) = @_;
581    
582            my $log = $self->_get_logger();
583    
584            if (! $self->{'import_xml'}->{'format'}->{$name}) {
585                    $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});
586                    return $data;
587            }
588    
589            $log->warn("no delimiter for format $name") if (! $delimiter);
590    
591            my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");
592    
593            my @data = split(/\Q$delimiter\E/, $data);
594    
595            my $out = sprintf($format, @data);
596            $log->debug("using format $name [$format] on $data to produce: $out");
597    
598            if ($self->{'lookup_regex'} && $out =~ $self->{'lookup_regex'}) {
599                    return $self->{'lookup'}->lookup($out);
600            } else {
601                    return $out;
602            }
603    
604    }
605    
606  =head2 sort_arr  =head2 sort_arr
607    
608  Sort array ignoring case and html in data  Sort array ignoring case and html in data
# Line 485  sub sort_arr { Line 629  sub sort_arr {
629  }  }
630    
631    
632    =head1 INTERNAL METHODS
633    
634  =head2 _sort_by_order  =head2 _sort_by_order
635    
636  Sort xml tags data structure accoding to C<order=""> attribute.  Sort xml tags data structure accoding to C<order=""> attribute.
# Line 504  sub _sort_by_order { Line 650  sub _sort_by_order {
650    
651  =head2 _x  =head2 _x
652    
653  Convert strings from C<conf/normalize> encoding into application specific  Convert strings from C<conf/normalize/*.xml> encoding into application
654  (optinally specified using C<code_page> to C<new> constructor.  specific encoding (optinally specified using C<code_page> to C<new>
655    constructor).
656    
657   my $text = $n->_x('normalize text string');   my $text = $n->_x('normalize text string');
658    
# Line 532  under the same terms as Perl itself. Line 679  under the same terms as Perl itself.
679    
680  =cut  =cut
681    
682  1; # End of WebPAC::DB  1; # End of WebPAC::Normalize

Legend:
Removed from v.14  
changed lines
  Added in v.252

  ViewVC Help
Powered by ViewVC 1.1.26