/[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 15 by dpavlin, Sun Jul 17 10:42:23 2005 UTC revision 295 by dpavlin, Mon Dec 19 15:34: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;
 use Storable;  
7    
8  =head1 NAME  =head1 NAME
9    
# Line 11  WebPAC::Normalize - data mungling for no Line 11  WebPAC::Normalize - data mungling for no
11    
12  =head1 VERSION  =head1 VERSION
13    
14  Version 0.01  Version 0.07
15    
16  =cut  =cut
17    
18  our $VERSION = '0.01';  our $VERSION = '0.07';
19    
20  =head1 SYNOPSIS  =head1 SYNOPSIS
21    
# Line 47  optional C<filter{filter_name}> at B<beg Line 47  optional C<filter{filter_name}> at B<beg
47  code defined as code ref on format after field substitution to producing  code defined as code ref on format after field substitution to producing
48  output  output
49    
50    There is one built-in filter called C<regex> which can be use like this:
51    
52      filter{regex(s/foo/bar/)}
53    
54  =item *  =item *
55    
56  optional C<lookup{...}> will be then performed. See C<WebPAC::Lookups>.  optional C<lookup{...}> will be then performed. See C<WebPAC::Lookups>.
# Line 79  Create new normalisation object Line 83  Create new normalisation object
83                          return length($_);                          return length($_);
84                  }, ...                  }, ...
85          },          },
86          cache_data_structure => './cache/ds/',          db => $db_obj,
87          lookup_regex => $lookup->regex,          lookup_regex => $lookup->regex,
88            lookup => $lookup_obj,
89            prefix => 'foobar',
90    );    );
91    
92  Parametar C<filter> defines user supplied snippets of perl code which can  Parametar C<filter> defines user supplied snippets of perl code which can
93  be use with C<filter{...}> notation.  be use with C<filter{...}> notation.
94    
95  Optional parameter C<cache_data_structure> defines path to directory  C<prefix> is used to form filename for database record (to support multiple
96  in which cache file for C<data_structure> call will be created.  source files which are joined in one database).
97    
98  Recommended parametar C<lookup_regex> is used to enable parsing of lookups  Recommended parametar C<lookup_regex> is used to enable parsing of lookups
99  in structures.  in structures. If you pass this parametar, you must also pass C<lookup>
100    which is C<WebPAC::Lookup> object.
101    
102  =cut  =cut
103    
# Line 99  sub new { Line 106  sub new {
106          my $self = {@_};          my $self = {@_};
107          bless($self, $class);          bless($self, $class);
108    
109          $self->setup_cache_dir( $self->{'cache_data_structure'} );          my $r = $self->{'lookup_regex'} ? 1 : 0;
110            my $l = $self->{'lookup'} ? 1 : 0;
         $self ? return $self : return undef;  
 }  
   
 =head2 setup_cache_dir  
111    
112  Check if specified cache directory exist, and if not, disable caching.          my $log = $self->_get_logger();
   
  $setup_cache_dir('./cache/ds/');  
   
 If you pass false or zero value to this function, it will disable  
 cacheing.  
   
 =cut  
113    
114  sub setup_cache_dir {          # those two must be in pair
115          my $self = shift;          if ( ($r & $l) != ($r || $l) ) {
116                    my $log = $self->_get_logger();
117                    $log->logdie("lookup_regex and lookup must be in pair");
118            }
119    
120          my $dir = shift;          $log->logdie("lookup must be WebPAC::Lookup object") if ($self->{'lookup'} && ! $self->{'lookup'}->isa('WebPAC::Lookup'));
121    
122          my $log = $self->_get_logger();          $log->warn("no prefix defined. please check that!") unless ($self->{'prefix'});
123    
124          if ($dir) {          $log->debug("using lookup regex: ", $self->{lookup_regex}) if ($r && $l);
                 my $msg;  
                 if (! -e $dir) {  
                         $msg = "doesn't exist";  
                 } elsif (! -d $dir) {  
                         $msg = "is not directory";  
                 } elsif (! -w $dir) {  
                         $msg = "not writable";  
                 }  
125    
126                  if ($msg) {          if (! $self->{filter} || ! $self->{filter}->{regex}) {
127                          undef $self->{'cache_data_structure'};                  $log->debug("adding built-in filter regex");
128                          $log->warn("cache_data_structure $dir $msg, disabling...");                  $self->{filter}->{regex} = sub {
129                  } else {                          my ($val, $regex) = @_;
130                          $log->debug("using cache dir $dir");                          eval "\$val =~ $regex";
131                  }                          return $val;
132          } else {                  };
                 $log->debug("disabling cache");  
                 undef $self->{'cache_data_structure'};  
133          }          }
134    
135            $self ? return $self : return undef;
136  }  }
137    
138    
# Line 152  C<conf/normalize/*.xml>. Line 143  C<conf/normalize/*.xml>.
143    
144  This structures are used to produce output.  This structures are used to produce output.
145    
146   my @ds = $webpac->data_structure($rec);   my $ds = $webpac->data_structure($rec);
   
 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.  
147    
148  =cut  =cut
149    
# Line 170  sub data_structure { Line 155  sub data_structure {
155          my $rec = shift;          my $rec = shift;
156          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
157    
158            $log->debug("data_structure rec = ", sub { Dumper($rec) });
159    
160            $log->logdie("need unique ID (mfn) in field 000 of record ", sub { Dumper($rec) } ) unless (defined($rec->{'000'}));
161    
162            my $id = $rec->{'000'}->[0] || $log->logdie("field 000 isn't array!");
163    
164          my $cache_file;          my $cache_file;
165    
166          if (my $cache_path = $self->{'cache_data_structure'}) {          if ($self->{'db'}) {
167                  my $id = $rec->{'000'};                  my $ds = $self->{'db'}->load_ds( id => $id, prefix => $self->{prefix} );
168                  $id = $rec->{'000'}->[0] if ($id =~ m/^ARRAY/o);                  $log->debug("load_ds( rec = ", sub { Dumper($rec) }, ") = ", sub { Dumper($ds) });
169                  unless (defined($id)) {                  return $ds if ($ds);
170                          $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'};  
                                         }  
                                 }  
                         }  
                 }  
171          }          }
172    
         undef $self->{'currnet_filename'};  
         undef $self->{'headline'};  
   
173          my @sorted_tags;          my @sorted_tags;
174          if ($self->{tags_by_order}) {          if ($self->{tags_by_order}) {
175                  @sorted_tags = @{$self->{tags_by_order}};                  @sorted_tags = @{$self->{tags_by_order}};
# Line 214  sub data_structure { Line 178  sub data_structure {
178                  $self->{tags_by_order} = \@sorted_tags;                  $self->{tags_by_order} = \@sorted_tags;
179          }          }
180    
181          my @ds;          my $ds;
182    
183          $log->debug("tags: ",sub { join(", ",@sorted_tags) });          $log->debug("tags: ",sub { join(", ",@sorted_tags) });
184    
# Line 225  sub data_structure { Line 189  sub data_structure {
189  #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'}});
190    
191                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
192                          my $format = $tag->{'value'} || $tag->{'content'};                          my $format;
193    
194                            $log->logdie("expected tag HASH and got $tag") unless (ref($tag) eq 'HASH');
195                            $format = $tag->{'value'} || $tag->{'content'};
196    
197                          $log->debug("format: $format");                          $log->debug("format: $format");
198    
# Line 246  sub data_structure { Line 213  sub data_structure {
213                                  @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;                                  @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
214                          }                          }
215    
                         if ($field eq 'filename') {  
                                 $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!  
                         }  
   
216                          # delimiter will join repeatable fields                          # delimiter will join repeatable fields
217                          if ($tag->{'delimiter'}) {                          if ($tag->{'delimiter'}) {
218                                  @v = ( join($tag->{'delimiter'}, @v) );                                  @v = ( join($tag->{'delimiter'}, @v) );
219                          }                          }
220    
221                          # default types                          # default types
222                          my @types = qw(display swish);                          my @types = qw(display search);
223                          # override by type attribute                          # override by type attribute
224                          @types = ( $tag->{'type'} ) if ($tag->{'type'});                          @types = ( $tag->{'type'} ) if ($tag->{'type'});
225    
226                          foreach my $type (@types) {                          foreach my $type (@types) {
227                                  # append to previous line?                                  # append to previous line?
228                                  $log->debug("type: $type ",sub { join(" ",@v) }, $row->{'append'} || 'no append');                                  $log->debug("type: $type ",sub { join(" ",@v) }, " ", $row->{'append'} || 'no append');
229                                  if ($tag->{'append'}) {                                  if ($tag->{'append'}) {
230    
231                                          # I will delimit appended part with                                          # I will delimit appended part with
# Line 294  sub data_structure { Line 252  sub data_structure {
252    
253                          # TODO: name_sigular, name_plural                          # TODO: name_sigular, name_plural
254                          my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};                          my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
255                          $row->{'name'} = $name ? $self->_x($name) : $field;                          my $row_name = $name ? $self->_x($name) : $field;
256    
257                          # post-sort all values in field                          # post-sort all values in field
258                          if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {                          if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {
259                                  $log->warn("sort at field tag not implemented");                                  $log->warn("sort at field tag not implemented");
260                          }                          }
261    
262                          push @ds, $row;                          $ds->{$row_name} = $row;
263    
264                          $log->debug("row $field: ",sub { Dumper($row) });                          $log->debug("row $field: ",sub { Dumper($row) });
265                  }                  }
266    
267          }          }
268    
269          if ($cache_file) {          $self->{'db'}->save_ds(
270                  store {                  id => $id,
271                          ds => \@ds,                  ds => $ds,
272                          current_filename => $self->{'current_filename'},                  prefix => $self->{prefix},
273                          headline => $self->{'headline'},          ) if ($self->{'db'});
274                  }, $cache_file;  
275                  $log->debug("created storable cache file $cache_file");          $log->debug("ds: ", sub { Dumper($ds) });
         }  
276    
277          return @ds;          $log->logconfess("data structure returned is not array any more!") if wantarray;
278    
279            return $ds;
280    
281  }  }
282    
# Line 329  return output or nothing depending on ev Line 288  return output or nothing depending on ev
288    
289   my $text = $webpac->parse($rec,'eval{"v901^a" eq "Deskriptor"}descriptor: v250^a', $i);   my $text = $webpac->parse($rec,'eval{"v901^a" eq "Deskriptor"}descriptor: v250^a', $i);
290    
291    Filters are implemented here. While simple form of filters looks like this:
292    
293      filter{name_of_filter}
294    
295    but, filters can also have variable number of parametars like this:
296    
297      filter{name_of_filter(param,param,param)}
298    
299  =cut  =cut
300    
301    my $warn_once;
302    
303  sub parse {  sub parse {
304          my $self = shift;          my $self = shift;
305    
# Line 400  sub parse { Line 369  sub parse {
369                  return if (! $self->_eval($eval));                  return if (! $self->_eval($eval));
370          }          }
371                    
372          if ($filter_name && $self->{'filter'}->{$filter_name}) {          if ($filter_name) {
373                  $log->debug("about to filter{$filter_name} format: $out");                  my @filter_args;
374                  $out = $self->{'filter'}->{$filter_name}->($out);                  if ($filter_name =~ s/(\w+)\((.*)\)/$1/) {
375                  return unless(defined($out));                          @filter_args = split(/,/, $2);
376                  $log->debug("filter result: $out");                  }
377                    if ($self->{'filter'}->{$filter_name}) {
378                            $log->debug("about to filter{$filter_name} format: $out with arguments: ", join(",", @filter_args));
379                            unshift @filter_args, $out;
380                            $out = $self->{'filter'}->{$filter_name}->(@filter_args);
381                            return unless(defined($out));
382                            $log->debug("filter result: $out");
383                    } elsif (! $warn_once->{$filter_name}) {
384                            $log->warn("trying to use undefined filter $filter_name");
385                            $warn_once->{$filter_name}++;
386                    }
387          }          }
388    
389          return $out;          return $out;
# Line 513  sub fill_in { Line 492  sub fill_in {
492                  }                  }
493                  # do we have lookups?                  # do we have lookups?
494                  if ($self->{'lookup'}) {                  if ($self->{'lookup'}) {
495                          return $self->lookup($format);                          if ($self->{'lookup'}->can('lookup')) {
496                                    my @lookup = $self->{lookup}->lookup($format);
497                                    $log->debug("lookup $format", join(", ", @lookup));
498                                    return @lookup;
499                            } else {
500                                    $log->warn("Have lookup object but can't invoke lookup method");
501                            }
502                  } else {                  } else {
503                          return $format;                          return $format;
504                  }                  }
# Line 586  sub get_data { Line 571  sub get_data {
571                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {
572                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
573                          return $$rec->{$f}->[$i]->{$sf};                          return $$rec->{$f}->[$i]->{$sf};
574                  } elsif ($$rec->{$f}->[$i]) {                  } elsif (! $sf && $$rec->{$f}->[$i]) {
575                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
576                          # it still might have subfield, just                          # it still might have subfield, just
577                          # not specified, so we'll dump all                          # not specified, so we'll dump all
# Line 599  sub get_data { Line 584  sub get_data {
584                          } else {                          } else {
585                                  return $$rec->{$f}->[$i];                                  return $$rec->{$f}->[$i];
586                          }                          }
587                    } else {
588                            return '';
589                  }                  }
590          } else {          } else {
591                  return '';                  return '';
# Line 639  sub apply_format { Line 626  sub apply_format {
626          $log->debug("using format $name [$format] on $data to produce: $out");          $log->debug("using format $name [$format] on $data to produce: $out");
627    
628          if ($self->{'lookup_regex'} && $out =~ $self->{'lookup_regex'}) {          if ($self->{'lookup_regex'} && $out =~ $self->{'lookup_regex'}) {
629                  return $self->lookup($out);                  return $self->{'lookup'}->lookup($out);
630          } else {          } else {
631                  return $out;                  return $out;
632          }          }
# Line 722  under the same terms as Perl itself. Line 709  under the same terms as Perl itself.
709    
710  =cut  =cut
711    
712  1; # End of WebPAC::DB  1; # End of WebPAC::Normalize

Legend:
Removed from v.15  
changed lines
  Added in v.295

  ViewVC Help
Powered by ViewVC 1.1.26