/[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 375 by dpavlin, Sun Jan 8 22:21:24 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 494  sub fill_in { Line 473  sub fill_in {
473    
474          # do actual replacement of placeholders          # do actual replacement of placeholders
475          # repeatable fields          # repeatable fields
476          if ($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) {
477                  $just_single = 0;                  $just_single = 0;
478          }          }
479    
480          # non-repeatable fields          # non-repeatable fields
481          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) {
482                  return if ($i > 0 && $just_single);                  return if ($i > 0 && $just_single);
483          }          }
484    
# Line 533  sub fill_in { Line 512  sub fill_in {
512  }  }
513    
514    
515  =head2 fill_in_to_arr  =head2 _rec_to_arr
516    
517  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
518  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
519  C<fill_id>ed.  C<paste>d or C<fill_id>ed. Last argument is name of operation: C<paste> or C<fill_in>.
520    
521   my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]');   my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]','paste');
522    
523  =cut  =cut
524    
525  sub fill_in_to_arr {  sub _rec_to_arr {
526          my $self = shift;          my $self = shift;
527    
528          my ($rec, $format_utf8) = @_;          my ($rec, $format_utf8, $code) = @_;
529    
530          my $log = $self->_get_logger();          my $log = $self->_get_logger();
531    
532          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
533          return if (! $format_utf8);          return if (! $format_utf8);
534    
535            $log->debug("using $code on $format_utf8");
536    
537          my $i = 0;          my $i = 0;
538            my $max = 0;
539          my @arr;          my @arr;
540            my $rec_size = {};
541    
542          while (my $v = $self->fill_in($rec,$format_utf8,$i++)) {          while ($i <= $max) {
543                  push @arr, $v;                  my @v = $self->$code($rec,$format_utf8,$i++,\$rec_size);
544                    if ($rec_size) {
545                            foreach my $f (keys %{ $rec_size }) {
546                                    $max = $rec_size->{$f} if ($rec_size->{$f} > $max);
547                            }
548                            $log->debug("max set to $max");
549                            undef $rec_size;
550                    }
551                    if (@v) {
552                            push @arr, @v;
553                    } else {
554                            push @arr, '' if ($max > $i);
555                    }
556          }          }
557    
558          $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 565  sub fill_in_to_arr {
565    
566  Returns value from record.  Returns value from record.
567    
568   my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);   my $text = $self->get_data(\$rec,$f,$sf,$i,\$found,\$rec_size);
569    
570    Required arguments are:
571    
572    =over 8
573    
574    =item C<$rec>
575    
576    record reference
577    
578    =item C<$f>
579    
580    field
581    
582    =item C<$sf>
583    
584    optional subfield
585    
586    =item C<$i>
587    
588  Arguments are:  index offset for repeatable values ( 0 ... $rec_size->{'400^a'} )
 record reference C<$rec>,  
 field C<$f>,  
 optional subfiled C<$sf>,  
 index for repeatable values C<$i>.  
589    
590  Optinal variable C<$found> will be incremeted if there  =item C<$found>
 is field.  
591    
592  Returns value or empty string.  optional variable that will be incremeted if preset
593    
594    =item C<$rec_size>
595    
596    hash to hold maximum occurances of C<field^subfield> combinations
597    (which can be accessed using keys in same format)
598    
599    =back
600    
601    Returns value or empty string, updates C<$found> and C<rec_size>
602    if present.
603    
604  =cut  =cut
605    
606  sub get_data {  sub get_data {
607          my $self = shift;          my $self = shift;
608    
609          my ($rec,$f,$sf,$i,$found) = @_;          my ($rec,$f,$sf,$i,$found,$cache) = @_;
610    
611            return '' unless ($$rec->{$f} && ref($$rec->{$f}) eq 'ARRAY');
612    
613          if ($$rec->{$f}) {          if (defined($$cache)) {
614                  return '' if (! $$rec->{$f}->[$i]);                  $$cache->{ $f . ( $sf ? '^' . $sf : '' ) } ||= scalar @{ $$rec->{$f} };
615            }
616    
617            return '' unless ($$rec->{$f}->[$i]);
618    
619            {
620                  no strict 'refs';                  no strict 'refs';
621                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {                  if (defined($sf)) {
622                          $$found++ if (defined($$found));                          $$found++ if (defined($$found) && $$rec->{$f}->[$i]->{$sf});
623                          return $$rec->{$f}->[$i]->{$sf};                          return $$rec->{$f}->[$i]->{$sf};
624                  } elsif (! $sf && $$rec->{$f}->[$i]) {                  } else {
625                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
626                          # it still might have subfield, just                          # it still might have subfields, just
627                          # not specified, so we'll dump all                          # not specified, so we'll dump some debug info
628                          if ($$rec->{$f}->[$i] =~ /HASH/o) {                          if ($$rec->{$f}->[$i] =~ /HASH/o) {
629                                  my $out;                                  my $out;
630                                  foreach my $k (keys %{$$rec->{$f}->[$i]}) {                                  foreach my $k (keys %{$$rec->{$f}->[$i]}) {
631                                          my $v = $$rec->{$f}->[$i]->{$k};                                          $out .= '$' . $k .':' . $$rec->{$f}->[$i]->{$k}." ";
                                         $out .= "$v " if ($v);  
632                                  }                                  }
633                                  return $out;                                  return $out;
634                          } else {                          } else {
635                                  return $$rec->{$f}->[$i];                                  return $$rec->{$f}->[$i];
636                          }                          }
                 } else {  
                         return '';  
637                  }                  }
         } else {  
                 return '';  
638          }          }
639  }  }
640    

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

  ViewVC Help
Powered by ViewVC 1.1.26