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

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

  ViewVC Help
Powered by ViewVC 1.1.26