/[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 13 by dpavlin, Sat Jul 16 23:56:14 2005 UTC revision 38 by dpavlin, Sat Nov 12 21:21:50 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;
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    
# Line 18  our $VERSION = '0.01'; Line 19  our $VERSION = '0.01';
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 28  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    );    );
86    
87  Optional parameter C<cache_data_structure> defines path to directory  Parametar C<filter> defines user supplied snippets of perl code which can
88  in which cache file for C<data_structure> call will be created.  be use with C<filter{...}> notation.
89    
90  Recommended parametar C<lookup_regex> is used to enable parsing of lookups  Recommended parametar C<lookup_regex> is used to enable parsing of lookups
91  in structures.  in structures. If you pass this parametar, you must also pass C<lookup>
92    which is C<WebPAC::Lookup> object.
93    
94  =cut  =cut
95    
# Line 45  sub new { Line 98  sub new {
98          my $self = {@_};          my $self = {@_};
99          bless($self, $class);          bless($self, $class);
100    
101          $self->setup_cache_dir( $self->{'cache_data_structure'} );          my $r = $self->{'lookup_regex'} ? 1 : 0;
102            my $l = $self->{'lookup'} ? 1 : 0;
         $self ? return $self : return undef;  
 }  
   
 =head2 setup_cache_dir  
   
 Check if specified cache directory exist, and if not, disable caching.  
   
  $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;  
   
         my $dir = shift;  
103    
104          my $log = $self->_get_logger();          my $log = $self->_get_logger();
105    
106          if ($dir) {          # those two must be in pair
107                  my $msg;          if ( ($r & $l) != ($r || $l) ) {
108                  if (! -e $dir) {                  my $log = $self->_get_logger();
109                          $msg = "doesn't exist";                  $log->logdie("lookup_regex and lookup must be in pair");
                 } elsif (! -d $dir) {  
                         $msg = "is not directory";  
                 } elsif (! -w $dir) {  
                         $msg = "not writable";  
                 }  
   
                 if ($msg) {  
                         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'};  
110          }          }
111    
112            $log->logdie("lookup must be WebPAC::Lookup object") if ($self->{'lookup'} && ! $self->{'lookup'}->isa('WebPAC::Lookup'));
113    
114            $self ? return $self : return undef;
115  }  }
116    
117    
# Line 118  sub data_structure { Line 142  sub data_structure {
142    
143          my $cache_file;          my $cache_file;
144    
145          if (my $cache_path = $self->{'cache_data_structure'}) {          if ($self->{'db'}) {
146                  my $id = $rec->{'000'};                  my @ds = $self->{'db'}->load_ds($rec);
147                  $id = $rec->{'000'}->[0] if ($id =~ m/^ARRAY/o);                  $log->debug("load_ds( rec = ", sub { Dumper($rec) }, ") = ", sub { Dumper(@ds) });
148                  unless (defined($id)) {                  return @ds if ($#ds > 0);
149                          $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'};  
                                         }  
                                 }  
                         }  
                 }  
150          }          }
151    
152          undef $self->{'currnet_filename'};          undef $self->{'currnet_filename'};
# Line 171  sub data_structure { Line 171  sub data_structure {
171  #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'}});
172    
173                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
174                          my $format = $tag->{'value'} || $tag->{'content'};                          my $format;
175    
176                            $log->logdie("expected tag HASH and got $tag") unless (ref($tag) eq 'HASH');
177                            $format = $tag->{'value'} || $tag->{'content'};
178    
179                          $log->debug("format: $format");                          $log->debug("format: $format");
180    
# Line 254  sub data_structure { Line 257  sub data_structure {
257    
258          }          }
259    
260          if ($cache_file) {          $self->{'db'}->save_ds(
261                  store {                  ds => \@ds,
262                          ds => \@ds,                  current_filename => $self->{'current_filename'},
263                          current_filename => $self->{'current_filename'},                  headline => $self->{'headline'},
264                          headline => $self->{'headline'},          ) if ($self->{'db'});
                 }, $cache_file;  
                 $log->debug("created storable cache file $cache_file");  
         }  
265    
266          return @ds;          $log->debug("ds: ", sub { Dumper(@ds) });
267    
268  }          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'");  
   
         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;  
         }  
269    
270  }  }
271    
# Line 426  sub parse_to_arr { Line 388  sub parse_to_arr {
388          return @arr;          return @arr;
389  }  }
390    
391    
392    =head2 fill_in
393    
394    Workhourse of all: takes record from in-memory structure of database and
395    strings with placeholders and returns string or array of with substituted
396    values from record.
397    
398     my $text = $webpac->fill_in($rec,'v250^a');
399    
400    Optional argument is ordinal number for repeatable fields. By default,
401    it's assume to be first repeatable field (fields are perl array, so first
402    element is 0).
403    Following example will read second value from repeatable field.
404    
405     my $text = $webpac->fill_in($rec,'Title: v250^a',1);
406    
407    This function B<does not> perform parsing of format to inteligenty skip
408    delimiters before fields which aren't used.
409    
410    This method will automatically decode UTF-8 string to local code page
411    if needed.
412    
413    =cut
414    
415    sub fill_in {
416            my $self = shift;
417    
418            my $log = $self->_get_logger();
419    
420            my $rec = shift || $log->logconfess("need data record");
421            my $format = shift || $log->logconfess("need format to parse");
422            # iteration (for repeatable fields)
423            my $i = shift || 0;
424    
425            $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));
426    
427            # FIXME remove for speedup?
428            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
429    
430            if (utf8::is_utf8($format)) {
431                    $format = $self->_x($format);
432            }
433    
434            my $found = 0;
435    
436            my $eval_code;
437            # remove eval{...} from beginning
438            $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
439    
440            my $filter_name;
441            # remove filter{...} from beginning
442            $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
443    
444            # do actual replacement of placeholders
445            # repeatable fields
446            $format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;
447            # non-repeatable fields
448            $format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found)/ges;
449    
450            if ($found) {
451                    $log->debug("format: $format");
452                    if ($eval_code) {
453                            my $eval = $self->fill_in($rec,$eval_code,$i);
454                            return if (! $self->_eval($eval));
455                    }
456                    if ($filter_name && $self->{'filter'}->{$filter_name}) {
457                            $log->debug("filter '$filter_name' for $format");
458                            $format = $self->{'filter'}->{$filter_name}->($format);
459                            return unless(defined($format));
460                            $log->debug("filter result: $format");
461                    }
462                    # do we have lookups?
463                    if ($self->{'lookup'}) {
464                            if ($self->{'lookup'}->can('lookup')) {
465                                    return $self->{'lookup'}->lookup($format);
466                            } else {
467                                    $log->warn("Have lookup object but can't invoke lookup method");
468                            }
469                    } else {
470                            return $format;
471                    }
472            } else {
473                    return;
474            }
475    }
476    
477    
478  =head2 fill_in_to_arr  =head2 fill_in_to_arr
479    
480  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 458  sub fill_in_to_arr { Line 507  sub fill_in_to_arr {
507          return @arr;          return @arr;
508  }  }
509    
510    
511    =head2 get_data
512    
513    Returns value from record.
514    
515     my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);
516    
517    Arguments are:
518    record reference C<$rec>,
519    field C<$f>,
520    optional subfiled C<$sf>,
521    index for repeatable values C<$i>.
522    
523    Optinal variable C<$found> will be incremeted if there
524    is field.
525    
526    Returns value or empty string.
527    
528    =cut
529    
530    sub get_data {
531            my $self = shift;
532    
533            my ($rec,$f,$sf,$i,$found) = @_;
534    
535            if ($$rec->{$f}) {
536                    return '' if (! $$rec->{$f}->[$i]);
537                    no strict 'refs';
538                    if ($sf && $$rec->{$f}->[$i]->{$sf}) {
539                            $$found++ if (defined($$found));
540                            return $$rec->{$f}->[$i]->{$sf};
541                    } elsif ($$rec->{$f}->[$i]) {
542                            $$found++ if (defined($$found));
543                            # it still might have subfield, just
544                            # not specified, so we'll dump all
545                            if ($$rec->{$f}->[$i] =~ /HASH/o) {
546                                    my $out;
547                                    foreach my $k (keys %{$$rec->{$f}->[$i]}) {
548                                            $out .= $$rec->{$f}->[$i]->{$k}." ";
549                                    }
550                                    return $out;
551                            } else {
552                                    return $$rec->{$f}->[$i];
553                            }
554                    }
555            } else {
556                    return '';
557            }
558    }
559    
560    
561    =head2 apply_format
562    
563    Apply format specified in tag with C<format_name="name"> and
564    C<format_delimiter=";;">.
565    
566     my $text = $webpac->apply_format($format_name,$format_delimiter,$data);
567    
568    Formats can contain C<lookup{...}> if you need them.
569    
570    =cut
571    
572    sub apply_format {
573            my $self = shift;
574    
575            my ($name,$delimiter,$data) = @_;
576    
577            my $log = $self->_get_logger();
578    
579            if (! $self->{'import_xml'}->{'format'}->{$name}) {
580                    $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});
581                    return $data;
582            }
583    
584            $log->warn("no delimiter for format $name") if (! $delimiter);
585    
586            my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");
587    
588            my @data = split(/\Q$delimiter\E/, $data);
589    
590            my $out = sprintf($format, @data);
591            $log->debug("using format $name [$format] on $data to produce: $out");
592    
593            if ($self->{'lookup_regex'} && $out =~ $self->{'lookup_regex'}) {
594                    return $self->{'lookup'}->lookup($out);
595            } else {
596                    return $out;
597            }
598    
599    }
600    
601  =head2 sort_arr  =head2 sort_arr
602    
603  Sort array ignoring case and html in data  Sort array ignoring case and html in data
# Line 484  sub sort_arr { Line 624  sub sort_arr {
624  }  }
625    
626    
627    =head1 INTERNAL METHODS
628    
629  =head2 _sort_by_order  =head2 _sort_by_order
630    
631  Sort xml tags data structure accoding to C<order=""> attribute.  Sort xml tags data structure accoding to C<order=""> attribute.
# Line 503  sub _sort_by_order { Line 645  sub _sort_by_order {
645    
646  =head2 _x  =head2 _x
647    
648  Convert strings from C<conf/normalize> encoding into application specific  Convert strings from C<conf/normalize/*.xml> encoding into application
649  (optinally specified using C<code_page> to C<new> constructor.  specific encoding (optinally specified using C<code_page> to C<new>
650    constructor).
651    
652   my $text = $n->_x('normalize text string');   my $text = $n->_x('normalize text string');
653    

Legend:
Removed from v.13  
changed lines
  Added in v.38

  ViewVC Help
Powered by ViewVC 1.1.26