/[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 219 by dpavlin, Mon Dec 5 17:48:08 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  
   
 sub setup_cache_dir {  
         my $self = shift;  
109    
110          my $dir = shift;          # those two must be in pair
111            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 $log = $self->_get_logger();          $log->logdie("lookup must be WebPAC::Lookup object") if ($self->{'lookup'} && ! $self->{'lookup'}->isa('WebPAC::Lookup'));
117    
118          if ($dir) {          $log->warn("no prefix defined. please check that!") unless ($self->{'prefix'});
                 my $msg;  
                 if (! -e $dir) {  
                         $msg = "doesn't exist";  
                 } elsif (! -d $dir) {  
                         $msg = "is not directory";  
                 } elsif (! -w $dir) {  
                         $msg = "not writable";  
                 }  
119    
120                  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'};  
         }  
121  }  }
122    
123    
# Line 99  C<conf/normalize/*.xml>. Line 128  C<conf/normalize/*.xml>.
128    
129  This structures are used to produce output.  This structures are used to produce output.
130    
131   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.  
132    
133  =cut  =cut
134    
# Line 117  sub data_structure { Line 140  sub data_structure {
140          my $rec = shift;          my $rec = shift;
141          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
142    
143            $log->debug("data_structure rec = ", sub { Dumper($rec) });
144    
145            $log->logdie("need unique ID (mfn) in field 000 of record ", sub { Dumper($rec) } ) unless (defined($rec->{'000'}));
146    
147            my $id = $rec->{'000'}->[0] || $log->logdie("field 000 isn't array!");
148    
149          my $cache_file;          my $cache_file;
150    
151          if (my $cache_path = $self->{'cache_data_structure'}) {          if ($self->{'db'}) {
152                  my $id = $rec->{'000'};                  my $ds = $self->{'db'}->load_ds( id => $id, prefix => $self->{prefix} );
153                  $id = $rec->{'000'}->[0] if ($id =~ m/^ARRAY/o);                  $log->debug("load_ds( rec = ", sub { Dumper($rec) }, ") = ", sub { Dumper($ds) });
154                  unless (defined($id)) {                  return $ds if ($ds);
155                          $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'};  
                                         }  
                                 }  
                         }  
                 }  
156          }          }
157    
158          undef $self->{'currnet_filename'};          undef $self->{'currnet_filename'};
# Line 161  sub data_structure { Line 166  sub data_structure {
166                  $self->{tags_by_order} = \@sorted_tags;                  $self->{tags_by_order} = \@sorted_tags;
167          }          }
168    
169          my @ds;          my $ds;
170    
171          $log->debug("tags: ",sub { join(", ",@sorted_tags) });          $log->debug("tags: ",sub { join(", ",@sorted_tags) });
172    
# Line 172  sub data_structure { Line 177  sub data_structure {
177  #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'}});
178    
179                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
180                          my $format = $tag->{'value'} || $tag->{'content'};                          my $format;
181    
182                            $log->logdie("expected tag HASH and got $tag") unless (ref($tag) eq 'HASH');
183                            $format = $tag->{'value'} || $tag->{'content'};
184    
185                          $log->debug("format: $format");                          $log->debug("format: $format");
186    
# Line 193  sub data_structure { Line 201  sub data_structure {
201                                  @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;                                  @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
202                          }                          }
203    
                         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!  
                         }  
   
204                          # delimiter will join repeatable fields                          # delimiter will join repeatable fields
205                          if ($tag->{'delimiter'}) {                          if ($tag->{'delimiter'}) {
206                                  @v = ( join($tag->{'delimiter'}, @v) );                                  @v = ( join($tag->{'delimiter'}, @v) );
207                          }                          }
208    
209                          # default types                          # default types
210                          my @types = qw(display swish);                          my @types = qw(display search);
211                          # override by type attribute                          # override by type attribute
212                          @types = ( $tag->{'type'} ) if ($tag->{'type'});                          @types = ( $tag->{'type'} ) if ($tag->{'type'});
213    
# Line 241  sub data_structure { Line 240  sub data_structure {
240    
241                          # TODO: name_sigular, name_plural                          # TODO: name_sigular, name_plural
242                          my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};                          my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
243                          $row->{'name'} = $name ? $self->_x($name) : $field;                          my $row_name = $name ? $self->_x($name) : $field;
244    
245                          # post-sort all values in field                          # post-sort all values in field
246                          if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {                          if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {
247                                  $log->warn("sort at field tag not implemented");                                  $log->warn("sort at field tag not implemented");
248                          }                          }
249    
250                          push @ds, $row;                          $ds->{$row_name} = $row;
251    
252                          $log->debug("row $field: ",sub { Dumper($row) });                          $log->debug("row $field: ",sub { Dumper($row) });
253                  }                  }
254    
255          }          }
256    
257          if ($cache_file) {          $self->{'db'}->save_ds(
258                  store {                  id => $id,
259                          ds => \@ds,                  ds => $ds,
260                          current_filename => $self->{'current_filename'},                  prefix => $self->{prefix},
261                          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.  
   
 =cut  
   
 sub apply_format {  
         my $self = shift;  
   
         my ($name,$delimiter,$data) = @_;  
   
         my $log = $self->_get_logger();  
   
         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'");  
262    
263          my @data = split(/\Q$delimiter\E/, $data);          $log->debug("ds: ", sub { Dumper($ds) });
264    
265          my $out = sprintf($format, @data);          $log->logconfess("data structure returned is not array any more!") if wantarray;
         $log->debug("using format $name [$format] on $data to produce: $out");  
266    
267          if ($self->{'lookup_regex'} && $out =~ $self->{'lookup_regex'}) {          return $ds;
                 return $self->lookup($out);  
         } else {  
                 return $out;  
         }  
268    
269  }  }
270    
# Line 427  sub parse_to_arr { Line 387  sub parse_to_arr {
387          return @arr;          return @arr;
388  }  }
389    
390    
391    =head2 fill_in
392    
393    Workhourse of all: takes record from in-memory structure of database and
394    strings with placeholders and returns string or array of with substituted
395    values from record.
396    
397     my $text = $webpac->fill_in($rec,'v250^a');
398    
399    Optional argument is ordinal number for repeatable fields. By default,
400    it's assume to be first repeatable field (fields are perl array, so first
401    element is 0).
402    Following example will read second value from repeatable field.
403    
404     my $text = $webpac->fill_in($rec,'Title: v250^a',1);
405    
406    This function B<does not> perform parsing of format to inteligenty skip
407    delimiters before fields which aren't used.
408    
409    This method will automatically decode UTF-8 string to local code page
410    if needed.
411    
412    =cut
413    
414    sub fill_in {
415            my $self = shift;
416    
417            my $log = $self->_get_logger();
418    
419            my $rec = shift || $log->logconfess("need data record");
420            my $format = shift || $log->logconfess("need format to parse");
421            # iteration (for repeatable fields)
422            my $i = shift || 0;
423    
424            $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));
425    
426            # FIXME remove for speedup?
427            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
428    
429            if (utf8::is_utf8($format)) {
430                    $format = $self->_x($format);
431            }
432    
433            my $found = 0;
434    
435            my $eval_code;
436            # remove eval{...} from beginning
437            $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
438    
439            my $filter_name;
440            # remove filter{...} from beginning
441            $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
442    
443            # do actual replacement of placeholders
444            # repeatable fields
445            $format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;
446            # non-repeatable fields
447            $format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found)/ges;
448    
449            if ($found) {
450                    $log->debug("format: $format");
451                    if ($eval_code) {
452                            my $eval = $self->fill_in($rec,$eval_code,$i);
453                            return if (! $self->_eval($eval));
454                    }
455                    if ($filter_name && $self->{'filter'}->{$filter_name}) {
456                            $log->debug("filter '$filter_name' for $format");
457                            $format = $self->{'filter'}->{$filter_name}->($format);
458                            return unless(defined($format));
459                            $log->debug("filter result: $format");
460                    }
461                    # do we have lookups?
462                    if ($self->{'lookup'}) {
463                            if ($self->{'lookup'}->can('lookup')) {
464                                    return $self->{'lookup'}->lookup($format);
465                            } else {
466                                    $log->warn("Have lookup object but can't invoke lookup method");
467                            }
468                    } else {
469                            return $format;
470                    }
471            } else {
472                    return;
473            }
474    }
475    
476    
477  =head2 fill_in_to_arr  =head2 fill_in_to_arr
478    
479  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 506  sub fill_in_to_arr {
506          return @arr;          return @arr;
507  }  }
508    
509    
510    =head2 get_data
511    
512    Returns value from record.
513    
514     my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);
515    
516    Arguments are:
517    record reference C<$rec>,
518    field C<$f>,
519    optional subfiled C<$sf>,
520    index for repeatable values C<$i>.
521    
522    Optinal variable C<$found> will be incremeted if there
523    is field.
524    
525    Returns value or empty string.
526    
527    =cut
528    
529    sub get_data {
530            my $self = shift;
531    
532            my ($rec,$f,$sf,$i,$found) = @_;
533    
534            if ($$rec->{$f}) {
535                    return '' if (! $$rec->{$f}->[$i]);
536                    no strict 'refs';
537                    if ($sf && $$rec->{$f}->[$i]->{$sf}) {
538                            $$found++ if (defined($$found));
539                            return $$rec->{$f}->[$i]->{$sf};
540                    } elsif (! $sf && $$rec->{$f}->[$i]) {
541                            $$found++ if (defined($$found));
542                            # it still might have subfield, just
543                            # not specified, so we'll dump all
544                            if ($$rec->{$f}->[$i] =~ /HASH/o) {
545                                    my $out;
546                                    foreach my $k (keys %{$$rec->{$f}->[$i]}) {
547                                            $out .= $$rec->{$f}->[$i]->{$k}." ";
548                                    }
549                                    return $out;
550                            } else {
551                                    return $$rec->{$f}->[$i];
552                            }
553                    } else {
554                            return '';
555                    }
556            } else {
557                    return '';
558            }
559    }
560    
561    
562    =head2 apply_format
563    
564    Apply format specified in tag with C<format_name="name"> and
565    C<format_delimiter=";;">.
566    
567     my $text = $webpac->apply_format($format_name,$format_delimiter,$data);
568    
569    Formats can contain C<lookup{...}> if you need them.
570    
571    =cut
572    
573    sub apply_format {
574            my $self = shift;
575    
576            my ($name,$delimiter,$data) = @_;
577    
578            my $log = $self->_get_logger();
579    
580            if (! $self->{'import_xml'}->{'format'}->{$name}) {
581                    $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});
582                    return $data;
583            }
584    
585            $log->warn("no delimiter for format $name") if (! $delimiter);
586    
587            my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");
588    
589            my @data = split(/\Q$delimiter\E/, $data);
590    
591            my $out = sprintf($format, @data);
592            $log->debug("using format $name [$format] on $data to produce: $out");
593    
594            if ($self->{'lookup_regex'} && $out =~ $self->{'lookup_regex'}) {
595                    return $self->{'lookup'}->lookup($out);
596            } else {
597                    return $out;
598            }
599    
600    }
601    
602  =head2 sort_arr  =head2 sort_arr
603    
604  Sort array ignoring case and html in data  Sort array ignoring case and html in data
# Line 485  sub sort_arr { Line 625  sub sort_arr {
625  }  }
626    
627    
628    =head1 INTERNAL METHODS
629    
630  =head2 _sort_by_order  =head2 _sort_by_order
631    
632  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 646  sub _sort_by_order {
646    
647  =head2 _x  =head2 _x
648    
649  Convert strings from C<conf/normalize> encoding into application specific  Convert strings from C<conf/normalize/*.xml> encoding into application
650  (optinally specified using C<code_page> to C<new> constructor.  specific encoding (optinally specified using C<code_page> to C<new>
651    constructor).
652    
653   my $text = $n->_x('normalize text string');   my $text = $n->_x('normalize text string');
654    
# Line 532  under the same terms as Perl itself. Line 675  under the same terms as Perl itself.
675    
676  =cut  =cut
677    
678  1; # End of WebPAC::DB  1; # End of WebPAC::Normalize

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

  ViewVC Help
Powered by ViewVC 1.1.26