/[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 29 by dpavlin, Sun Jul 24 11:17:44 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    
# Line 19  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 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    );    );
85    
86  Optional parameter C<cache_data_structure> defines path to directory  Parametar C<filter> defines user supplied snippets of perl code which can
87  in which cache file for C<data_structure> call will be created.  be use with C<filter{...}> notation.
88    
89  Recommended parametar C<lookup_regex> is used to enable parsing of lookups  Recommended parametar C<lookup_regex> is used to enable parsing of lookups
90  in structures.  in structures.
# Line 46  sub new { Line 96  sub new {
96          my $self = {@_};          my $self = {@_};
97          bless($self, $class);          bless($self, $class);
98    
         $self->setup_cache_dir( $self->{'cache_data_structure'} );  
   
99          $self ? return $self : return undef;          $self ? return $self : return undef;
100  }  }
101    
 =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;  
   
         my $log = $self->_get_logger();  
   
         if ($dir) {  
                 my $msg;  
                 if (! -e $dir) {  
                         $msg = "doesn't exist";  
                 } 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'};  
         }  
 }  
   
102    
103  =head2 data_structure  =head2 data_structure
104    
# Line 119  sub data_structure { Line 127  sub data_structure {
127    
128          my $cache_file;          my $cache_file;
129    
130          if (my $cache_path = $self->{'cache_data_structure'}) {          if ($self->{'db'}) {
131                  my $id = $rec->{'000'};                  my @ds = $self->{'db'}->load_ds($rec);
132                  $id = $rec->{'000'}->[0] if ($id =~ m/^ARRAY/o);                  $log->debug("load_ds( rec = ", sub { Dumper($rec) }, ") = ", sub { Dumper(@ds) });
133                  unless (defined($id)) {                  return @ds if ($#ds > 0);
134                          $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'};  
                                         }  
                                 }  
                         }  
                 }  
135          }          }
136    
137          undef $self->{'currnet_filename'};          undef $self->{'currnet_filename'};
# Line 255  sub data_structure { Line 239  sub data_structure {
239    
240          }          }
241    
242          if ($cache_file) {          $self->{'db'}->save_ds(
243                  store {                  ds => \@ds,
244                          ds => \@ds,                  current_filename => $self->{'current_filename'},
245                          current_filename => $self->{'current_filename'},                  headline => $self->{'headline'},
246                          headline => $self->{'headline'},          ) if ($self->{'db'});
                 }, $cache_file;  
                 $log->debug("created storable cache file $cache_file");  
         }  
247    
248          return @ds;          $log->debug("ds: ", sub { Dumper(@ds) });
   
 }  
249    
250  =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;  
         }  
251    
252  }  }
253    
# Line 427  sub parse_to_arr { Line 370  sub parse_to_arr {
370          return @arr;          return @arr;
371  }  }
372    
373    
374    =head2 fill_in
375    
376    Workhourse of all: takes record from in-memory structure of database and
377    strings with placeholders and returns string or array of with substituted
378    values from record.
379    
380     my $text = $webpac->fill_in($rec,'v250^a');
381    
382    Optional argument is ordinal number for repeatable fields. By default,
383    it's assume to be first repeatable field (fields are perl array, so first
384    element is 0).
385    Following example will read second value from repeatable field.
386    
387     my $text = $webpac->fill_in($rec,'Title: v250^a',1);
388    
389    This function B<does not> perform parsing of format to inteligenty skip
390    delimiters before fields which aren't used.
391    
392    This method will automatically decode UTF-8 string to local code page
393    if needed.
394    
395    =cut
396    
397    sub fill_in {
398            my $self = shift;
399    
400            my $log = $self->_get_logger();
401    
402            my $rec = shift || $log->logconfess("need data record");
403            my $format = shift || $log->logconfess("need format to parse");
404            # iteration (for repeatable fields)
405            my $i = shift || 0;
406    
407            $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));
408    
409            # FIXME remove for speedup?
410            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
411    
412            if (utf8::is_utf8($format)) {
413                    $format = $self->_x($format);
414            }
415    
416            my $found = 0;
417    
418            my $eval_code;
419            # remove eval{...} from beginning
420            $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
421    
422            my $filter_name;
423            # remove filter{...} from beginning
424            $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
425    
426            # do actual replacement of placeholders
427            # repeatable fields
428            $format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;
429            # non-repeatable fields
430            $format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found)/ges;
431    
432            if ($found) {
433                    $log->debug("format: $format");
434                    if ($eval_code) {
435                            my $eval = $self->fill_in($rec,$eval_code,$i);
436                            return if (! $self->_eval($eval));
437                    }
438                    if ($filter_name && $self->{'filter'}->{$filter_name}) {
439                            $log->debug("filter '$filter_name' for $format");
440                            $format = $self->{'filter'}->{$filter_name}->($format);
441                            return unless(defined($format));
442                            $log->debug("filter result: $format");
443                    }
444                    # do we have lookups?
445                    if ($self->{'lookup'}) {
446                            return $self->lookup($format);
447                    } else {
448                            return $format;
449                    }
450            } else {
451                    return;
452            }
453    }
454    
455    
456  =head2 fill_in_to_arr  =head2 fill_in_to_arr
457    
458  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 485  sub fill_in_to_arr {
485          return @arr;          return @arr;
486  }  }
487    
488    
489    =head2 get_data
490    
491    Returns value from record.
492    
493     my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);
494    
495    Arguments are:
496    record reference C<$rec>,
497    field C<$f>,
498    optional subfiled C<$sf>,
499    index for repeatable values C<$i>.
500    
501    Optinal variable C<$found> will be incremeted if there
502    is field.
503    
504    Returns value or empty string.
505    
506    =cut
507    
508    sub get_data {
509            my $self = shift;
510    
511            my ($rec,$f,$sf,$i,$found) = @_;
512    
513            if ($$rec->{$f}) {
514                    return '' if (! $$rec->{$f}->[$i]);
515                    no strict 'refs';
516                    if ($sf && $$rec->{$f}->[$i]->{$sf}) {
517                            $$found++ if (defined($$found));
518                            return $$rec->{$f}->[$i]->{$sf};
519                    } elsif ($$rec->{$f}->[$i]) {
520                            $$found++ if (defined($$found));
521                            # it still might have subfield, just
522                            # not specified, so we'll dump all
523                            if ($$rec->{$f}->[$i] =~ /HASH/o) {
524                                    my $out;
525                                    foreach my $k (keys %{$$rec->{$f}->[$i]}) {
526                                            $out .= $$rec->{$f}->[$i]->{$k}." ";
527                                    }
528                                    return $out;
529                            } else {
530                                    return $$rec->{$f}->[$i];
531                            }
532                    }
533            } else {
534                    return '';
535            }
536    }
537    
538    
539    =head2 apply_format
540    
541    Apply format specified in tag with C<format_name="name"> and
542    C<format_delimiter=";;">.
543    
544     my $text = $webpac->apply_format($format_name,$format_delimiter,$data);
545    
546    Formats can contain C<lookup{...}> if you need them.
547    
548    =cut
549    
550    sub apply_format {
551            my $self = shift;
552    
553            my ($name,$delimiter,$data) = @_;
554    
555            my $log = $self->_get_logger();
556    
557            if (! $self->{'import_xml'}->{'format'}->{$name}) {
558                    $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});
559                    return $data;
560            }
561    
562            $log->warn("no delimiter for format $name") if (! $delimiter);
563    
564            my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");
565    
566            my @data = split(/\Q$delimiter\E/, $data);
567    
568            my $out = sprintf($format, @data);
569            $log->debug("using format $name [$format] on $data to produce: $out");
570    
571            if ($self->{'lookup_regex'} && $out =~ $self->{'lookup_regex'}) {
572                    return $self->lookup($out);
573            } else {
574                    return $out;
575            }
576    
577    }
578    
579  =head2 sort_arr  =head2 sort_arr
580    
581  Sort array ignoring case and html in data  Sort array ignoring case and html in data
# Line 485  sub sort_arr { Line 602  sub sort_arr {
602  }  }
603    
604    
605    =head1 INTERNAL METHODS
606    
607  =head2 _sort_by_order  =head2 _sort_by_order
608    
609  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 623  sub _sort_by_order {
623    
624  =head2 _x  =head2 _x
625    
626  Convert strings from C<conf/normalize> encoding into application specific  Convert strings from C<conf/normalize/*.xml> encoding into application
627  (optinally specified using C<code_page> to C<new> constructor.  specific encoding (optinally specified using C<code_page> to C<new>
628    constructor).
629    
630   my $text = $n->_x('normalize text string');   my $text = $n->_x('normalize text string');
631    

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

  ViewVC Help
Powered by ViewVC 1.1.26