/[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 74 by dpavlin, Sun Nov 20 20:13:39 2005 UTC revision 371 by dpavlin, Sun Jan 8 21:16:27 2006 UTC
# Line 2  package WebPAC::Normalize; Line 2  package WebPAC::Normalize;
2    
3  use warnings;  use warnings;
4  use strict;  use strict;
5    use blib;
6    use WebPAC::Common;
7  use base 'WebPAC::Common';  use base 'WebPAC::Common';
8  use Data::Dumper;  use Data::Dumper;
9    
# Line 11  WebPAC::Normalize - data mungling for no Line 13  WebPAC::Normalize - data mungling for no
13    
14  =head1 VERSION  =head1 VERSION
15    
16  Version 0.02  Version 0.08
17    
18  =cut  =cut
19    
20  our $VERSION = '0.02';  our $VERSION = '0.08';
21    
22  =head1 SYNOPSIS  =head1 SYNOPSIS
23    
# Line 47  optional C<filter{filter_name}> at B<beg Line 49  optional C<filter{filter_name}> at B<beg
49  code defined as code ref on format after field substitution to producing  code defined as code ref on format after field substitution to producing
50  output  output
51    
52    There is one built-in filter called C<regex> which can be use like this:
53    
54      filter{regex(s/foo/bar/)}
55    
56  =item *  =item *
57    
58  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 88  Create new normalisation object
88          db => $db_obj,          db => $db_obj,
89          lookup_regex => $lookup->regex,          lookup_regex => $lookup->regex,
90          lookup => $lookup_obj,          lookup => $lookup_obj,
91            prefix => 'foobar',
92    );    );
93    
94  Parametar C<filter> defines user supplied snippets of perl code which can  Parametar C<filter> defines user supplied snippets of perl code which can
95  be use with C<filter{...}> notation.  be use with C<filter{...}> notation.
96    
97    C<prefix> is used to form filename for database record (to support multiple
98    source files which are joined in one database).
99    
100  Recommended parametar C<lookup_regex> is used to enable parsing of lookups  Recommended parametar C<lookup_regex> is used to enable parsing of lookups
101  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>
102  which is C<WebPAC::Lookup> object.  which is C<WebPAC::Lookup> object.
# Line 111  sub new { Line 121  sub new {
121    
122          $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'));
123    
124            $log->warn("no prefix defined. please check that!") unless ($self->{'prefix'});
125    
126            $log->debug("using lookup regex: ", $self->{lookup_regex}) if ($r && $l);
127    
128            if (! $self->{filter} || ! $self->{filter}->{regex}) {
129                    $log->debug("adding built-in filter regex");
130                    $self->{filter}->{regex} = sub {
131                            my ($val, $regex) = @_;
132                            eval "\$val =~ $regex";
133                            return $val;
134                    };
135            }
136    
137          $self ? return $self : return undef;          $self ? return $self : return undef;
138  }  }
139    
# Line 124  This structures are used to produce outp Line 147  This structures are used to produce outp
147    
148   my $ds = $webpac->data_structure($rec);   my $ds = $webpac->data_structure($rec);
149    
 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.  
   
150  =cut  =cut
151    
152  sub data_structure {  sub data_structure {
# Line 140  sub data_structure { Line 157  sub data_structure {
157          my $rec = shift;          my $rec = shift;
158          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
159    
160            $log->debug("data_structure rec = ", sub { Dumper($rec) });
161    
162            $log->logdie("need unique ID (mfn) in field 000 of record " . Dumper($rec) ) unless (defined($rec->{'000'}));
163    
164            my $id = $rec->{'000'}->[0] || $log->logdie("field 000 isn't array!");
165    
166          my $cache_file;          my $cache_file;
167    
168          if ($self->{'db'}) {          if ($self->{'db'}) {
169                  my $ds = $self->{'db'}->load_ds($rec);                  my $ds = $self->{'db'}->load_ds( id => $id, prefix => $self->{prefix} );
170                  $log->debug("load_ds( rec = ", sub { Dumper($rec) }, ") = ", sub { Dumper($ds) });                  $log->debug("load_ds( rec = ", sub { Dumper($rec) }, ") = ", sub { Dumper($ds) });
171                  return $ds if ($ds);                  return $ds if ($ds);
172                  $log->debug("cache miss, creating");                  $log->debug("cache miss, creating");
173          }          }
174    
         undef $self->{'currnet_filename'};  
         undef $self->{'headline'};  
   
175          my @sorted_tags;          my @sorted_tags;
176          if ($self->{tags_by_order}) {          if ($self->{tags_by_order}) {
177                  @sorted_tags = @{$self->{tags_by_order}};                  @sorted_tags = @{$self->{tags_by_order}};
# Line 176  sub data_structure { Line 196  sub data_structure {
196                          $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');
197                          $format = $tag->{'value'} || $tag->{'content'};                          $format = $tag->{'value'} || $tag->{'content'};
198    
                         $log->debug("format: $format");  
   
199                          my @v;                          my @v;
200                          if ($self->{'lookup_regex'} && $format =~ $self->{'lookup_regex'}) {                          if ($self->{'lookup_regex'} && $format =~ $self->{'lookup_regex'}) {
201                                  @v = $self->fill_in_to_arr($rec,$format);                                  @v = $self->fill_in_to_arr($rec,$format);
202                          } else {                          } else {
203                                  @v = $self->parse_to_arr($rec,$format);                                  @v = $self->parse_to_arr($rec,$format);
204                          }                          }
205                          next if (! @v);                          if (! @v) {
206                                    $log->debug("$field <",$self->{tag},"> format: $format no values");
207    #                               next;
208                            } else {
209                                    $log->debug("$field <",$self->{tag},"> format: $format values: ", join(",", @v));
210                            }
211    
212                          if ($tag->{'sort'}) {                          if ($tag->{'sort'}) {
213                                  @v = $self->sort_arr(@v);                                  @v = $self->sort_arr(@v);
# Line 195  sub data_structure { Line 218  sub data_structure {
218                                  @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;                                  @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
219                          }                          }
220    
                         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!  
                         }  
   
221                          # delimiter will join repeatable fields                          # delimiter will join repeatable fields
222                          if ($tag->{'delimiter'}) {                          if ($tag->{'delimiter'}) {
223                                  @v = ( join($tag->{'delimiter'}, @v) );                                  @v = ( join($tag->{'delimiter'}, @v) );
# Line 216  sub data_structure { Line 230  sub data_structure {
230    
231                          foreach my $type (@types) {                          foreach my $type (@types) {
232                                  # append to previous line?                                  # append to previous line?
233                                  $log->debug("type: $type ",sub { join(" ",@v) }, $row->{'append'} || 'no append');                                  $log->debug("tag $field / $type [",sub { join(",",@v) }, "] ", $row->{'append'} || 'no append');
234                                  if ($tag->{'append'}) {                                  if ($tag->{'append'}) {
235    
236                                          # I will delimit appended part with                                          # I will delimit appended part with
# Line 257  sub data_structure { Line 271  sub data_structure {
271    
272          }          }
273    
         $log->logdie("there is no current_filename defined! Do you have filename tag in conf/normalize/?.xml") unless ($self->{'current_filename'});  
   
274          $self->{'db'}->save_ds(          $self->{'db'}->save_ds(
275                    id => $id,
276                  ds => $ds,                  ds => $ds,
277                  current_filename => $self->{'current_filename'},                  prefix => $self->{prefix},
                 headline => $self->{'headline'},  
278          ) if ($self->{'db'});          ) if ($self->{'db'});
279    
280          $log->debug("ds: ", sub { Dumper($ds) });          $log->debug("ds: ", sub { Dumper($ds) });
# Line 281  return output or nothing depending on ev Line 293  return output or nothing depending on ev
293    
294   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);
295    
296    Filters are implemented here. While simple form of filters looks like this:
297    
298      filter{name_of_filter}
299    
300    but, filters can also have variable number of parametars like this:
301    
302      filter{name_of_filter(param,param,param)}
303    
304  =cut  =cut
305    
306    my $warn_once;
307    
308  sub parse {  sub parse {
309          my $self = shift;          my $self = shift;
310    
311          my ($rec, $format_utf8, $i) = @_;          my ($rec, $format_utf8, $i, $rec_size) = @_;
312    
313          return if (! $format_utf8);          return if (! $format_utf8);
314    
# Line 300  sub parse { Line 322  sub parse {
322    
323          my @out;          my @out;
324    
325          $log->debug("format: $format");          $log->debug("format: $format [$i]");
326    
327          my $eval_code;          my $eval_code;
328          # remove eval{...} from beginning          # remove eval{...} from beginning
# Line 310  sub parse { Line 332  sub parse {
332          # remove filter{...} from beginning          # remove filter{...} from beginning
333          $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);          $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
334    
335            # did we found any (att all) field from format in row?
336            my $found_any;
337            # prefix before first field which we preserve it $found_any
338          my $prefix;          my $prefix;
339          my $all_found=0;  
340            my $f_step = 1;
341    
342          while ($format =~ s/^(.*?)(v|s)(\d+)(?:\^(\w))?//s) {          while ($format =~ s/^(.*?)(v|s)(\d+)(?:\^(\w))?//s) {
343    
344                  my $del = $1 || '';                  my $del = $1 || '';
345                  $prefix ||= $del if ($all_found == 0);                  $prefix = $del if ($f_step == 1);
346    
347                    my $fld_type = lc($2);
348    
349                  # repeatable index                  # repeatable index
350                  my $r = $i;                  my $r = $i;
351                  $r = 0 if (lc("$2") eq 's');                  if ($fld_type eq 's') {
352                            if ($found_any->{'v'}) {
353                                    $r = 0;
354                            } else {
355                                    return;
356                            }
357                    }
358    
359                  my $found = 0;                  my $found = 0;
360                  my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found);                  my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found,$rec_size);
361    
362                  if ($found) {                  if ($found) {
363                          push @out, $del;                          $found_any->{$fld_type} += $found;
364    
365                            # we will skip delimiter before first occurence of field!
366                            push @out, $del unless($found_any->{$fld_type} == 1);
367                          push @out, $tmp;                          push @out, $tmp;
                         $all_found += $found;  
368                  }                  }
369                    $f_step++;
370          }          }
371    
372          return if (! $all_found);          # test if any fields found?
373            return if (! $found_any->{'v'} && ! $found_any->{'s'});
374    
375          my $out = join('',@out);          my $out = join('',@out);
376    
# Line 352  sub parse { Line 390  sub parse {
390                  return if (! $self->_eval($eval));                  return if (! $self->_eval($eval));
391          }          }
392                    
393          if ($filter_name && $self->{'filter'}->{$filter_name}) {          if ($filter_name) {
394                  $log->debug("about to filter{$filter_name} format: $out");                  my @filter_args;
395                  $out = $self->{'filter'}->{$filter_name}->($out);                  if ($filter_name =~ s/(\w+)\((.*)\)/$1/) {
396                  return unless(defined($out));                          @filter_args = split(/,/, $2);
397                  $log->debug("filter result: $out");                  }
398                    if ($self->{'filter'}->{$filter_name}) {
399                            $log->debug("about to filter{$filter_name} format: $out with arguments: ", join(",", @filter_args));
400                            unshift @filter_args, $out;
401                            $out = $self->{'filter'}->{$filter_name}->(@filter_args);
402                            return unless(defined($out));
403                            $log->debug("filter result: $out");
404                    } elsif (! $warn_once->{$filter_name}) {
405                            $log->warn("trying to use undefined filter $filter_name");
406                            $warn_once->{$filter_name}++;
407                    }
408          }          }
409    
410          return $out;          return $out;
# Line 383  sub parse_to_arr { Line 431  sub parse_to_arr {
431          my $i = 0;          my $i = 0;
432          my @arr;          my @arr;
433    
434          while (my $v = $self->parse($rec,$format_utf8,$i++)) {          my $rec_size = { '_' => '_' };
435    
436            while (my $v = $self->parse($rec,$format_utf8,$i++,\$rec_size)) {
437                  push @arr, $v;                  push @arr, $v;
438                    warn "parse rec_size = ", Dumper($rec_size);
439          }          }
440    
441          $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 414  delimiters before fields which aren't us Line 465  delimiters before fields which aren't us
465  This method will automatically decode UTF-8 string to local code page  This method will automatically decode UTF-8 string to local code page
466  if needed.  if needed.
467    
468    There is optional parametar C<$record_size> which can be used to get sizes of
469    all C<field^subfield> combinations in this format.
470    
471     my $text = $webpac->fill_in($rec,'got: v900^a v900^x',0,\$rec_size);
472    
473  =cut  =cut
474    
475  sub fill_in {  sub fill_in {
# Line 421  sub fill_in { Line 477  sub fill_in {
477    
478          my $log = $self->_get_logger();          my $log = $self->_get_logger();
479    
480          my $rec = shift || $log->logconfess("need data record");          my ($rec,$format,$i,$rec_size) = @_;
481          my $format = shift || $log->logconfess("need format to parse");  
482            $log->logconfess("need data record") unless ($rec);
483            $log->logconfess("need format to parse") unless($format);
484    
485          # iteration (for repeatable fields)          # iteration (for repeatable fields)
486          my $i = shift || 0;          $i ||= 0;
487    
488          $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));          $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));
489    
# Line 436  sub fill_in { Line 495  sub fill_in {
495          }          }
496    
497          my $found = 0;          my $found = 0;
498            my $just_single = 1;
499    
500          my $eval_code;          my $eval_code;
501          # remove eval{...} from beginning          # remove eval{...} from beginning
# Line 447  sub fill_in { Line 507  sub fill_in {
507    
508          # do actual replacement of placeholders          # do actual replacement of placeholders
509          # repeatable fields          # repeatable fields
510          $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,$rec_size)/ges) {
511                    $just_single = 0;
512            }
513    
514          # non-repeatable fields          # non-repeatable fields
515          $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,$rec_size)/ges) {
516                    return if ($i > 0 && $just_single);
517            }
518    
519          if ($found) {          if ($found) {
520                  $log->debug("format: $format");                  $log->debug("format: $format");
# Line 466  sub fill_in { Line 531  sub fill_in {
531                  # do we have lookups?                  # do we have lookups?
532                  if ($self->{'lookup'}) {                  if ($self->{'lookup'}) {
533                          if ($self->{'lookup'}->can('lookup')) {                          if ($self->{'lookup'}->can('lookup')) {
534                                  return $self->{'lookup'}->lookup($format);                                  my @lookup = $self->{lookup}->lookup($format);
535                                    $log->debug("lookup $format", join(", ", @lookup));
536                                    return @lookup;
537                          } else {                          } else {
538                                  $log->warn("Have lookup object but can't invoke lookup method");                                  $log->warn("Have lookup object but can't invoke lookup method");
539                          }                          }
# Line 502  sub fill_in_to_arr { Line 569  sub fill_in_to_arr {
569          my $i = 0;          my $i = 0;
570          my @arr;          my @arr;
571    
572          while (my @v = $self->fill_in($rec,$format_utf8,$i++)) {          my $rec_size;
573                  push @arr, @v;  
574            while (my $v = $self->fill_in($rec,$format_utf8,$i,\$rec_size)) {
575                    push @arr, $v;
576                    warn "rec_size = ", Dumper($rec_size);
577          }          }
578    
579          $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 516  sub fill_in_to_arr { Line 586  sub fill_in_to_arr {
586    
587  Returns value from record.  Returns value from record.
588    
589   my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);   my $text = $self->get_data(\$rec,$f,$sf,$i,\$found,\$rec_size);
590    
591    Required arguments are:
592    
593    =over 8
594    
595    =item C<$rec>
596    
597    record reference
598    
599    =item C<$f>
600    
601    field
602    
603  Arguments are:  =item C<$sf>
 record reference C<$rec>,  
 field C<$f>,  
 optional subfiled C<$sf>,  
 index for repeatable values C<$i>.  
604    
605  Optinal variable C<$found> will be incremeted if there  optional subfield
 is field.  
606    
607  Returns value or empty string.  =item C<$i>
608    
609    index offset for repeatable values ( 0 ... $rec_size->{'400^a'} )
610    
611    =item C<$found>
612    
613    optional variable that will be incremeted if preset
614    
615    =item C<$rec_size>
616    
617    hash to hold maximum occurances of C<field^subfield> combinations
618    (which can be accessed using keys in same format)
619    
620    =back
621    
622    Returns value or empty string, updates C<$found> and C<rec_size>
623    if present.
624    
625  =cut  =cut
626    
627  sub get_data {  sub get_data {
628          my $self = shift;          my $self = shift;
629    
630          my ($rec,$f,$sf,$i,$found) = @_;          my ($rec,$f,$sf,$i,$found,$cache) = @_;
631    
632          if ($$rec->{$f}) {          return '' unless ($$rec->{$f} && ref($$rec->{$f}) eq 'ARRAY');
633                  return '' if (! $$rec->{$f}->[$i]);  
634            if (defined($$cache)) {
635                    $$cache->{ $f . ( $sf ? '^' . $sf : '' ) } ||= scalar @{ $$rec->{$f} };
636            }
637    
638            return '' unless ($$rec->{$f}->[$i]);
639    
640            {
641                  no strict 'refs';                  no strict 'refs';
642                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {                  if (defined($sf)) {
643                          $$found++ if (defined($$found));                          $$found++ if (defined($$found) && $$rec->{$f}->[$i]->{$sf});
644                          return $$rec->{$f}->[$i]->{$sf};                          return $$rec->{$f}->[$i]->{$sf};
645                  } elsif (! $sf && $$rec->{$f}->[$i]) {                  } else {
646                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
647                          # it still might have subfield, just                          # it still might have subfields, just
648                          # not specified, so we'll dump all                          # not specified, so we'll dump some debug info
649                          if ($$rec->{$f}->[$i] =~ /HASH/o) {                          if ($$rec->{$f}->[$i] =~ /HASH/o) {
650                                  my $out;                                  my $out;
651                                  foreach my $k (keys %{$$rec->{$f}->[$i]}) {                                  foreach my $k (keys %{$$rec->{$f}->[$i]}) {
652                                          $out .= $$rec->{$f}->[$i]->{$k}." ";                                          $out .= '$' . $k .':' . $$rec->{$f}->[$i]->{$k}." ";
653                                  }                                  }
654                                  return $out;                                  return $out;
655                          } else {                          } else {
656                                  return $$rec->{$f}->[$i];                                  return $$rec->{$f}->[$i];
657                          }                          }
                 } else {  
                         return '';  
658                  }                  }
         } else {  
                 return '';  
659          }          }
660  }  }
661    
# Line 680  under the same terms as Perl itself. Line 776  under the same terms as Perl itself.
776    
777  =cut  =cut
778    
779  1; # End of WebPAC::DB  1; # End of WebPAC::Normalize

Legend:
Removed from v.74  
changed lines
  Added in v.371

  ViewVC Help
Powered by ViewVC 1.1.26