/[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 38 by dpavlin, Sat Nov 12 21:21:50 2005 UTC revision 364 by dpavlin, Sun Jan 8 20:27:11 2006 UTC
# 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.08
15    
16  =cut  =cut
17    
18  our $VERSION = '0.01';  our $VERSION = '0.08';
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 82  Create new normalisation object Line 86  Create new normalisation object
86          db => $db_obj,          db => $db_obj,
87          lookup_regex => $lookup->regex,          lookup_regex => $lookup->regex,
88          lookup => $lookup_obj,          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. If you pass this parametar, you must also pass C<lookup>  in structures. If you pass this parametar, you must also pass C<lookup>
100  which is C<WebPAC::Lookup> object.  which is C<WebPAC::Lookup> object.
# Line 111  sub new { Line 119  sub new {
119    
120          $log->logdie("lookup must be WebPAC::Lookup object") if ($self->{'lookup'} && ! $self->{'lookup'}->isa('WebPAC::Lookup'));          $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 122  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 140  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 " . 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'}->load_ds($rec);                  my $ds = $self->{'db'}->load_ds( id => $id, prefix => $self->{prefix} );
168                  $log->debug("load_ds( rec = ", sub { Dumper($rec) }, ") = ", sub { Dumper(@ds) });                  $log->debug("load_ds( rec = ", sub { Dumper($rec) }, ") = ", sub { Dumper($ds) });
169                  return @ds if ($#ds > 0);                  return $ds if ($ds);
170                  $log->debug("cache miss, creating");                  $log->debug("cache miss, creating");
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 160  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 176  sub data_structure { Line 194  sub data_structure {
194                          $log->logdie("expected tag HASH and got $tag") unless (ref($tag) eq 'HASH');                          $log->logdie("expected tag HASH and got $tag") unless (ref($tag) eq 'HASH');
195                          $format = $tag->{'value'} || $tag->{'content'};                          $format = $tag->{'value'} || $tag->{'content'};
196    
                         $log->debug("format: $format");  
   
197                          my @v;                          my @v;
198                          if ($self->{'lookup_regex'} && $format =~ $self->{'lookup_regex'}) {                          if ($self->{'lookup_regex'} && $format =~ $self->{'lookup_regex'}) {
199                                  @v = $self->fill_in_to_arr($rec,$format);                                  @v = $self->fill_in_to_arr($rec,$format);
200                          } else {                          } else {
201                                  @v = $self->parse_to_arr($rec,$format);                                  @v = $self->parse_to_arr($rec,$format);
202                          }                          }
203                          next if (! @v);                          if (! @v) {
204                                    $log->debug("$field <",$self->{tag},"> format: $format no values");
205    #                               next;
206                            } else {
207                                    $log->debug("$field <",$self->{tag},"> format: $format values: ", join(",", @v));
208                            }
209    
210                          if ($tag->{'sort'}) {                          if ($tag->{'sort'}) {
211                                  @v = $self->sort_arr(@v);                                  @v = $self->sort_arr(@v);
# Line 195  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("tag $field / $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 243  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                  }                  }
# Line 258  sub data_structure { Line 270  sub data_structure {
270          }          }
271    
272          $self->{'db'}->save_ds(          $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          $log->debug("ds: ", sub { Dumper(@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;          return $ds;
283    
284  }  }
285    
# Line 277  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 296  sub parse { Line 320  sub parse {
320    
321          my @out;          my @out;
322    
323          $log->debug("format: $format");          $log->debug("format: $format [$i]");
324    
325          my $eval_code;          my $eval_code;
326          # remove eval{...} from beginning          # remove eval{...} from beginning
# Line 306  sub parse { Line 330  sub parse {
330          # remove filter{...} from beginning          # remove filter{...} from beginning
331          $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);          $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
332    
333            # did we found any (att all) field from format in row?
334            my $found_any;
335            # prefix before first field which we preserve it $found_any
336          my $prefix;          my $prefix;
337          my $all_found=0;  
338            my $f_step = 1;
339    
340          while ($format =~ s/^(.*?)(v|s)(\d+)(?:\^(\w))?//s) {          while ($format =~ s/^(.*?)(v|s)(\d+)(?:\^(\w))?//s) {
341    
342                  my $del = $1 || '';                  my $del = $1 || '';
343                  $prefix ||= $del if ($all_found == 0);                  $prefix = $del if ($f_step == 1);
344    
345                    my $fld_type = lc($2);
346    
347                  # repeatable index                  # repeatable index
348                  my $r = $i;                  my $r = $i;
349                  $r = 0 if (lc("$2") eq 's');                  if ($fld_type eq 's') {
350                            if ($found_any->{'v'}) {
351                                    $r = 0;
352                            } else {
353                                    return;
354                            }
355                    }
356    
357                  my $found = 0;                  my $found = 0;
358                  my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found);                  my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found);
359    
360                  if ($found) {                  if ($found) {
361                          push @out, $del;                          $found_any->{$fld_type} += $found;
362    
363                            # we will skip delimiter before first occurence of field!
364                            push @out, $del unless($found_any->{$fld_type} == 1);
365                          push @out, $tmp;                          push @out, $tmp;
                         $all_found += $found;  
366                  }                  }
367                    $f_step++;
368          }          }
369    
370          return if (! $all_found);          # test if any fields found?
371            return if (! $found_any->{'v'} && ! $found_any->{'s'});
372    
373          my $out = join('',@out);          my $out = join('',@out);
374    
# Line 348  sub parse { Line 388  sub parse {
388                  return if (! $self->_eval($eval));                  return if (! $self->_eval($eval));
389          }          }
390                    
391          if ($filter_name && $self->{'filter'}->{$filter_name}) {          if ($filter_name) {
392                  $log->debug("about to filter{$filter_name} format: $out");                  my @filter_args;
393                  $out = $self->{'filter'}->{$filter_name}->($out);                  if ($filter_name =~ s/(\w+)\((.*)\)/$1/) {
394                  return unless(defined($out));                          @filter_args = split(/,/, $2);
395                  $log->debug("filter result: $out");                  }
396                    if ($self->{'filter'}->{$filter_name}) {
397                            $log->debug("about to filter{$filter_name} format: $out with arguments: ", join(",", @filter_args));
398                            unshift @filter_args, $out;
399                            $out = $self->{'filter'}->{$filter_name}->(@filter_args);
400                            return unless(defined($out));
401                            $log->debug("filter result: $out");
402                    } elsif (! $warn_once->{$filter_name}) {
403                            $log->warn("trying to use undefined filter $filter_name");
404                            $warn_once->{$filter_name}++;
405                    }
406          }          }
407    
408          return $out;          return $out;
# Line 432  sub fill_in { Line 482  sub fill_in {
482          }          }
483    
484          my $found = 0;          my $found = 0;
485            my $just_single = 1;
486    
487          my $eval_code;          my $eval_code;
488          # remove eval{...} from beginning          # remove eval{...} from beginning
# Line 443  sub fill_in { Line 494  sub fill_in {
494    
495          # do actual replacement of placeholders          # do actual replacement of placeholders
496          # repeatable fields          # repeatable fields
497          $format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;          if ($format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges) {
498                    $just_single = 0;
499            }
500    
501          # non-repeatable fields          # non-repeatable fields
502          $format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found)/ges;          if ($format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found)/ges) {
503                    return if ($i > 0 && $just_single);
504            }
505    
506          if ($found) {          if ($found) {
507                  $log->debug("format: $format");                  $log->debug("format: $format");
# Line 462  sub fill_in { Line 518  sub fill_in {
518                  # do we have lookups?                  # do we have lookups?
519                  if ($self->{'lookup'}) {                  if ($self->{'lookup'}) {
520                          if ($self->{'lookup'}->can('lookup')) {                          if ($self->{'lookup'}->can('lookup')) {
521                                  return $self->{'lookup'}->lookup($format);                                  my @lookup = $self->{lookup}->lookup($format);
522                                    $log->debug("lookup $format", join(", ", @lookup));
523                                    return @lookup;
524                          } else {                          } else {
525                                  $log->warn("Have lookup object but can't invoke lookup method");                                  $log->warn("Have lookup object but can't invoke lookup method");
526                          }                          }
# Line 498  sub fill_in_to_arr { Line 556  sub fill_in_to_arr {
556          my $i = 0;          my $i = 0;
557          my @arr;          my @arr;
558    
559          while (my @v = $self->fill_in($rec,$format_utf8,$i++)) {          while (my $v = $self->fill_in($rec,$format_utf8,$i++)) {
560                  push @arr, @v;                  push @arr, $v;
561          }          }
562    
563          $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);          $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
# Line 538  sub get_data { Line 596  sub get_data {
596                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {
597                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
598                          return $$rec->{$f}->[$i]->{$sf};                          return $$rec->{$f}->[$i]->{$sf};
599                  } elsif ($$rec->{$f}->[$i]) {                  } elsif (! $sf && $$rec->{$f}->[$i]) {
600                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
601                          # it still might have subfield, just                          # it still might have subfield, just
602                          # not specified, so we'll dump all                          # not specified, so we'll dump all
603                          if ($$rec->{$f}->[$i] =~ /HASH/o) {                          if ($$rec->{$f}->[$i] =~ /HASH/o) {
604                                  my $out;                                  my $out;
605                                  foreach my $k (keys %{$$rec->{$f}->[$i]}) {                                  foreach my $k (keys %{$$rec->{$f}->[$i]}) {
606                                          $out .= $$rec->{$f}->[$i]->{$k}." ";                                          my $v = $$rec->{$f}->[$i]->{$k};
607                                            $out .= "$v " if ($v);
608                                  }                                  }
609                                  return $out;                                  return $out;
610                          } else {                          } else {
611                                  return $$rec->{$f}->[$i];                                  return $$rec->{$f}->[$i];
612                          }                          }
613                    } else {
614                            return '';
615                  }                  }
616          } else {          } else {
617                  return '';                  return '';
# Line 674  under the same terms as Perl itself. Line 735  under the same terms as Perl itself.
735    
736  =cut  =cut
737    
738  1; # End of WebPAC::DB  1; # End of WebPAC::Normalize

Legend:
Removed from v.38  
changed lines
  Added in v.364

  ViewVC Help
Powered by ViewVC 1.1.26