/[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 18 by dpavlin, Sun Jul 17 14:53:37 2005 UTC revision 261 by dpavlin, Fri Dec 16 16:00:18 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
# Line 10  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.06
15    
16  =cut  =cut
17    
18  our $VERSION = '0.01';  our $VERSION = '0.06';
19    
20  =head1 SYNOPSIS  =head1 SYNOPSIS
21    
# Line 46  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 78  Create new normalisation object Line 83  Create new normalisation object
83                          return length($_);                          return length($_);
84                  }, ...                  }, ...
85          },          },
86          db => $webpac_db_obj,          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    C<prefix> is used to form filename for database record (to support multiple
96    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 95  sub new { Line 106  sub new {
106          my $self = {@_};          my $self = {@_};
107          bless($self, $class);          bless($self, $class);
108    
109            my $r = $self->{'lookup_regex'} ? 1 : 0;
110            my $l = $self->{'lookup'} ? 1 : 0;
111    
112            my $log = $self->_get_logger();
113    
114            # those two must be in pair
115            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            $log->logdie("lookup must be WebPAC::Lookup object") if ($self->{'lookup'} && ! $self->{'lookup'}->isa('WebPAC::Lookup'));
121    
122            $log->warn("no prefix defined. please check that!") unless ($self->{'prefix'});
123    
124            $log->debug("using lookup regex: ", $self->{lookup_regex}) if ($r && $l);
125    
126            if ($self->{filter} && ! $self->{filter}->{regex}) {
127                    $log->debug("adding built-in filter regex");
128                    $self->{filter}->{regex} = sub {
129                            my ($val, $regex) = @_;
130                            eval "\$val =~ $regex";
131                            return $val;
132                    };
133            }
134    
135          $self ? return $self : return undef;          $self ? return $self : return undef;
136  }  }
137    
# Line 106  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 124  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 ($self->{'db'}) {          if ($self->{'db'}) {
167                  my @ds = $self->{'db'}->get_ds($rec);                  my $ds = $self->{'db'}->load_ds( id => $id, prefix => $self->{prefix} );
168                  return @ds if (@ds);                  $log->debug("load_ds( rec = ", sub { Dumper($rec) }, ") = ", sub { Dumper($ds) });
169                    return $ds if ($ds);
170                    $log->debug("cache miss, creating");
171          }          }
172    
173          undef $self->{'currnet_filename'};          undef $self->{'currnet_filename'};
# Line 142  sub data_structure { Line 181  sub data_structure {
181                  $self->{tags_by_order} = \@sorted_tags;                  $self->{tags_by_order} = \@sorted_tags;
182          }          }
183    
184          my @ds;          my $ds;
185    
186          $log->debug("tags: ",sub { join(", ",@sorted_tags) });          $log->debug("tags: ",sub { join(", ",@sorted_tags) });
187    
# Line 153  sub data_structure { Line 192  sub data_structure {
192  #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'}});
193    
194                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
195                          my $format = $tag->{'value'} || $tag->{'content'};                          my $format;
196    
197                            $log->logdie("expected tag HASH and got $tag") unless (ref($tag) eq 'HASH');
198                            $format = $tag->{'value'} || $tag->{'content'};
199    
200                          $log->debug("format: $format");                          $log->debug("format: $format");
201    
# Line 174  sub data_structure { Line 216  sub data_structure {
216                                  @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;                                  @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
217                          }                          }
218    
                         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!  
                         }  
   
219                          # delimiter will join repeatable fields                          # delimiter will join repeatable fields
220                          if ($tag->{'delimiter'}) {                          if ($tag->{'delimiter'}) {
221                                  @v = ( join($tag->{'delimiter'}, @v) );                                  @v = ( join($tag->{'delimiter'}, @v) );
222                          }                          }
223    
224                          # default types                          # default types
225                          my @types = qw(display swish);                          my @types = qw(display search);
226                          # override by type attribute                          # override by type attribute
227                          @types = ( $tag->{'type'} ) if ($tag->{'type'});                          @types = ( $tag->{'type'} ) if ($tag->{'type'});
228    
229                          foreach my $type (@types) {                          foreach my $type (@types) {
230                                  # append to previous line?                                  # append to previous line?
231                                  $log->debug("type: $type ",sub { join(" ",@v) }, $row->{'append'} || 'no append');                                  $log->debug("type: $type ",sub { join(" ",@v) }, " ", $row->{'append'} || 'no append');
232                                  if ($tag->{'append'}) {                                  if ($tag->{'append'}) {
233    
234                                          # I will delimit appended part with                                          # I will delimit appended part with
# Line 222  sub data_structure { Line 255  sub data_structure {
255    
256                          # TODO: name_sigular, name_plural                          # TODO: name_sigular, name_plural
257                          my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};                          my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
258                          $row->{'name'} = $name ? $self->_x($name) : $field;                          my $row_name = $name ? $self->_x($name) : $field;
259    
260                          # post-sort all values in field                          # post-sort all values in field
261                          if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {                          if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {
262                                  $log->warn("sort at field tag not implemented");                                  $log->warn("sort at field tag not implemented");
263                          }                          }
264    
265                          push @ds, $row;                          $ds->{$row_name} = $row;
266    
267                          $log->debug("row $field: ",sub { Dumper($row) });                          $log->debug("row $field: ",sub { Dumper($row) });
268                  }                  }
269    
270          }          }
271    
272          $self->{'db'}->put_gs(          $self->{'db'}->save_ds(
273                  ds => \@ds,                  id => $id,
274                  current_filename => $self->{'current_filename'},                  ds => $ds,
275                  headline => $self->{'headline'},                  prefix => $self->{prefix},
276          ) if ($self->{'db'});          ) if ($self->{'db'});
277    
278          return @ds;          $log->debug("ds: ", sub { Dumper($ds) });
279    
280            $log->logconfess("data structure returned is not array any more!") if wantarray;
281    
282            return $ds;
283    
284  }  }
285    
# Line 254  return output or nothing depending on ev Line 291  return output or nothing depending on ev
291    
292   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);
293    
294    Filters are implemented here. While simple form of filters looks like this:
295    
296      filter{name_of_filter}
297    
298    but, filters can also have variable number of parametars like this:
299    
300      filter{name_of_filter(param,param,param)}
301    
302  =cut  =cut
303    
304    my $warn_once;
305    
306  sub parse {  sub parse {
307          my $self = shift;          my $self = shift;
308    
# Line 325  sub parse { Line 372  sub parse {
372                  return if (! $self->_eval($eval));                  return if (! $self->_eval($eval));
373          }          }
374                    
375          if ($filter_name && $self->{'filter'}->{$filter_name}) {          if ($filter_name) {
376                  $log->debug("about to filter{$filter_name} format: $out");                  my @filter_args;
377                  $out = $self->{'filter'}->{$filter_name}->($out);                  if ($filter_name =~ s/(\w+)\((.*)\)/$1/) {
378                  return unless(defined($out));                          @filter_args = split(/,/, $2);
379                  $log->debug("filter result: $out");                  }
380                    if ($self->{'filter'}->{$filter_name}) {
381                            $log->debug("about to filter{$filter_name} format: $out with arguments: ", join(",", @filter_args));
382                            unshift @filter_args, $out;
383                            $out = $self->{'filter'}->{$filter_name}->(@filter_args);
384                            return unless(defined($out));
385                            $log->debug("filter result: $out");
386                    } elsif (! $warn_once->{$filter_name}) {
387                            $log->warn("trying to use undefined filter $filter_name");
388                            $warn_once->{$filter_name}++;
389                    }
390          }          }
391    
392          return $out;          return $out;
# Line 438  sub fill_in { Line 495  sub fill_in {
495                  }                  }
496                  # do we have lookups?                  # do we have lookups?
497                  if ($self->{'lookup'}) {                  if ($self->{'lookup'}) {
498                          return $self->lookup($format);                          if ($self->{'lookup'}->can('lookup')) {
499                                    my @lookup = $self->{lookup}->lookup($format);
500                                    $log->debug("lookup $format", join(", ", @lookup));
501                                    return @lookup;
502                            } else {
503                                    $log->warn("Have lookup object but can't invoke lookup method");
504                            }
505                  } else {                  } else {
506                          return $format;                          return $format;
507                  }                  }
# Line 511  sub get_data { Line 574  sub get_data {
574                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {
575                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
576                          return $$rec->{$f}->[$i]->{$sf};                          return $$rec->{$f}->[$i]->{$sf};
577                  } elsif ($$rec->{$f}->[$i]) {                  } elsif (! $sf && $$rec->{$f}->[$i]) {
578                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
579                          # it still might have subfield, just                          # it still might have subfield, just
580                          # not specified, so we'll dump all                          # not specified, so we'll dump all
# Line 524  sub get_data { Line 587  sub get_data {
587                          } else {                          } else {
588                                  return $$rec->{$f}->[$i];                                  return $$rec->{$f}->[$i];
589                          }                          }
590                    } else {
591                            return '';
592                  }                  }
593          } else {          } else {
594                  return '';                  return '';
# Line 564  sub apply_format { Line 629  sub apply_format {
629          $log->debug("using format $name [$format] on $data to produce: $out");          $log->debug("using format $name [$format] on $data to produce: $out");
630    
631          if ($self->{'lookup_regex'} && $out =~ $self->{'lookup_regex'}) {          if ($self->{'lookup_regex'} && $out =~ $self->{'lookup_regex'}) {
632                  return $self->lookup($out);                  return $self->{'lookup'}->lookup($out);
633          } else {          } else {
634                  return $out;                  return $out;
635          }          }
# Line 647  under the same terms as Perl itself. Line 712  under the same terms as Perl itself.
712    
713  =cut  =cut
714    
715  1; # End of WebPAC::DB  1; # End of WebPAC::Normalize
Legend:
Removed from v.18  
changed lines
  Added in v.261
  ViewVC Help
Powered by ViewVC 1.1.26