/[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 368 by dpavlin, Sun Jan 8 20:32:06 2006 UTC revision 433 by dpavlin, Mon Apr 17 16:01:12 2006 UTC
# Line 13  WebPAC::Normalize - data mungling for no Line 13  WebPAC::Normalize - data mungling for no
13    
14  =head1 VERSION  =head1 VERSION
15    
16  Version 0.08  Version 0.09
17    
18  =cut  =cut
19    
20  our $VERSION = '0.08';  our $VERSION = '0.09';
21    
22  =head1 SYNOPSIS  =head1 SYNOPSIS
23    
# Line 137  sub new { Line 137  sub new {
137          $self ? return $self : return undef;          $self ? return $self : return undef;
138  }  }
139    
140    =head2 all_tags
141    
142    Returns all tags in document in specified order
143    
144      my $sorted_tags = $self->all_tags();
145    
146    =cut
147    
148    sub all_tags {
149            my $self = shift;
150    
151            if (! $self->{_tags_by_order}) {
152    
153                    my $log = $self->_get_logger;
154                    # sanity check
155                    $log->logdie("can't find self->{inport_xml}->{indexer}") unless ($self->{import_xml}->{indexer});
156    
157                    my @tags = keys %{ $self->{'import_xml'}->{'indexer'}};
158                    $log->debug("unsorted tags: " . join(", ", @tags));
159    
160                    @tags = sort { $self->_sort_by_order } @tags;
161    
162                    $log->debug("sorted tags: " . join(",", @tags) );
163    
164                    $self->{_tags_by_order} = \@tags;
165            }
166    
167            return $self->{_tags_by_order};
168    }
169    
170    
171    
172  =head2 data_structure  =head2 data_structure
173    
# Line 172  sub data_structure { Line 203  sub data_structure {
203                  $log->debug("cache miss, creating");                  $log->debug("cache miss, creating");
204          }          }
205    
206          my @sorted_tags;          my $tags = $self->all_tags();
         if ($self->{tags_by_order}) {  
                 @sorted_tags = @{$self->{tags_by_order}};  
         } else {  
                 @sorted_tags = sort { $self->_sort_by_order } keys %{$self->{'import_xml'}->{'indexer'}};  
                 $self->{tags_by_order} = \@sorted_tags;  
         }  
207    
208          my $ds;          $log->debug("tags: ",sub { join(", ",@{ $tags }) });
209    
210          $log->debug("tags: ",sub { join(", ",@sorted_tags) });          my $ds;
211    
212          foreach my $field (@sorted_tags) {          foreach my $field (@{ $tags }) {
213    
214                  my $row;                  my $row;
215    
# Line 198  sub data_structure { Line 223  sub data_structure {
223    
224                          my @v;                          my @v;
225                          if ($self->{'lookup_regex'} && $format =~ $self->{'lookup_regex'}) {                          if ($self->{'lookup_regex'} && $format =~ $self->{'lookup_regex'}) {
226                                  @v = $self->fill_in_to_arr($rec,$format);                                  @v = $self->_rec_to_arr($rec,$format,'fill_in');
227                          } else {                          } else {
228                                  @v = $self->parse_to_arr($rec,$format);                                  @v = $self->_rec_to_arr($rec,$format,'parse');
229                          }                          }
230                          if (! @v) {                          if (! @v) {
231                                  $log->debug("$field <",$self->{tag},"> format: $format no values");                                  $log->debug("$field <",$self->{tag},"> format: $format no values");
232  #                               next;                                  next;
233                          } else {                          } else {
234                                  $log->debug("$field <",$self->{tag},"> format: $format values: ", join(",", @v));                                  $log->debug("$field <",$self->{tag},"> format: $format values: ", join(",", @v));
235                          }                          }
# Line 308  my $warn_once; Line 333  my $warn_once;
333  sub parse {  sub parse {
334          my $self = shift;          my $self = shift;
335    
336          my ($rec, $format_utf8, $i) = @_;          my ($rec, $format_utf8, $i, $rec_size) = @_;
337    
338          return if (! $format_utf8);          return if (! $format_utf8);
339    
# Line 357  sub parse { Line 382  sub parse {
382                  }                  }
383    
384                  my $found = 0;                  my $found = 0;
385                  my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found);                  my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found,$rec_size);
386    
387                  if ($found) {                  if ($found) {
388                          $found_any->{$fld_type} += $found;                          $found_any->{$fld_type} += $found;
# Line 410  sub parse { Line 435  sub parse {
435          return $out;          return $out;
436  }  }
437    
 =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;  
 }  
   
   
438  =head2 fill_in  =head2 fill_in
439    
440  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 462  delimiters before fields which aren't us Line 456  delimiters before fields which aren't us
456  This method will automatically decode UTF-8 string to local code page  This method will automatically decode UTF-8 string to local code page
457  if needed.  if needed.
458    
459    There is optional parametar C<$record_size> which can be used to get sizes of
460    all C<field^subfield> combinations in this format.
461    
462     my $text = $webpac->fill_in($rec,'got: v900^a v900^x',0,\$rec_size);
463    
464  =cut  =cut
465    
466  sub fill_in {  sub fill_in {
# Line 469  sub fill_in { Line 468  sub fill_in {
468    
469          my $log = $self->_get_logger();          my $log = $self->_get_logger();
470    
471          my $rec = shift || $log->logconfess("need data record");          my ($rec,$format,$i,$rec_size) = @_;
472          my $format = shift || $log->logconfess("need format to parse");  
473            $log->logconfess("need data record") unless ($rec);
474            $log->logconfess("need format to parse") unless($format);
475    
476          # iteration (for repeatable fields)          # iteration (for repeatable fields)
477          my $i = shift || 0;          $i ||= 0;
478    
479          $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));
480    
# Line 494  sub fill_in { Line 496  sub fill_in {
496          # remove filter{...} from beginning          # remove filter{...} from beginning
497          $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);          $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
498    
499          # do actual replacement of placeholders          {
500          # repeatable fields                  # fix warnings
501          if ($format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges) {                  no warnings 'uninitialized';
502                  $just_single = 0;  
503          }                  # do actual replacement of placeholders
504                    # repeatable fields
505                    if ($format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found,$rec_size)/ges) {
506                            $just_single = 0;
507                    }
508    
509          # non-repeatable fields                  # non-repeatable fields
510          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) {
511                  return if ($i > 0 && $just_single);                          return if ($i > 0 && $just_single);
512                    }
513          }          }
514    
515          if ($found) {          if ($found) {
# Line 535  sub fill_in { Line 542  sub fill_in {
542  }  }
543    
544    
545  =head2 fill_in_to_arr  =head2 _rec_to_arr
546    
547  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
548  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
549  C<fill_id>ed.  C<paste>d or C<fill_id>ed. Last argument is name of operation: C<paste> or C<fill_in>.
550    
551   my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]');   my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]','paste');
552    
553  =cut  =cut
554    
555  sub fill_in_to_arr {  sub _rec_to_arr {
556          my $self = shift;          my $self = shift;
557    
558          my ($rec, $format_utf8) = @_;          my ($rec, $format_utf8, $code) = @_;
559    
560          my $log = $self->_get_logger();          my $log = $self->_get_logger();
561    
562          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
563          return if (! $format_utf8);          return if (! $format_utf8);
564    
565            $log->debug("using $code on $format_utf8");
566    
567          my $i = 0;          my $i = 0;
568            my $max = 0;
569          my @arr;          my @arr;
570            my $rec_size = {};
571    
572          while (my $v = $self->fill_in($rec,$format_utf8,$i++)) {          while ($i <= $max) {
573                  push @arr, $v;                  my @v = $self->$code($rec,$format_utf8,$i++,\$rec_size);
574                    if ($rec_size) {
575                            foreach my $f (keys %{ $rec_size }) {
576                                    $max = $rec_size->{$f} if ($rec_size->{$f} > $max);
577                            }
578                            $log->debug("max set to $max");
579                            undef $rec_size;
580                    }
581                    if (@v) {
582                            push @arr, @v;
583                    } else {
584                            push @arr, '' if ($max > $i);
585                    }
586          }          }
587    
588          $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 572  sub fill_in_to_arr { Line 595  sub fill_in_to_arr {
595    
596  Returns value from record.  Returns value from record.
597    
598   my $text = $self->get_data(\$rec,$f,$sf,$i,\$found,\$fld_occurances);   my $text = $self->get_data(\$rec,$f,$sf,$i,\$found,\$rec_size);
599    
600  Required arguments are:  Required arguments are:
601    
# Line 592  optional subfield Line 615  optional subfield
615    
616  =item C<$i>  =item C<$i>
617    
618  index offset for repeatable values ( 0 ... $#occurances )  index offset for repeatable values ( 0 ... $rec_size->{'400^a'} )
619    
620  =item C<$found>  =item C<$found>
621    
622  optional variable that will be incremeted if preset  optional variable that will be incremeted if preset
623    
624  =item C<$fld_occurances>  =item C<$rec_size>
625    
626  hash to hold maximum occurances of C<field\tsubfield> combinations  hash to hold maximum occurances of C<field^subfield> combinations
627  (which can be accessed using keys in same format)  (which can be accessed using keys in same format)
628    
629  =back  =back
630    
631  Returns value or empty string, updates C<$found> and C<fld_occurences>  Returns value or empty string, updates C<$found> and C<rec_size>
632  if present.  if present.
633    
634  =cut  =cut
# Line 618  sub get_data { Line 641  sub get_data {
641          return '' unless ($$rec->{$f} && ref($$rec->{$f}) eq 'ARRAY');          return '' unless ($$rec->{$f} && ref($$rec->{$f}) eq 'ARRAY');
642    
643          if (defined($$cache)) {          if (defined($$cache)) {
644                  $$cache->{"$f\t$sf"} ||= $$#rec->{$f};                  $$cache->{ $f . ( $sf ? '^' . $sf : '' ) } ||= scalar @{ $$rec->{$f} };
645          }          }
646    
647          return '' unless ($$rec->{$f}->[$i]);          return '' unless ($$rec->{$f}->[$i]);
Legend:
Removed from v.368  
changed lines
  Added in v.433
  ViewVC Help
Powered by ViewVC 1.1.26