/[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 376 by dpavlin, Sun Jun 20 18:39:30 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 246  sub open_import_xml { Line 254  sub open_import_xml {
254    
255          $self->{'tag'} = $type2tag{$type_base};          $self->{'tag'} = $type2tag{$type_base};
256    
257          $log->debug("using type '",$self->{'type'},"' tag <",$self->{'tag'},">") if ($self->{'debug'});          $log->info("using type '",$self->{'type'},"' tag <",$self->{'tag'},">");
258    
259          my $f = "./import_xml/".$self->{'type'}.".xml";          my $f = "./import_xml/".$self->{'type'}.".xml";
260          $log->logconfess("import_xml file '$f' doesn't exist!") if (! -e "$f");          $log->logconfess("import_xml file '$f' doesn't exist!") if (! -e "$f");
261    
262          $log->debug("reading '$f'") if ($self->{'debug'});          $log->info("reading '$f'");
263    
264            $self->{'import_xml_file'} = $f;
265    
266          $self->{'import_xml'} = XMLin($f,          $self->{'import_xml'} = XMLin($f,
267                  ForceArray => [ $self->{'tag'}, 'config', 'format' ],                  ForceArray => [ $self->{'tag'}, 'config', 'format' ],
                 ForceContent => 1  
268          );          );
269    
270            $log->debug("import xml is ",sub { Dumper($self->{'import_xml'}) });
271    
272  }  }
273    
274  =head2 create_lookup  =head2 create_lookup
# Line 284  sub create_lookup { Line 295  sub create_lookup {
295                          my $key = $self->fill_in($rec,$i->{'key'});                          my $key = $self->fill_in($rec,$i->{'key'});
296                          my @val = $self->fill_in($rec,$i->{'val'});                          my @val = $self->fill_in($rec,$i->{'val'});
297                          if ($key && @val && eval $eval) {                          if ($key && @val && eval $eval) {
298                                    $log->debug("stored $key = ",sub { join(" | ",@val) });
299                                  push @{$self->{'lookup'}->{$key}}, @val;                                  push @{$self->{'lookup'}->{$key}}, @val;
300                          }                          }
301                  } else {                  } else {
302                          my $key = $self->fill_in($rec,$i->{'key'});                          my $key = $self->fill_in($rec,$i->{'key'});
303                          my @val = $self->fill_in($rec,$i->{'val'});                          my @val = $self->fill_in($rec,$i->{'val'});
304                          if ($key && @val) {                          if ($key && @val) {
305                                    $log->debug("stored $key = ",sub { join(" | ",@val) });
306                                  push @{$self->{'lookup'}->{$key}}, @val;                                  push @{$self->{'lookup'}->{$key}}, @val;
307                          }                          }
308                  }                  }
# Line 362  Following example will read second value Line 375  Following example will read second value
375  This function B<does not> perform parsing of format to inteligenty skip  This function B<does not> perform parsing of format to inteligenty skip
376  delimiters before fields which aren't used.  delimiters before fields which aren't used.
377    
378    This method will automatically decode UTF-8 string to local code page
379    if needed.
380    
381  =cut  =cut
382    
383  sub fill_in {  sub fill_in {
# Line 377  sub fill_in { Line 393  sub fill_in {
393          # FIXME remove for speedup?          # FIXME remove for speedup?
394          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
395    
396            if (utf8::is_utf8($format)) {
397                    $format = $self->_x($format);
398            }
399    
400          my $found = 0;          my $found = 0;
401    
402          my $eval_code;          my $eval_code;
# Line 384  sub fill_in { Line 404  sub fill_in {
404          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
405    
406          # do actual replacement of placeholders          # do actual replacement of placeholders
407          $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;
408    
409          if ($found) {          if ($found) {
410                    $log->debug("format: $format");
411                  if ($eval_code) {                  if ($eval_code) {
412                          my $eval = $self->fill_in($rec,$eval_code,$i);                          my $eval = $self->fill_in($rec,$eval_code,$i);
413                          return if (! $self->_eval($eval));                          return if (! $self->_eval($eval));
414                  }                  }
415                  # do we have lookups?                  # do we have lookups?
416                  $log->debug("test format '$format' for lookups");                  if ($format =~ /$LOOKUP_REGEX/o) {
417                  if ($format =~ /\[[^\[\]]+\]/o) {                          $log->debug("format '$format' has lookup");
418                          return $self->lookup($format);                          return $self->lookup($format);
419                  } else {                  } else {
420                          return $format;                          return $format;
# Line 420  sub lookup { Line 441  sub lookup {
441    
442          my $tmp = shift || $log->logconfess("need format");          my $tmp = shift || $log->logconfess("need format");
443    
444          if ($tmp =~ /\[[^\[\]]+\]/o) {          if ($tmp =~ /$LOOKUP_REGEX/o) {
445                  my @in = ( $tmp );                  my @in = ( $tmp );
446    
447                  $log->debug("lookup for: ",$tmp);                  $log->debug("lookup for: ",$tmp);
448    
449                  my @out;                  my @out;
450                  while (my $f = shift @in) {                  while (my $f = shift @in) {
451                          if ($f =~ /\[([^\[\]]+)\]/) {                          if ($f =~ /$LOOKUP_REGEX_SAVE/o) {
452                                  my $k = $1;                                  my $k = $1;
453                                  if ($self->{'lookup'}->{$k}) {                                  if ($self->{'lookup'}->{$k}) {
454                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {
455                                                  my $tmp2 = $f;                                                  my $tmp2 = $f;
456                                                  $tmp2 =~ s/\[$k\]/$nv/g;                                                  $tmp2 =~ s/lookup{$k}/$nv/g;
457                                                  push @in, $tmp2;                                                  push @in, $tmp2;
458                                          }                                          }
459                                  } else {                                  } else {
# Line 442  sub lookup { Line 463  sub lookup {
463                                  push @out, $f;                                  push @out, $f;
464                          }                          }
465                  }                  }
466                    $log->logconfess("return is array and it's not expected!") unless wantarray;
467                  return @out;                  return @out;
468          } else {          } else {
469                  return $tmp;                  return $tmp;
# Line 472  sub parse { Line 494  sub parse {
494    
495          $i = 0 if (! $i);          $i = 0 if (! $i);
496    
497          my $format = $self->{'utf2cp'}->convert($format_utf8) || $log->logconfess("can't convert '$format_utf8' from UTF-8 to ",$self->{'code_page'});          my $format = $self->_x($format_utf8) || $log->logconfess("can't convert '$format_utf8' from UTF-8 to ",$self->{'code_page'});
498    
499          my @out;          my @out;
500    
501            $log->debug("format: $format");
502    
503          my $eval_code;          my $eval_code;
504          # remove eval{...} from beginning          # remove eval{...} from beginning
505          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
# Line 483  sub parse { Line 507  sub parse {
507          my $prefix;          my $prefix;
508          my $all_found=0;          my $all_found=0;
509    
510          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))*//s) {          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))?//s) {
511    
512                  my $del = $1 || '';                  my $del = $1 || '';
513                  $prefix ||= $del if ($all_found == 0);                  $prefix ||= $del if ($all_found == 0);
# Line 500  sub parse { Line 524  sub parse {
524    
525          return if (! $all_found);          return if (! $all_found);
526    
527          my $out = join('',@out) . $format;          my $out = join('',@out);
528    
529            if ($out) {
530                    # add rest of format (suffix)
531                    $out .= $format;
532    
533          # add prefix if not there                  # add prefix if not there
534          $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);                  $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);
535    
536                    $log->debug("result: $out");
537            }
538    
539          if ($eval_code) {          if ($eval_code) {
540                  my $eval = $self->fill_in($rec,$eval_code,$i);                  my $eval = $self->fill_in($rec,$eval_code,$i);
541                  $log->debug("about to eval ",$eval," [$out]");                  $log->debug("about to eval{",$eval,"} format: $out");
542                  return if (! $self->_eval($eval));                  return if (! $self->_eval($eval));
543          }          }
544    
# Line 539  sub parse_to_arr { Line 570  sub parse_to_arr {
570                  push @arr, $v;                  push @arr, $v;
571          }          }
572    
573            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
574    
575            return @arr;
576    }
577    
578    =head2 fill_in_to_arr
579    
580    Similar to C<fill_in>, but returns array of all repeatable fields. Usable
581    for fields which have lookups, so they shouldn't be parsed but rather
582    C<fill_id>ed.
583    
584     my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]');
585    
586    =cut
587    
588    sub fill_in_to_arr {
589            my $self = shift;
590    
591            my ($rec, $format_utf8) = @_;
592    
593            my $log = $self->_get_logger();
594    
595            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
596            return if (! $format_utf8);
597    
598            my $i = 0;
599            my @arr;
600    
601            while (my @v = $self->fill_in($rec,$format_utf8,$i++)) {
602                    push @arr, @v;
603            }
604    
605            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
606    
607          return @arr;          return @arr;
608  }  }
609    
610    
611  =head2 data_structure  =head2 data_structure
612    
613  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 615  It is used later to produce output.
615    
616   my @ds = $webpac->data_structure($rec);   my @ds = $webpac->data_structure($rec);
617    
618    This method will also set C<$webpac->{'currnet_filename'}> if there is
619    <filename> tag in C<import_xml>.
620    
621  =cut  =cut
622    
623  sub data_structure {  sub data_structure {
# Line 559  sub data_structure { Line 628  sub data_structure {
628          my $rec = shift;          my $rec = shift;
629          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
630    
631            undef $self->{'currnet_filename'};
632    
633          my @sorted_tags;          my @sorted_tags;
634          if ($self->{tags_by_order}) {          if ($self->{tags_by_order}) {
635                  @sorted_tags = @{$self->{tags_by_order}};                  @sorted_tags = @{$self->{tags_by_order}};
# Line 569  sub data_structure { Line 640  sub data_structure {
640    
641          my @ds;          my @ds;
642    
643            $log->debug("tags: ",sub { join(", ",@sorted_tags) });
644    
645          foreach my $field (@sorted_tags) {          foreach my $field (@sorted_tags) {
646    
647                  my $row;                  my $row;
# Line 576  sub data_structure { Line 649  sub data_structure {
649  #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'}});
650    
651                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
652                          my @v = $self->parse_to_arr($rec,$tag->{'content'});                          my $format = $tag->{'value'} || $tag->{'content'};
653    
654                            $log->debug("format: $format");
655    
656                            my @v;
657                            if ($format =~ /$LOOKUP_REGEX/o) {
658                                    @v = $self->fill_in_to_arr($rec,$format);
659                            } else {
660                                    @v = $self->parse_to_arr($rec,$format);
661                            }
662                          next if (! @v);                          next if (! @v);
663    
664                            # use format?
665                            if ($tag->{'format_name'}) {
666                                    @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
667                            }
668    
669                          # does tag have type?                          # does tag have type?
670                          if ($tag->{'type'}) {                          if ($tag->{'type'}) {
671                                  push @{$row->{$tag->{'type'}}}, @v;                                  push @{$row->{$tag->{'type'}}}, @v;
# Line 587  sub data_structure { Line 673  sub data_structure {
673                                  push @{$row->{'display'}}, @v;                                  push @{$row->{'display'}}, @v;
674                                  push @{$row->{'swish'}}, @v;                                  push @{$row->{'swish'}}, @v;
675                          }                          }
676    
677                            if ($field eq 'filename') {
678                                    $self->{'current_filename'} = join('',@v);
679                                    $log->debug("filename: ",$self->{'current_filename'});
680                            }
681    
682                  }                  }
683    
684                  if ($row) {                  if ($row) {
685                          $row->{'tag'} = $field;                          $row->{'tag'} = $field;
686    
687                            # TODO: name_sigular, name_plural
688                            my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
689                            $row->{'name'} = $name ? $self->_x($name) : $field;
690    
691                          push @ds, $row;                          push @ds, $row;
692    
693                            $log->debug("row $field: ",sub { Dumper($row) });
694                  }                  }
695    
696          }          }
# Line 629  sub output { Line 728  sub output {
728          return $out;          return $out;
729  }  }
730    
731    =head2 apply_format
732    
733    Apply format specified in tag with C<format_name="name"> and
734    C<format_delimiter=";;">.
735    
736     my $text = $webpac->apply_format($format_name,$format_delimiter,$data);
737    
738    Formats can contain C<lookup{...}> if you need them.
739    
740    =cut
741    
742    sub apply_format {
743            my $self = shift;
744    
745            my ($name,$delimiter,$data) = @_;
746    
747            my $log = $self->_get_logger();
748    
749            if (! $self->{'import_xml'}->{'format'}->{$name}) {
750                    $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});
751                    return $data;
752            }
753    
754            $log->warn("no delimiter for format $name") if (! $delimiter);
755    
756            my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");
757    
758            my @data = split(/\Q$delimiter\E/, $data);
759    
760            my $out = sprintf($format, @data);
761            $log->debug("using format $name [$format] on $data to produce: $out");
762    
763            if ($out =~ m/$LOOKUP_REGEX/o) {
764                    return $self->lookup($out);
765            } else {
766                    return $out;
767            }
768    
769    }
770    
771    
772  #  #
773  #  #
774  #  #
# Line 681  sub _sort_by_order { Line 821  sub _sort_by_order {
821          return $va <=> $vb;          return $va <=> $vb;
822  }  }
823    
824    =head2 _get_logger
825    
826    Get C<Log::Log4perl> object with a twist: domains are defined for each
827    method
828    
829     my $log = $webpac->_get_logger();
830    
831    =cut
832    
833  sub _get_logger {  sub _get_logger {
834          my $self = shift;          my $self = shift;
835    
836          my @c = caller(1);          my $name = (caller(1))[3] || caller;
837          return get_logger($c[3]);          return get_logger($name);
838    }
839    
840    =head2 _x
841    
842    Convert string from UTF-8 to code page defined in C<import_xml>.
843    
844     my $text = $webpac->_x('utf8 text');
845    
846    =cut
847    
848    sub _x {
849            my $self = shift;
850            my $utf8 = shift || return;
851    
852            return $self->{'utf2cp'}->convert($utf8) ||
853                    $self->_get_logger()->logwarn("can't convert '$utf8'");
854  }  }
855    
856  #  #
Legend:
Removed from v.372  
changed lines
  Added in v.376
  ViewVC Help
Powered by ViewVC 1.1.26