/[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 39 by dpavlin, Sat Nov 12 21:31:47 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) {          $log->logdie("there is no current_filename defined! Do you have filename tag in conf/normalize/?.xml") unless ($self->{'current_filename'});
                 store {  
                         ds => \@ds,  
                         current_filename => $self->{'current_filename'},  
                         headline => $self->{'headline'},  
                 }, $cache_file;  
                 $log->debug("created storable cache file $cache_file");  
         }  
261    
262          return @ds;          $self->{'db'}->save_ds(
263                    ds => \@ds,
264                    current_filename => $self->{'current_filename'},
265                    headline => $self->{'headline'},
266            ) if ($self->{'db'});
267    
268  }          $log->debug("ds: ", sub { Dumper(@ds) });
269    
270  =head2 apply_format          return @ds;
   
 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;  
         }  
271    
272  }  }
273    
# Line 426  sub parse_to_arr { Line 390  sub parse_to_arr {
390          return @arr;          return @arr;
391  }  }
392    
393    
394    =head2 fill_in
395    
396    Workhourse of all: takes record from in-memory structure of database and
397    strings with placeholders and returns string or array of with substituted
398    values from record.
399    
400     my $text = $webpac->fill_in($rec,'v250^a');
401    
402    Optional argument is ordinal number for repeatable fields. By default,
403    it's assume to be first repeatable field (fields are perl array, so first
404    element is 0).
405    Following example will read second value from repeatable field.
406    
407     my $text = $webpac->fill_in($rec,'Title: v250^a',1);
408    
409    This function B<does not> perform parsing of format to inteligenty skip
410    delimiters before fields which aren't used.
411    
412    This method will automatically decode UTF-8 string to local code page
413    if needed.
414    
415    =cut
416    
417    sub fill_in {
418            my $self = shift;
419    
420            my $log = $self->_get_logger();
421    
422            my $rec = shift || $log->logconfess("need data record");
423            my $format = shift || $log->logconfess("need format to parse");
424            # iteration (for repeatable fields)
425            my $i = shift || 0;
426    
427            $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));
428    
429            # FIXME remove for speedup?
430            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
431    
432            if (utf8::is_utf8($format)) {
433                    $format = $self->_x($format);
434            }
435    
436            my $found = 0;
437    
438            my $eval_code;
439            # remove eval{...} from beginning
440            $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
441    
442            my $filter_name;
443            # remove filter{...} from beginning
444            $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
445    
446            # do actual replacement of placeholders
447            # repeatable fields
448            $format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;
449            # non-repeatable fields
450            $format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found)/ges;
451    
452            if ($found) {
453                    $log->debug("format: $format");
454                    if ($eval_code) {
455                            my $eval = $self->fill_in($rec,$eval_code,$i);
456                            return if (! $self->_eval($eval));
457                    }
458                    if ($filter_name && $self->{'filter'}->{$filter_name}) {
459                            $log->debug("filter '$filter_name' for $format");
460                            $format = $self->{'filter'}->{$filter_name}->($format);
461                            return unless(defined($format));
462                            $log->debug("filter result: $format");
463                    }
464                    # do we have lookups?
465                    if ($self->{'lookup'}) {
466                            if ($self->{'lookup'}->can('lookup')) {
467                                    return $self->{'lookup'}->lookup($format);
468                            } else {
469                                    $log->warn("Have lookup object but can't invoke lookup method");
470                            }
471                    } else {
472                            return $format;
473                    }
474            } else {
475                    return;
476            }
477    }
478    
479    
480  =head2 fill_in_to_arr  =head2 fill_in_to_arr
481    
482  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 509  sub fill_in_to_arr {
509          return @arr;          return @arr;
510  }  }
511    
512    
513    =head2 get_data
514    
515    Returns value from record.
516    
517     my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);
518    
519    Arguments are:
520    record reference C<$rec>,
521    field C<$f>,
522    optional subfiled C<$sf>,
523    index for repeatable values C<$i>.
524    
525    Optinal variable C<$found> will be incremeted if there
526    is field.
527    
528    Returns value or empty string.
529    
530    =cut
531    
532    sub get_data {
533            my $self = shift;
534    
535            my ($rec,$f,$sf,$i,$found) = @_;
536    
537            if ($$rec->{$f}) {
538                    return '' if (! $$rec->{$f}->[$i]);
539                    no strict 'refs';
540                    if ($sf && $$rec->{$f}->[$i]->{$sf}) {
541                            $$found++ if (defined($$found));
542                            return $$rec->{$f}->[$i]->{$sf};
543                    } elsif ($$rec->{$f}->[$i]) {
544                            $$found++ if (defined($$found));
545                            # it still might have subfield, just
546                            # not specified, so we'll dump all
547                            if ($$rec->{$f}->[$i] =~ /HASH/o) {
548                                    my $out;
549                                    foreach my $k (keys %{$$rec->{$f}->[$i]}) {
550                                            $out .= $$rec->{$f}->[$i]->{$k}." ";
551                                    }
552                                    return $out;
553                            } else {
554                                    return $$rec->{$f}->[$i];
555                            }
556                    }
557            } else {
558                    return '';
559            }
560    }
561    
562    
563    =head2 apply_format
564    
565    Apply format specified in tag with C<format_name="name"> and
566    C<format_delimiter=";;">.
567    
568     my $text = $webpac->apply_format($format_name,$format_delimiter,$data);
569    
570    Formats can contain C<lookup{...}> if you need them.
571    
572    =cut
573    
574    sub apply_format {
575            my $self = shift;
576    
577            my ($name,$delimiter,$data) = @_;
578    
579            my $log = $self->_get_logger();
580    
581            if (! $self->{'import_xml'}->{'format'}->{$name}) {
582                    $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});
583                    return $data;
584            }
585    
586            $log->warn("no delimiter for format $name") if (! $delimiter);
587    
588            my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");
589    
590            my @data = split(/\Q$delimiter\E/, $data);
591    
592            my $out = sprintf($format, @data);
593            $log->debug("using format $name [$format] on $data to produce: $out");
594    
595            if ($self->{'lookup_regex'} && $out =~ $self->{'lookup_regex'}) {
596                    return $self->{'lookup'}->lookup($out);
597            } else {
598                    return $out;
599            }
600    
601    }
602    
603  =head2 sort_arr  =head2 sort_arr
604    
605  Sort array ignoring case and html in data  Sort array ignoring case and html in data
# Line 484  sub sort_arr { Line 626  sub sort_arr {
626  }  }
627    
628    
629    =head1 INTERNAL METHODS
630    
631  =head2 _sort_by_order  =head2 _sort_by_order
632    
633  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 647  sub _sort_by_order {
647    
648  =head2 _x  =head2 _x
649    
650  Convert strings from C<conf/normalize> encoding into application specific  Convert strings from C<conf/normalize/*.xml> encoding into application
651  (optinally specified using C<code_page> to C<new> constructor.  specific encoding (optinally specified using C<code_page> to C<new>
652    constructor).
653    
654   my $text = $n->_x('normalize text string');   my $text = $n->_x('normalize text string');
655    

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

  ViewVC Help
Powered by ViewVC 1.1.26