/[webpac]/trunk2/lib/WebPAC.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 /trunk2/lib/WebPAC.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 372 by dpavlin, Sat Jun 19 18:16:20 2004 UTC revision 374 by dpavlin, Sun Jun 20 16:57:52 2004 UTC
# Line 12  use Log::Log4perl qw(get_logger :levels) Line 12  use Log::Log4perl qw(get_logger :levels)
12    
13  use Data::Dumper;  use Data::Dumper;
14    
15    #my $LOOKUP_REGEX = '\[[^\[\]]+\]';
16    #my $LOOKUP_REGEX_SAVE = '\[([^\[\]]+)\]';
17    my $LOOKUP_REGEX = 'lookup{[^\{\}]+}';
18    my $LOOKUP_REGEX_SAVE = 'lookup{([^\{\}]+)}';
19    
20  =head1 NAME  =head1 NAME
21    
22  WebPAC - base class for WebPAC  WebPAC - base class for WebPAC
# Line 183  sub open_isis { Line 188  sub open_isis {
188    
189                                          push @{$self->{'data'}->{$mfn}->{$k}}, $val;                                          push @{$self->{'data'}->{$mfn}->{$k}}, $val;
190                                  }                                  }
191                            } else {
192                                    push @{$self->{'data'}->{$mfn}->{'000'}}, $mfn;
193                          }                          }
194    
195                  }                  }
# Line 217  sub fetch_rec { Line 224  sub fetch_rec {
224    
225          if ($mfn > $self->{'max_mfn'}) {          if ($mfn > $self->{'max_mfn'}) {
226                  $self->{'current_mfn'} = $self->{'max_mfn'};                  $self->{'current_mfn'} = $self->{'max_mfn'};
227                    $log->debug("at EOF");
228                  return;                  return;
229          }          }
230    
# Line 255  sub open_import_xml { Line 263  sub open_import_xml {
263    
264          $self->{'import_xml'} = XMLin($f,          $self->{'import_xml'} = XMLin($f,
265                  ForceArray => [ $self->{'tag'}, 'config', 'format' ],                  ForceArray => [ $self->{'tag'}, 'config', 'format' ],
                 ForceContent => 1  
266          );          );
267    
268  }  }
# Line 284  sub create_lookup { Line 291  sub create_lookup {
291                          my $key = $self->fill_in($rec,$i->{'key'});                          my $key = $self->fill_in($rec,$i->{'key'});
292                          my @val = $self->fill_in($rec,$i->{'val'});                          my @val = $self->fill_in($rec,$i->{'val'});
293                          if ($key && @val && eval $eval) {                          if ($key && @val && eval $eval) {
294                                    $log->debug("stored $key = ",sub { join(" | ",@val) });
295                                  push @{$self->{'lookup'}->{$key}}, @val;                                  push @{$self->{'lookup'}->{$key}}, @val;
296                          }                          }
297                  } else {                  } else {
298                          my $key = $self->fill_in($rec,$i->{'key'});                          my $key = $self->fill_in($rec,$i->{'key'});
299                          my @val = $self->fill_in($rec,$i->{'val'});                          my @val = $self->fill_in($rec,$i->{'val'});
300                          if ($key && @val) {                          if ($key && @val) {
301                                    $log->debug("stored $key = ",sub { join(" | ",@val) });
302                                  push @{$self->{'lookup'}->{$key}}, @val;                                  push @{$self->{'lookup'}->{$key}}, @val;
303                          }                          }
304                  }                  }
# Line 384  sub fill_in { Line 393  sub fill_in {
393          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
394    
395          # do actual replacement of placeholders          # do actual replacement of placeholders
396          $format =~ s/v(\d+)(?:\^(\w))*/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;          $format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;
397    
398          if ($found) {          if ($found) {
399                    $log->debug("format: $format");
400                  if ($eval_code) {                  if ($eval_code) {
401                          my $eval = $self->fill_in($rec,$eval_code,$i);                          my $eval = $self->fill_in($rec,$eval_code,$i);
402                          return if (! $self->_eval($eval));                          return if (! $self->_eval($eval));
403                  }                  }
404                  # do we have lookups?                  # do we have lookups?
405                  $log->debug("test format '$format' for lookups");                  if ($format =~ /$LOOKUP_REGEX/o) {
406                  if ($format =~ /\[[^\[\]]+\]/o) {                          $log->debug("format '$format' has lookup");
407                          return $self->lookup($format);                          return $self->lookup($format);
408                  } else {                  } else {
409                          return $format;                          return $format;
# Line 420  sub lookup { Line 430  sub lookup {
430    
431          my $tmp = shift || $log->logconfess("need format");          my $tmp = shift || $log->logconfess("need format");
432    
433          if ($tmp =~ /\[[^\[\]]+\]/o) {          if ($tmp =~ /$LOOKUP_REGEX/o) {
434                  my @in = ( $tmp );                  my @in = ( $tmp );
435    
436                  $log->debug("lookup for: ",$tmp);                  $log->debug("lookup for: ",$tmp);
437    
438                  my @out;                  my @out;
439                  while (my $f = shift @in) {                  while (my $f = shift @in) {
440                          if ($f =~ /\[([^\[\]]+)\]/) {                          if ($f =~ /$LOOKUP_REGEX_SAVE/o) {
441                                  my $k = $1;                                  my $k = $1;
442                                  if ($self->{'lookup'}->{$k}) {                                  if ($self->{'lookup'}->{$k}) {
443                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {
444                                                  my $tmp2 = $f;                                                  my $tmp2 = $f;
445                                                  $tmp2 =~ s/\[$k\]/$nv/g;                                                  $tmp2 =~ s/lookup{$k}/$nv/g;
446                                                  push @in, $tmp2;                                                  push @in, $tmp2;
447                                          }                                          }
448                                  } else {                                  } else {
# Line 442  sub lookup { Line 452  sub lookup {
452                                  push @out, $f;                                  push @out, $f;
453                          }                          }
454                  }                  }
455                    $log->logconfess("return is array and it's not expected!") unless wantarray;
456                  return @out;                  return @out;
457          } else {          } else {
458                  return $tmp;                  return $tmp;
# Line 476  sub parse { Line 487  sub parse {
487    
488          my @out;          my @out;
489    
490            $log->debug("format: $format");
491    
492          my $eval_code;          my $eval_code;
493          # remove eval{...} from beginning          # remove eval{...} from beginning
494          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
# Line 483  sub parse { Line 496  sub parse {
496          my $prefix;          my $prefix;
497          my $all_found=0;          my $all_found=0;
498    
499          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))*//s) {          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))?//s) {
500    
501                  my $del = $1 || '';                  my $del = $1 || '';
502                  $prefix ||= $del if ($all_found == 0);                  $prefix ||= $del if ($all_found == 0);
# Line 500  sub parse { Line 513  sub parse {
513    
514          return if (! $all_found);          return if (! $all_found);
515    
516          my $out = join('',@out) . $format;          my $out = join('',@out);
517    
518          # add prefix if not there          if ($out) {
519          $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);                  # add rest of format (suffix)
520                    $out .= $format;
521    
522                    # add prefix if not there
523                    $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);
524    
525                    $log->debug("result: $out");
526            }
527    
528          if ($eval_code) {          if ($eval_code) {
529                  my $eval = $self->fill_in($rec,$eval_code,$i);                  my $eval = $self->fill_in($rec,$eval_code,$i);
530                  $log->debug("about to eval ",$eval," [$out]");                  $log->debug("about to eval{",$eval,"} format: $out");
531                  return if (! $self->_eval($eval));                  return if (! $self->_eval($eval));
532          }          }
533    
# Line 539  sub parse_to_arr { Line 559  sub parse_to_arr {
559                  push @arr, $v;                  push @arr, $v;
560          }          }
561    
562            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
563    
564          return @arr;          return @arr;
565  }  }
566    
567    =head2 fill_in_to_arr
568    
569    Similar to C<fill_in>, but returns array of all repeatable fields. Usable
570    for fields which have lookups, so they shouldn't be parsed but rather
571    C<fill_id>ed.
572    
573     my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]');
574    
575    =cut
576    
577    sub fill_in_to_arr {
578            my $self = shift;
579    
580            my ($rec, $format_utf8) = @_;
581    
582            my $log = $self->_get_logger();
583    
584            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
585            return if (! $format_utf8);
586    
587            my $i = 0;
588            my @arr;
589    
590            while (my @v = $self->fill_in($rec,$format_utf8,$i++)) {
591                    push @arr, @v;
592            }
593    
594            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
595    
596            return @arr;
597    }
598    
599    
600  =head2 data_structure  =head2 data_structure
601    
602  Create in-memory data structure which represents layout from C<import_xml>.  Create in-memory data structure which represents layout from C<import_xml>.
# Line 549  It is used later to produce output. Line 604  It is used later to produce output.
604    
605   my @ds = $webpac->data_structure($rec);   my @ds = $webpac->data_structure($rec);
606    
607    This method will also set C<$webpac->{'currnet_filename'}> if there is
608    <filename> tag in C<import_xml>.
609    
610  =cut  =cut
611    
612  sub data_structure {  sub data_structure {
# Line 559  sub data_structure { Line 617  sub data_structure {
617          my $rec = shift;          my $rec = shift;
618          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
619    
620            undef $self->{'currnet_filename'};
621    
622          my @sorted_tags;          my @sorted_tags;
623          if ($self->{tags_by_order}) {          if ($self->{tags_by_order}) {
624                  @sorted_tags = @{$self->{tags_by_order}};                  @sorted_tags = @{$self->{tags_by_order}};
# Line 569  sub data_structure { Line 629  sub data_structure {
629    
630          my @ds;          my @ds;
631    
632            $log->debug("tags: ",sub { join(", ",@sorted_tags) });
633    
634          foreach my $field (@sorted_tags) {          foreach my $field (@sorted_tags) {
635    
636                  my $row;                  my $row;
# Line 576  sub data_structure { Line 638  sub data_structure {
638  #print "field $field [",$self->{'tag'},"] = ",Dumper($self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}});  #print "field $field [",$self->{'tag'},"] = ",Dumper($self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}});
639    
640                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
641                          my @v = $self->parse_to_arr($rec,$tag->{'content'});                          my $format = $tag->{'value'} || $tag->{'content'};
642    
643                            $log->debug("format: $format");
644    
645                            my @v;
646                            if ($format =~ /$LOOKUP_REGEX/o) {
647                                    @v = $self->fill_in_to_arr($rec,$format);
648                            } else {
649                                    @v = $self->parse_to_arr($rec,$format);
650                            }
651                          next if (! @v);                          next if (! @v);
652    
653                          # does tag have type?                          # does tag have type?
# Line 587  sub data_structure { Line 657  sub data_structure {
657                                  push @{$row->{'display'}}, @v;                                  push @{$row->{'display'}}, @v;
658                                  push @{$row->{'swish'}}, @v;                                  push @{$row->{'swish'}}, @v;
659                          }                          }
660    
661                            if ($field eq 'filename') {
662                                    $self->{'current_filename'} = join('',@v);
663                                    $log->debug("filename: ",$self->{'current_filename'});
664                            }
665    
666                  }                  }
667    
668                  if ($row) {                  if ($row) {
669                          $row->{'tag'} = $field;                          $row->{'tag'} = $field;
670                          push @ds, $row;                          push @ds, $row;
671    
672                            $log->debug("row $field: ",sub { Dumper($row) });
673                  }                  }
674    
675          }          }
# Line 684  sub _sort_by_order { Line 762  sub _sort_by_order {
762  sub _get_logger {  sub _get_logger {
763          my $self = shift;          my $self = shift;
764    
765          my @c = caller(1);          my $name = (caller(1))[3] || caller;
766          return get_logger($c[3]);          return get_logger($name);
767  }  }
768    
769  #  #
Legend:
Removed from v.372  
changed lines
  Added in v.374
  ViewVC Help
Powered by ViewVC 1.1.26