/[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 364 by dpavlin, Sun Jan 8 20:27:11 2006 UTC revision 397 by dpavlin, Wed Feb 15 15:54:12 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 196  sub data_structure { Line 198  sub data_structure {
198    
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->_rec_to_arr($rec,$format,'fill_in');
202                          } else {                          } else {
203                                  @v = $self->parse_to_arr($rec,$format);                                  @v = $self->_rec_to_arr($rec,$format,'parse');
204                          }                          }
205                          if (! @v) {                          if (! @v) {
206                                  $log->debug("$field <",$self->{tag},"> format: $format no values");                                  $log->debug("$field <",$self->{tag},"> format: $format no values");
207  #                               next;                                  next;
208                          } else {                          } else {
209                                  $log->debug("$field <",$self->{tag},"> format: $format values: ", join(",", @v));                                  $log->debug("$field <",$self->{tag},"> format: $format values: ", join(",", @v));
210                          }                          }
# Line 306  my $warn_once; Line 308  my $warn_once;
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 355  sub parse { Line 357  sub parse {
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                          $found_any->{$fld_type} += $found;                          $found_any->{$fld_type} += $found;
# Line 408  sub parse { Line 410  sub parse {
410          return $out;          return $out;
411  }  }
412    
 =head2 parse_to_arr  
   
 Similar to C<parse>, but returns array of all repeatable fields  
   
  my @arr = $webpac->parse_to_arr($rec,'v250^a');  
   
 =cut  
   
 sub parse_to_arr {  
         my $self = shift;  
   
         my ($rec, $format_utf8) = @_;  
   
         my $log = $self->_get_logger();  
   
         $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);  
         return if (! $format_utf8);  
   
         my $i = 0;  
         my @arr;  
   
         while (my $v = $self->parse($rec,$format_utf8,$i++)) {  
                 push @arr, $v;  
         }  
   
         $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);  
   
         return @arr;  
 }  
   
   
413  =head2 fill_in  =head2 fill_in
414    
415  Workhourse of all: takes record from in-memory structure of database and  Workhourse of all: takes record from in-memory structure of database and
# Line 460  delimiters before fields which aren't us Line 431  delimiters before fields which aren't us
431  This method will automatically decode UTF-8 string to local code page  This method will automatically decode UTF-8 string to local code page
432  if needed.  if needed.
433    
434    There is optional parametar C<$record_size> which can be used to get sizes of
435    all C<field^subfield> combinations in this format.
436    
437     my $text = $webpac->fill_in($rec,'got: v900^a v900^x',0,\$rec_size);
438    
439  =cut  =cut
440    
441  sub fill_in {  sub fill_in {
# Line 467  sub fill_in { Line 443  sub fill_in {
443    
444          my $log = $self->_get_logger();          my $log = $self->_get_logger();
445    
446          my $rec = shift || $log->logconfess("need data record");          my ($rec,$format,$i,$rec_size) = @_;
447          my $format = shift || $log->logconfess("need format to parse");  
448            $log->logconfess("need data record") unless ($rec);
449            $log->logconfess("need format to parse") unless($format);
450    
451          # iteration (for repeatable fields)          # iteration (for repeatable fields)
452          my $i = shift || 0;          $i ||= 0;
453    
454          $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));
455    
# Line 492  sub fill_in { Line 471  sub fill_in {
471          # remove filter{...} from beginning          # remove filter{...} from beginning
472          $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);          $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
473    
474          # do actual replacement of placeholders          {
475          # repeatable fields                  # fix warnings
476          if ($format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges) {                  no warnings 'uninitialized';
477                  $just_single = 0;  
478          }                  # do actual replacement of placeholders
479                    # repeatable fields
480                    if ($format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found,$rec_size)/ges) {
481                            $just_single = 0;
482                    }
483    
484          # non-repeatable fields                  # non-repeatable fields
485          if ($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) {
486                  return if ($i > 0 && $just_single);                          return if ($i > 0 && $just_single);
487                    }
488          }          }
489    
490          if ($found) {          if ($found) {
# Line 533  sub fill_in { Line 517  sub fill_in {
517  }  }
518    
519    
520  =head2 fill_in_to_arr  =head2 _rec_to_arr
521    
522  Similar to C<fill_in>, but returns array of all repeatable fields. Usable  Similar to C<parse> and C<fill_in>, but returns array of all repeatable fields. Usable
523  for fields which have lookups, so they shouldn't be parsed but rather  for fields which have lookups, so they shouldn't be parsed but rather
524  C<fill_id>ed.  C<paste>d or C<fill_id>ed. Last argument is name of operation: C<paste> or C<fill_in>.
525    
526   my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]');   my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]','paste');
527    
528  =cut  =cut
529    
530  sub fill_in_to_arr {  sub _rec_to_arr {
531          my $self = shift;          my $self = shift;
532    
533          my ($rec, $format_utf8) = @_;          my ($rec, $format_utf8, $code) = @_;
534    
535          my $log = $self->_get_logger();          my $log = $self->_get_logger();
536    
537          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
538          return if (! $format_utf8);          return if (! $format_utf8);
539    
540            $log->debug("using $code on $format_utf8");
541    
542          my $i = 0;          my $i = 0;
543            my $max = 0;
544          my @arr;          my @arr;
545            my $rec_size = {};
546    
547          while (my $v = $self->fill_in($rec,$format_utf8,$i++)) {          while ($i <= $max) {
548                  push @arr, $v;                  my @v = $self->$code($rec,$format_utf8,$i++,\$rec_size);
549                    if ($rec_size) {
550                            foreach my $f (keys %{ $rec_size }) {
551                                    $max = $rec_size->{$f} if ($rec_size->{$f} > $max);
552                            }
553                            $log->debug("max set to $max");
554                            undef $rec_size;
555                    }
556                    if (@v) {
557                            push @arr, @v;
558                    } else {
559                            push @arr, '' if ($max > $i);
560                    }
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 570  sub fill_in_to_arr { Line 570  sub fill_in_to_arr {
570    
571  Returns value from record.  Returns value from record.
572    
573   my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);   my $text = $self->get_data(\$rec,$f,$sf,$i,\$found,\$rec_size);
574    
575    Required arguments are:
576    
577    =over 8
578    
579    =item C<$rec>
580    
581    record reference
582    
583    =item C<$f>
584    
585    field
586    
587    =item C<$sf>
588    
589    optional subfield
590    
591  Arguments are:  =item C<$i>
 record reference C<$rec>,  
 field C<$f>,  
 optional subfiled C<$sf>,  
 index for repeatable values C<$i>.  
592    
593  Optinal variable C<$found> will be incremeted if there  index offset for repeatable values ( 0 ... $rec_size->{'400^a'} )
 is field.  
594    
595  Returns value or empty string.  =item C<$found>
596    
597    optional variable that will be incremeted if preset
598    
599    =item C<$rec_size>
600    
601    hash to hold maximum occurances of C<field^subfield> combinations
602    (which can be accessed using keys in same format)
603    
604    =back
605    
606    Returns value or empty string, updates C<$found> and C<rec_size>
607    if present.
608    
609  =cut  =cut
610    
611  sub get_data {  sub get_data {
612          my $self = shift;          my $self = shift;
613    
614          my ($rec,$f,$sf,$i,$found) = @_;          my ($rec,$f,$sf,$i,$found,$cache) = @_;
615    
616            return '' unless ($$rec->{$f} && ref($$rec->{$f}) eq 'ARRAY');
617    
618          if ($$rec->{$f}) {          if (defined($$cache)) {
619                  return '' if (! $$rec->{$f}->[$i]);                  $$cache->{ $f . ( $sf ? '^' . $sf : '' ) } ||= scalar @{ $$rec->{$f} };
620            }
621    
622            return '' unless ($$rec->{$f}->[$i]);
623    
624            {
625                  no strict 'refs';                  no strict 'refs';
626                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {                  if (defined($sf)) {
627                          $$found++ if (defined($$found));                          $$found++ if (defined($$found) && $$rec->{$f}->[$i]->{$sf});
628                          return $$rec->{$f}->[$i]->{$sf};                          return $$rec->{$f}->[$i]->{$sf};
629                  } elsif (! $sf && $$rec->{$f}->[$i]) {                  } else {
630                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
631                          # it still might have subfield, just                          # it still might have subfields, just
632                          # not specified, so we'll dump all                          # not specified, so we'll dump some debug info
633                          if ($$rec->{$f}->[$i] =~ /HASH/o) {                          if ($$rec->{$f}->[$i] =~ /HASH/o) {
634                                  my $out;                                  my $out;
635                                  foreach my $k (keys %{$$rec->{$f}->[$i]}) {                                  foreach my $k (keys %{$$rec->{$f}->[$i]}) {
636                                          my $v = $$rec->{$f}->[$i]->{$k};                                          $out .= '$' . $k .':' . $$rec->{$f}->[$i]->{$k}." ";
                                         $out .= "$v " if ($v);  
637                                  }                                  }
638                                  return $out;                                  return $out;
639                          } else {                          } else {
640                                  return $$rec->{$f}->[$i];                                  return $$rec->{$f}->[$i];
641                          }                          }
                 } else {  
                         return '';  
642                  }                  }
         } else {  
                 return '';  
643          }          }
644  }  }
645    

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

  ViewVC Help
Powered by ViewVC 1.1.26