/[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 536 by dpavlin, Mon Jun 26 16:39:51 2006 UTC
# Line 1  Line 1 
1  package WebPAC::Normalize;  package WebPAC::Normalize;
2    use Exporter 'import';
3    @EXPORT = qw/
4            set_rec set_lookup
5            get_ds clean_ds
6            tag search display
7            rec1 rec2 rec
8            regex prefix suffix surround
9            first lookup join_with
10    /;
11    
12  use warnings;  use warnings;
13  use strict;  use strict;
14    
15    #use base qw/WebPAC::Common/;
16  use Data::Dumper;  use Data::Dumper;
 use Storable;  
17    
18  =head1 NAME  =head1 NAME
19    
20  WebPAC::Normalize - normalisation of source file  WebPAC::Normalize - describe normalisaton rules using sets
21    
22  =head1 VERSION  =head1 VERSION
23    
24  Version 0.01  Version 0.04
25    
26  =cut  =cut
27    
28  our $VERSION = '0.01';  our $VERSION = '0.04';
29    
30  =head1 SYNOPSIS  =head1 SYNOPSIS
31    
32  This package contains code that could be helpful in implementing different  This module uses C<conf/normalize/*.pl> files to perform normalisation
33  normalisation front-ends.  from input records using perl functions which are specialized for set
34    processing.
35    
36    Sets are implemented as arrays, and normalisation file is valid perl, which
37    means that you check it's validity before running WebPAC using
38    C<perl -c normalize.pl>.
39    
40    Normalisation can generate multiple output normalized data. For now, supported output
41    types (on the left side of definition) are: C<tag>, C<display> and C<search>.
42    
43  =head1 FUNCTIONS  =head1 FUNCTIONS
44    
45  =head2 new  =head2 data_structure
46    
47  Create new normalisation object  Return data structure
48    
49    my $n = new WebPAC::Normalize::Something(    my $ds = WebPAC::Normalize(
50          cache_data_structure => './cache/ds/',          lookup => $lookup->lookup_hash,
51          lookup_regex => $lookup->regex,          row => $row,
52            rules => $normalize_pl_config,
53    );    );
54    
55  Optional parameter C<cache_data_structure> defines path to directory  This function will B<die> if normalizastion can't be evaled.
 in which cache file for C<data_structure> call will be created.  
   
 Recommended parametar C<lookup_regex> is used to enable parsing of lookups  
 in structures.  
56    
57  =cut  =cut
58    
59  sub new {  sub data_structure {
60          my $class = shift;          my $arg = {@_};
         my $self = {@_};  
         bless($self, $class);  
61    
62          $self->setup_cache_dir( $self->{'cache_data_structure'} );          die "need row argument" unless ($arg->{row});
63            die "need normalisation argument" unless ($arg->{rules});
64    
65          $self ? return $self : return undef;          no strict 'subs';
66            set_lookup( $arg->{lookup} );
67            set_rec( $arg->{row} );
68            clean_ds();
69            eval "$arg->{rules}";
70            die "error evaling $arg->{rules}: $@\n" if ($@);
71            return get_ds();
72  }  }
73    
74  =head2 setup_cache_dir  =head2 set_rec
   
 Check if specified cache directory exist, and if not, disable caching.  
75    
76   $setup_cache_dir('./cache/ds/');  Set current record hash
77    
78  If you pass false or zero value to this function, it will disable    set_rec( $rec );
 cacheing.  
79    
80  =cut  =cut
81    
82  sub setup_cache_dir {  my $rec;
         my $self = shift;  
   
         my $dir = shift;  
83    
84          my $log = $self->_get_logger();  sub set_rec {
85            $rec = shift or die "no record hash";
         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'};  
         }  
86  }  }
87    
88    =head2 tag
89    
90  =head2 data_structure  Define new tag for I<search> and I<display>.
   
 Create in-memory data structure which represents normalized layout from  
 C<conf/normalize/*.xml>.  
   
 This structures are used to produce output.  
91    
92   my @ds = $webpac->data_structure($rec);    tag('Title', rec('200','a') );
93    
 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.  
94    
95  =cut  =cut
96    
97  sub data_structure {  my $out;
         my $self = shift;  
   
         my $log = $self->_get_logger();  
   
         my $rec = shift;  
         $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);  
   
         my $cache_file;  
   
         if (my $cache_path = $self->{'cache_data_structure'}) {  
                 my $id = $rec->{'000'};  
                 $id = $rec->{'000'}->[0] if ($id =~ m/^ARRAY/o);  
                 unless (defined($id)) {  
                         $log->warn("Can't use cache_data_structure on records without unique identifier in field 000");  
                         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'};  
                                         }  
                                 }  
                         }  
                 }  
         }  
   
         undef $self->{'currnet_filename'};  
         undef $self->{'headline'};  
   
         my @sorted_tags;  
         if ($self->{tags_by_order}) {  
                 @sorted_tags = @{$self->{tags_by_order}};  
         } else {  
                 @sorted_tags = sort { $self->_sort_by_order } keys %{$self->{'import_xml'}->{'indexer'}};  
                 $self->{tags_by_order} = \@sorted_tags;  
         }  
   
         my @ds;  
98    
99          $log->debug("tags: ",sub { join(", ",@sorted_tags) });  sub tag {
100            my $name = shift or die "tag needs name as first argument";
101          foreach my $field (@sorted_tags) {          my @o = grep { defined($_) && $_ ne '' } @_;
102            return unless (@o);
103            $out->{$name}->{tag} = $name;
104            $out->{$name}->{search} = \@o;
105            $out->{$name}->{display} = \@o;
106    }
107    
108                  my $row;  =head2 display
109    
110  #print "field $field [",$self->{'tag'},"] = ",Dumper($self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}});  Define tag just for I<display>
111    
112                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {    @v = display('Title', rec('200','a') );
                         my $format = $tag->{'value'} || $tag->{'content'};  
113    
114                          $log->debug("format: $format");  =cut
115    
116                          my @v;  sub display {
117                          if ($self->{'lookup_regex'} && $format =~ $self->{'lookup_regex'}) {          my $name = shift or die "display needs name as first argument";
118                                  @v = $self->fill_in_to_arr($rec,$format);          my @o = grep { defined($_) && $_ ne '' } @_;
119                          } else {          return unless (@o);
120                                  @v = $self->parse_to_arr($rec,$format);          $out->{$name}->{tag} = $name;
121                          }          $out->{$name}->{display} = \@o;
122                          next if (! @v);  }
123    
124                          if ($tag->{'sort'}) {  =head2 search
                                 @v = $self->sort_arr(@v);  
                         }  
125    
126                          # use format?  Prepare values just for I<search>
                         if ($tag->{'format_name'}) {  
                                 @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;  
                         }  
127    
128                          if ($field eq 'filename') {    @v = search('Title', rec('200','a') );
                                 $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!  
                         }  
129    
130                          # delimiter will join repeatable fields  =cut
                         if ($tag->{'delimiter'}) {  
                                 @v = ( join($tag->{'delimiter'}, @v) );  
                         }  
131    
132                          # default types  sub search {
133                          my @types = qw(display swish);          my $name = shift or die "search needs name as first argument";
134                          # override by type attribute          my @o = grep { defined($_) && $_ ne '' } @_;
135                          @types = ( $tag->{'type'} ) if ($tag->{'type'});          return unless (@o);
136            $out->{$name}->{tag} = $name;
137                          foreach my $type (@types) {          $out->{$name}->{search} = \@o;
138                                  # append to previous line?  }
                                 $log->debug("type: $type ",sub { join(" ",@v) }, $row->{'append'} || 'no append');  
                                 if ($tag->{'append'}) {  
   
                                         # I will delimit appended part with  
                                         # delimiter (or ,)  
                                         my $d = $tag->{'delimiter'};  
                                         # default delimiter  
                                         $d ||= " ";  
   
                                         my $last = pop @{$row->{$type}};  
                                         $d = "" if (! $last);  
                                         $last .= $d . join($d, @v);  
                                         push @{$row->{$type}}, $last;  
   
                                 } else {  
                                         push @{$row->{$type}}, @v;  
                                 }  
                         }  
139    
140    =head2 get_ds
141    
142                  }  Return hash formatted as data structure
143    
144                  if ($row) {    my $ds = get_ds();
                         $row->{'tag'} = $field;  
145    
146                          # TODO: name_sigular, name_plural  =cut
                         my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};  
                         $row->{'name'} = $name ? $self->_x($name) : $field;  
   
                         # post-sort all values in field  
                         if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {  
                                 $log->warn("sort at field tag not implemented");  
                         }  
147    
148                          push @ds, $row;  sub get_ds {
149            return $out;
150    }
151    
152                          $log->debug("row $field: ",sub { Dumper($row) });  =head2 clean_ds
                 }  
153    
154          }  Clean data structure hash for next record
155    
156          if ($cache_file) {    clean_ds();
                 store {  
                         ds => \@ds,  
                         current_filename => $self->{'current_filename'},  
                         headline => $self->{'headline'},  
                 }, $cache_file;  
                 $log->debug("created storable cache file $cache_file");  
         }  
157    
158          return @ds;  =cut
159    
160    sub clean_ds {
161            $out = undef;
162  }  }
163    
164  =head2 apply_format  =head2 set_lookup
   
 Apply format specified in tag with C<format_name="name"> and  
 C<format_delimiter=";;">.  
165    
166   my $text = $webpac->apply_format($format_name,$format_delimiter,$data);  Set current lookup hash
167    
168  Formats can contain C<lookup{...}> if you need them.    set_lookup( $lookup );
169    
170  =cut  =cut
171    
172  sub apply_format {  my $lookup;
         my $self = shift;  
173    
174          my ($name,$delimiter,$data) = @_;  sub set_lookup {
175            $lookup = shift;
176          my $log = $self->_get_logger();  }
177    
178          if (! $self->{'import_xml'}->{'format'}->{$name}) {  =head2 rec1
                 $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});  
                 return $data;  
         }  
179    
180          $log->warn("no delimiter for format $name") if (! $delimiter);  Return all values in some field
181    
182          my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");    @v = rec1('200')
183    
184          my @data = split(/\Q$delimiter\E/, $data);  TODO: order of values is probably same as in source data, need to investigate that
185    
186          my $out = sprintf($format, @data);  =cut
         $log->debug("using format $name [$format] on $data to produce: $out");  
187    
188          if ($self->{'lookup_regex'} && $out =~ $self->{'lookup_regex'}) {  sub rec1 {
189                  return $self->lookup($out);          my $f = shift;
190          } else {          return unless (defined($rec) && defined($rec->{$f}));
191                  return $out;          if (ref($rec->{$f}) eq 'ARRAY') {
192                    return map {
193                            if (ref($_) eq 'HASH') {
194                                    values %{$_};
195                            } else {
196                                    $_;
197                            }
198                    } @{ $rec->{$f} };
199            } elsif( defined($rec->{$f}) ) {
200                    return $rec->{$f};
201          }          }
   
202  }  }
203    
204  =head2 parse  =head2 rec2
205    
206  Perform smart parsing of string, skipping delimiters for fields which aren't  Return all values in specific field and subfield
 defined. It can also eval code in format starting with C<eval{...}> and  
 return output or nothing depending on eval code.  
207    
208   my $text = $webpac->parse($rec,'eval{"v901^a" eq "Deskriptor"}descriptor: v250^a', $i);    @v = rec2('200','a')
209    
210  =cut  =cut
211    
212  sub parse {  sub rec2 {
213          my $self = shift;          my $f = shift;
214            return unless (defined($rec && $rec->{$f}));
215          my ($rec, $format_utf8, $i) = @_;          my $sf = shift;
216            return map { $_->{$sf} } grep { ref($_) eq 'HASH' && $_->{$sf} } @{ $rec->{$f} };
217          return if (! $format_utf8);  }
   
         my $log = $self->_get_logger();  
   
         $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);  
   
         $i = 0 if (! $i);  
   
         my $format = $self->_x($format_utf8) || $log->logconfess("can't convert '$format_utf8' from UTF-8 to ",$self->{'code_page'});  
   
         my @out;  
   
         $log->debug("format: $format");  
   
         my $eval_code;  
         # remove eval{...} from beginning  
         $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);  
   
         my $filter_name;  
         # remove filter{...} from beginning  
         $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);  
   
         my $prefix;  
         my $all_found=0;  
   
         while ($format =~ s/^(.*?)(v|s)(\d+)(?:\^(\w))?//s) {  
   
                 my $del = $1 || '';  
                 $prefix ||= $del if ($all_found == 0);  
   
                 # repeatable index  
                 my $r = $i;  
                 $r = 0 if (lc("$2") eq 's');  
   
                 my $found = 0;  
                 my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found);  
   
                 if ($found) {  
                         push @out, $del;  
                         push @out, $tmp;  
                         $all_found += $found;  
                 }  
         }  
   
         return if (! $all_found);  
218    
219          my $out = join('',@out);  =head2 rec
220    
221          if ($out) {  syntaxtic sugar for
                 # add rest of format (suffix)  
                 $out .= $format;  
222    
223                  # add prefix if not there    @v = rec('200')
224                  $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);    @v = rec('200','a')
225    
226                  $log->debug("result: $out");  =cut
         }  
227    
228          if ($eval_code) {  sub rec {
229                  my $eval = $self->fill_in($rec,$eval_code,$i) || return;          if ($#_ == 0) {
230                  $log->debug("about to eval{$eval} format: $out");                  return rec1(@_);
231                  return if (! $self->_eval($eval));          } elsif ($#_ == 1) {
232                    return rec2(@_);
233          }          }
           
         if ($filter_name && $self->{'filter'}->{$filter_name}) {  
                 $log->debug("about to filter{$filter_name} format: $out");  
                 $out = $self->{'filter'}->{$filter_name}->($out);  
                 return unless(defined($out));  
                 $log->debug("filter result: $out");  
         }  
   
         return $out;  
234  }  }
235    
236  =head2 parse_to_arr  =head2 regex
237    
238  Similar to C<parse>, but returns array of all repeatable fields  Apply regex to some or all values
239    
240   my @arr = $webpac->parse_to_arr($rec,'v250^a');    @v = regex( 's/foo/bar/g', @v );
241    
242  =cut  =cut
243    
244  sub parse_to_arr {  sub regex {
245          my $self = shift;          my $r = shift;
246            my @out;
247          my ($rec, $format_utf8) = @_;          #warn "r: $r\n",Dumper(\@_);
248            foreach my $t (@_) {
249          my $log = $self->_get_logger();                  next unless ($t);
250                    eval "\$t =~ $r";
251          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);                  push @out, $t if ($t && $t ne '');
         return if (! $format_utf8);  
   
         my $i = 0;  
         my @arr;  
   
         while (my $v = $self->parse($rec,$format_utf8,$i++)) {  
                 push @arr, $v;  
252          }          }
253            return @out;
         $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);  
   
         return @arr;  
254  }  }
255    
256  =head2 fill_in_to_arr  =head2 prefix
257    
258  Similar to C<fill_in>, but returns array of all repeatable fields. Usable  Prefix all values with a string
 for fields which have lookups, so they shouldn't be parsed but rather  
 C<fill_id>ed.  
259    
260   my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]');    @v = prefix( 'my_', @v );
261    
262  =cut  =cut
263    
264  sub fill_in_to_arr {  sub prefix {
265          my $self = shift;          my $p = shift or die "prefix needs string as first argument";
266            return map { $p . $_ } grep { defined($_) } @_;
267          my ($rec, $format_utf8) = @_;  }
268    
269          my $log = $self->_get_logger();  =head2 suffix
270    
271          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);  suffix all values with a string
         return if (! $format_utf8);  
272    
273          my $i = 0;    @v = suffix( '_my', @v );
         my @arr;  
274    
275          while (my @v = $self->fill_in($rec,$format_utf8,$i++)) {  =cut
                 push @arr, @v;  
         }  
   
         $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);  
276    
277          return @arr;  sub suffix {
278            my $s = shift or die "suffix needs string as first argument";
279            return map { $_ . $s } grep { defined($_) } @_;
280  }  }
281    
282  =head2 sort_arr  =head2 surround
283    
284  Sort array ignoring case and html in data  surround all values with a two strings
285    
286   my @sorted = $webpac->sort_arr(@unsorted);    @v = surround( 'prefix_', '_suffix', @v );
287    
288  =cut  =cut
289    
290  sub sort_arr {  sub surround {
291          my $self = shift;          my $p = shift or die "surround need prefix as first argument";
292            my $s = shift or die "surround needs suffix as second argument";
293          my $log = $self->_get_logger();          return map { $p . $_ . $s } grep { defined($_) } @_;
   
         # FIXME add Schwartzian Transformation?  
   
         my @sorted = sort {  
                 $a =~ s#<[^>]+/*>##;  
                 $b =~ s#<[^>]+/*>##;  
                 lc($b) cmp lc($a)  
         } @_;  
         $log->debug("sorted values: ",sub { join(", ",@sorted) });  
   
         return @sorted;  
294  }  }
295    
296    =head2 first
297    
298  =head2 _sort_by_order  Return first element
299    
300  Sort xml tags data structure accoding to C<order=""> attribute.    $v = first( @v );
301    
302  =cut  =cut
303    
304  sub _sort_by_order {  sub first {
305          my $self = shift;          my $r = shift;
306            return $r;
         my $va = $self->{'import_xml'}->{'indexer'}->{$a}->{'order'} ||  
                 $self->{'import_xml'}->{'indexer'}->{$a};  
         my $vb = $self->{'import_xml'}->{'indexer'}->{$b}->{'order'} ||  
                 $self->{'import_xml'}->{'indexer'}->{$b};  
   
         return $va <=> $vb;  
307  }  }
308    
309  =head2 _x  =head2 lookup
   
 Convert strings from C<conf/normalize> encoding into application specific  
 (optinally specified using C<code_page> to C<new> constructor.  
310    
311   my $text = $n->_x('normalize text string');  Consult lookup hashes for some value
312    
313  This is a stub so that other modules doesn't have to implement it.    @v = lookup( $v );
314      @v = lookup( @v );
315    
316  =cut  =cut
317    
318  sub _x {  sub lookup {
319          my $self = shift;          my $k = shift or return;
320          return shift;          return unless (defined($lookup->{$k}));
321            if (ref($lookup->{$k}) eq 'ARRAY') {
322                    return @{ $lookup->{$k} };
323            } else {
324                    return $lookup->{$k};
325            }
326  }  }
327    
328    =head2 join_with
329    
330  =head1 AUTHOR  Joins walues with some delimiter
   
 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  
   
 =head1 COPYRIGHT & LICENSE  
331    
332  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.    $v = join_with(", ", @v);
   
 This program is free software; you can redistribute it and/or modify it  
 under the same terms as Perl itself.  
333    
334  =cut  =cut
335    
336  1; # End of WebPAC::DB  sub join_with {
337            my $d = shift;
338            return join($d, grep { defined($_) && $_ ne '' } @_);
339    }
340    
341    # END
342    1;

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

  ViewVC Help
Powered by ViewVC 1.1.26