/[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 260 by dpavlin, Fri Dec 16 14:40:55 2005 UTC revision 368 by dpavlin, Sun Jan 8 20:32:06 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.06  Version 0.08
17    
18  =cut  =cut
19    
20  our $VERSION = '0.06';  our $VERSION = '0.08';
21    
22  =head1 SYNOPSIS  =head1 SYNOPSIS
23    
# Line 123  sub new { Line 125  sub new {
125    
126          $log->debug("using lookup regex: ", $self->{lookup_regex}) if ($r && $l);          $log->debug("using lookup regex: ", $self->{lookup_regex}) if ($r && $l);
127    
128          if ($self->{filter} && ! $self->{filter}->{regex}) {          if (! $self->{filter} || ! $self->{filter}->{regex}) {
129                  $log->debug("adding built-in filter regex");                  $log->debug("adding built-in filter regex");
130                  $self->{filter}->{regex} = sub {                  $self->{filter}->{regex} = sub {
131                          my ($val, $regex) = @_;                          my ($val, $regex) = @_;
# Line 157  sub data_structure { Line 159  sub data_structure {
159    
160          $log->debug("data_structure rec = ", sub { Dumper($rec) });          $log->debug("data_structure rec = ", sub { Dumper($rec) });
161    
162          $log->logdie("need unique ID (mfn) in field 000 of record ", sub { Dumper($rec) } ) unless (defined($rec->{'000'}));          $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!");          my $id = $rec->{'000'}->[0] || $log->logdie("field 000 isn't array!");
165    
# Line 170  sub data_structure { Line 172  sub data_structure {
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 197  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 228  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 301  but, filters can also have variable numb Line 303  but, filters can also have variable numb
303    
304  =cut  =cut
305    
306    my $warn_once;
307    
308  sub parse {  sub parse {
309          my $self = shift;          my $self = shift;
310    
# Line 318  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 328  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);
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 381  sub parse { Line 401  sub parse {
401                          $out = $self->{'filter'}->{$filter_name}->(@filter_args);                          $out = $self->{'filter'}->{$filter_name}->(@filter_args);
402                          return unless(defined($out));                          return unless(defined($out));
403                          $log->debug("filter result: $out");                          $log->debug("filter result: $out");
404                  } else {                  } elsif (! $warn_once->{$filter_name}) {
405                          $log->warn("trying to use undefined filter $filter_name");                          $log->warn("trying to use undefined filter $filter_name");
406                            $warn_once->{$filter_name}++;
407                  }                  }
408          }          }
409    
# Line 463  sub fill_in { Line 484  sub fill_in {
484          }          }
485    
486          my $found = 0;          my $found = 0;
487            my $just_single = 1;
488    
489          my $eval_code;          my $eval_code;
490          # remove eval{...} from beginning          # remove eval{...} from beginning
# Line 474  sub fill_in { Line 496  sub fill_in {
496    
497          # do actual replacement of placeholders          # do actual replacement of placeholders
498          # repeatable fields          # repeatable fields
499          $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) {
500                    $just_single = 0;
501            }
502    
503          # non-repeatable fields          # non-repeatable fields
504          $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) {
505                    return if ($i > 0 && $just_single);
506            }
507    
508          if ($found) {          if ($found) {
509                  $log->debug("format: $format");                  $log->debug("format: $format");
# Line 531  sub fill_in_to_arr { Line 558  sub fill_in_to_arr {
558          my $i = 0;          my $i = 0;
559          my @arr;          my @arr;
560    
561          while (my @v = $self->fill_in($rec,$format_utf8,$i++)) {          while (my $v = $self->fill_in($rec,$format_utf8,$i++)) {
562                  push @arr, @v;                  push @arr, $v;
563          }          }
564    
565          $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 545  sub fill_in_to_arr { Line 572  sub fill_in_to_arr {
572    
573  Returns value from record.  Returns value from record.
574    
575   my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);   my $text = $self->get_data(\$rec,$f,$sf,$i,\$found,\$fld_occurances);
576    
577    Required arguments are:
578    
579    =over 8
580    
581    =item C<$rec>
582    
583  Arguments are:  record reference
 record reference C<$rec>,  
 field C<$f>,  
 optional subfiled C<$sf>,  
 index for repeatable values C<$i>.  
584    
585  Optinal variable C<$found> will be incremeted if there  =item C<$f>
 is field.  
586    
587  Returns value or empty string.  field
588    
589    =item C<$sf>
590    
591    optional subfield
592    
593    =item C<$i>
594    
595    index offset for repeatable values ( 0 ... $#occurances )
596    
597    =item C<$found>
598    
599    optional variable that will be incremeted if preset
600    
601    =item C<$fld_occurances>
602    
603    hash to hold maximum occurances of C<field\tsubfield> combinations
604    (which can be accessed using keys in same format)
605    
606    =back
607    
608    Returns value or empty string, updates C<$found> and C<fld_occurences>
609    if present.
610    
611  =cut  =cut
612    
613  sub get_data {  sub get_data {
614          my $self = shift;          my $self = shift;
615    
616          my ($rec,$f,$sf,$i,$found) = @_;          my ($rec,$f,$sf,$i,$found,$cache) = @_;
617    
618            return '' unless ($$rec->{$f} && ref($$rec->{$f}) eq 'ARRAY');
619    
620            if (defined($$cache)) {
621                    $$cache->{"$f\t$sf"} ||= $$#rec->{$f};
622            }
623    
624            return '' unless ($$rec->{$f}->[$i]);
625    
626          if ($$rec->{$f}) {          {
                 return '' if (! $$rec->{$f}->[$i]);  
627                  no strict 'refs';                  no strict 'refs';
628                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {                  if (defined($sf)) {
629                          $$found++ if (defined($$found));                          $$found++ if (defined($$found) && $$rec->{$f}->[$i]->{$sf});
630                          return $$rec->{$f}->[$i]->{$sf};                          return $$rec->{$f}->[$i]->{$sf};
631                  } elsif (! $sf && $$rec->{$f}->[$i]) {                  } else {
632                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
633                          # it still might have subfield, just                          # it still might have subfields, just
634                          # not specified, so we'll dump all                          # not specified, so we'll dump some debug info
635                          if ($$rec->{$f}->[$i] =~ /HASH/o) {                          if ($$rec->{$f}->[$i] =~ /HASH/o) {
636                                  my $out;                                  my $out;
637                                  foreach my $k (keys %{$$rec->{$f}->[$i]}) {                                  foreach my $k (keys %{$$rec->{$f}->[$i]}) {
638                                          $out .= $$rec->{$f}->[$i]->{$k}." ";                                          $out .= '$' . $k .':' . $$rec->{$f}->[$i]->{$k}." ";
639                                  }                                  }
640                                  return $out;                                  return $out;
641                          } else {                          } else {
642                                  return $$rec->{$f}->[$i];                                  return $$rec->{$f}->[$i];
643                          }                          }
                 } else {  
                         return '';  
644                  }                  }
         } else {  
                 return '';  
645          }          }
646  }  }
647    

Legend:
Removed from v.260  
changed lines
  Added in v.368

  ViewVC Help
Powered by ViewVC 1.1.26