/[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 370 by dpavlin, Thu Jun 17 17:25:12 2004 UTC revision 411 by dpavlin, Sun Sep 5 22:22:37 2004 UTC
# Line 8  use Text::Iconv; Line 8  use Text::Iconv;
8  use Config::IniFiles;  use Config::IniFiles;
9  use XML::Simple;  use XML::Simple;
10  use Template;  use Template;
11    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 53  sub new { Line 59  sub new {
59          my $self = {@_};          my $self = {@_};
60          bless($self, $class);          bless($self, $class);
61    
62            my $log_file = $self->{'log'} || "log.conf";
63            Log::Log4perl->init($log_file);
64    
65            my $log = $self->_get_logger();
66    
67          # fill in default values          # fill in default values
68          # output codepage          # output codepage
69          $self->{'code_page'} = 'ISO-8859-2' if (! $self->{'code_page'});          $self->{'code_page'} = 'ISO-8859-2' if (! $self->{'code_page'});
# Line 60  sub new { Line 71  sub new {
71          #          #
72          # read global.conf          # read global.conf
73          #          #
74            $log->debug("read 'global.conf'");
75    
76          my $config = new Config::IniFiles( -file => 'global.conf' ) || croak "can't open 'global.conf'";          my $config = new Config::IniFiles( -file => 'global.conf' ) || $log->logcroak("can't open 'global.conf'");
77    
78          # read global config parametars          # read global config parametars
79          foreach my $var (qw(          foreach my $var (qw(
# Line 80  sub new { Line 92  sub new {
92          # read indexer config file          # read indexer config file
93          #          #
94    
95          $self->{indexer_config_file} = new Config::IniFiles( -file => $self->{config_file} ) || croak "can't open '$self->{config_file}'";          $self->{indexer_config_file} = new Config::IniFiles( -file => $self->{config_file} ) || $log->logcroak("can't open '",$self->{config_file},"'");
96    
97          # create UTF-8 convertor for import_xml files          # create UTF-8 convertor for import_xml files
98          $self->{'utf2cp'} = Text::Iconv->new('UTF-8' ,$self->{'code_page'});          $self->{'utf2cp'} = Text::Iconv->new('UTF-8' ,$self->{'code_page'});
# Line 132  sub open_isis { Line 144  sub open_isis {
144          my $self = shift;          my $self = shift;
145          my $arg = {@_};          my $arg = {@_};
146    
147          croak "need filename" if (! $arg->{'filename'});          my $log = $self->_get_logger();
148    
149            $log->logcroak("need filename") if (! $arg->{'filename'});
150          my $code_page = $arg->{'code_page'} || '852';          my $code_page = $arg->{'code_page'} || '852';
151    
152          use OpenIsis;          use OpenIsis;
# Line 142  sub open_isis { Line 156  sub open_isis {
156          # create Text::Iconv object          # create Text::Iconv object
157          my $cp = Text::Iconv->new($code_page,$self->{'code_page'});          my $cp = Text::Iconv->new($code_page,$self->{'code_page'});
158    
159          print STDERR "reading ISIS database '",$arg->{'filename'},"'\n" if ($self->{'debug'});          $log->info("reading ISIS database '",$arg->{'filename'},"'");
160    
161          my $isis_db = OpenIsis::open($arg->{'filename'});          my $isis_db = OpenIsis::open($arg->{'filename'});
162    
# Line 150  sub open_isis { Line 164  sub open_isis {
164    
165          $maxmfn = $self->{limit_mfn} if ($self->{limit_mfn});          $maxmfn = $self->{limit_mfn} if ($self->{limit_mfn});
166    
167          print STDERR "processing $maxmfn records...\n" if ($self->{'debug'});          $log->info("processing $maxmfn records...");
168    
169          # read database          # read database
170          for (my $mfn = 1; $mfn <= $maxmfn; $mfn++) {          for (my $mfn = 1; $mfn <= $maxmfn; $mfn++) {
# Line 174  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 182  sub open_isis { Line 198  sub open_isis {
198                  my $rec = $self->{'data'}->{$mfn};                  my $rec = $self->{'data'}->{$mfn};
199                  $self->create_lookup($rec, @{$arg->{'lookup'}});                  $self->create_lookup($rec, @{$arg->{'lookup'}});
200    
201                    $self->progress_bar($mfn,$maxmfn);
202    
203          }          }
204    
205          $self->{'current_mfn'} = 1;          $self->{'current_mfn'} = 1;
206            $self->{'last_pcnt'} = 0;
207    
208          # store max mfn and return it.          # store max mfn and return it.
209          return $self->{'max_mfn'} = $maxmfn;          return $self->{'max_mfn'} = $maxmfn;
# Line 202  it's implemented, that is). Line 221  it's implemented, that is).
221  sub fetch_rec {  sub fetch_rec {
222          my $self = shift;          my $self = shift;
223    
224          my $mfn = $self->{'current_mfn'}++ || confess "it seems that you didn't load database!";          my $log = $self->_get_logger();
225    
226            my $mfn = $self->{'current_mfn'}++ || $log->logconfess("it seems that you didn't load database!");
227    
228          if ($mfn > $self->{'max_mfn'}) {          if ($mfn > $self->{'max_mfn'}) {
229                  $self->{'current_mfn'} = $self->{'max_mfn'};                  $self->{'current_mfn'} = $self->{'max_mfn'};
230                    $log->debug("at EOF");
231                  return;                  return;
232          }          }
233    
234            $self->progress_bar($mfn,$self->{'max_mfn'});
235    
236          return $self->{'data'}->{$mfn};          return $self->{'data'}->{$mfn};
237  }  }
238    
239    =head2 progress_bar
240    
241    Draw progress bar on STDERR.
242    
243     $webpac->progress_bar($current, $max);
244    
245    =cut
246    
247    sub progress_bar {
248            my $self = shift;
249    
250            my ($curr,$max) = @_;
251    
252            my $log = $self->_get_logger();
253    
254            $log->logconfess("no current value!") if (! $curr);
255            $log->logconfess("no maximum value!") if (! $max);
256    
257            if ($curr > $max) {
258                    $max = $curr;
259                    $log->debug("overflow to $curr");
260            }
261    
262            $self->{'last_pcnt'} ||= 1;
263    
264            $self->{'last_pcnt'} = $curr if ($curr < $self->{'last_pcnt'});
265    
266            my $p = int($curr * 100 / $max);
267            if ($p != $self->{'last_pcnt'}) {
268                    printf STDERR ("%5d / %5d [%-51s] %-2d %% \r",$curr,$max,"=" x ($p/2).">", $p );
269                    $self->{'last_pcnt'} = $p;
270            }
271    }
272    
273  =head2 open_import_xml  =head2 open_import_xml
274    
275  Read file from C<import_xml/> directory and parse it.  Read file from C<import_xml/> directory and parse it.
# Line 223  Read file from C<import_xml/> directory Line 281  Read file from C<import_xml/> directory
281  sub open_import_xml {  sub open_import_xml {
282          my $self = shift;          my $self = shift;
283    
284            my $log = $self->_get_logger();
285    
286          my $arg = {@_};          my $arg = {@_};
287          confess "need type to load file from import_xml/" if (! $arg->{'type'});          $log->logconfess("need type to load file from import_xml/") if (! $arg->{'type'});
288    
289          $self->{'type'} = $arg->{'type'};          $self->{'type'} = $arg->{'type'};
290    
# Line 233  sub open_import_xml { Line 293  sub open_import_xml {
293    
294          $self->{'tag'} = $type2tag{$type_base};          $self->{'tag'} = $type2tag{$type_base};
295    
296          print STDERR "using type ",$self->{'type'}," tag ",$self->{'tag'},"\n" if ($self->{'debug'});          $log->info("using type '",$self->{'type'},"' tag <",$self->{'tag'},">");
297    
298          my $f = "./import_xml/".$self->{'type'}.".xml";          my $f = "./import_xml/".$self->{'type'}.".xml";
299          confess "import_xml file '$f' doesn't exist!" if (! -e "$f");          $log->logconfess("import_xml file '$f' doesn't exist!") if (! -e "$f");
300    
301            $log->info("reading '$f'");
302    
303          print STDERR "reading '$f'\n" if ($self->{'debug'});          $self->{'import_xml_file'} = $f;
304    
305          $self->{'import_xml'} = XMLin($f,          $self->{'import_xml'} = XMLin($f,
306                  ForceArray => [ $self->{'tag'}, 'config', 'format' ],                  ForceArray => [ $self->{'tag'}, 'config', 'format' ],
                 ForceContent => 1  
307          );          );
308    
309            $log->debug("import xml is ",sub { Dumper($self->{'import_xml'}) });
310    
311  }  }
312    
313  =head2 create_lookup  =head2 create_lookup
# Line 260  Called internally by C<open_*> methods. Line 323  Called internally by C<open_*> methods.
323  sub create_lookup {  sub create_lookup {
324          my $self = shift;          my $self = shift;
325    
326          my $rec = shift || confess "need record to create lookup";          my $log = $self->_get_logger();
327          confess("need HASH as first argument!") if ($rec !~ /HASH/o);  
328            my $rec = shift || $log->logconfess("need record to create lookup");
329            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
330    
331          foreach my $i (@_) {          foreach my $i (@_) {
332                  if ($i->{'eval'}) {                  if ($i->{'eval'}) {
# Line 269  sub create_lookup { Line 334  sub create_lookup {
334                          my $key = $self->fill_in($rec,$i->{'key'});                          my $key = $self->fill_in($rec,$i->{'key'});
335                          my @val = $self->fill_in($rec,$i->{'val'});                          my @val = $self->fill_in($rec,$i->{'val'});
336                          if ($key && @val && eval $eval) {                          if ($key && @val && eval $eval) {
337                                    $log->debug("stored $key = ",sub { join(" | ",@val) });
338                                  push @{$self->{'lookup'}->{$key}}, @val;                                  push @{$self->{'lookup'}->{$key}}, @val;
339                          }                          }
340                  } else {                  } else {
341                          my $key = $self->fill_in($rec,$i->{'key'});                          my $key = $self->fill_in($rec,$i->{'key'});
342                          my @val = $self->fill_in($rec,$i->{'val'});                          my @val = $self->fill_in($rec,$i->{'val'});
343                          if ($key && @val) {                          if ($key && @val) {
344                                    $log->debug("stored $key = ",sub { join(" | ",@val) });
345                                  push @{$self->{'lookup'}->{$key}}, @val;                                  push @{$self->{'lookup'}->{$key}}, @val;
346                          }                          }
347                  }                  }
# Line 307  sub get_data { Line 374  sub get_data {
374    
375          if ($$rec->{$f}) {          if ($$rec->{$f}) {
376                  return '' if (! $$rec->{$f}->[$i]);                  return '' if (! $$rec->{$f}->[$i]);
377                    no strict 'refs';
378                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {
379                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
380                          return $$rec->{$f}->[$i]->{$sf};                          return $$rec->{$f}->[$i]->{$sf};
# Line 347  Following example will read second value Line 415  Following example will read second value
415  This function B<does not> perform parsing of format to inteligenty skip  This function B<does not> perform parsing of format to inteligenty skip
416  delimiters before fields which aren't used.  delimiters before fields which aren't used.
417    
418    This method will automatically decode UTF-8 string to local code page
419    if needed.
420    
421  =cut  =cut
422    
423  sub fill_in {  sub fill_in {
424          my $self = shift;          my $self = shift;
425    
426          my $rec = shift || confess "need data record";          my $log = $self->_get_logger();
427          my $format = shift || confess "need format to parse";  
428            my $rec = shift || $log->logconfess("need data record");
429            my $format = shift || $log->logconfess("need format to parse");
430          # iteration (for repeatable fields)          # iteration (for repeatable fields)
431          my $i = shift || 0;          my $i = shift || 0;
432    
433          # FIXME remove for speedup?          # FIXME remove for speedup?
434          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
435    
436            if (utf8::is_utf8($format)) {
437                    $format = $self->_x($format);
438            }
439    
440          my $found = 0;          my $found = 0;
441    
# Line 367  sub fill_in { Line 444  sub fill_in {
444          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
445    
446          # do actual replacement of placeholders          # do actual replacement of placeholders
447          $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;
448    
449          if ($found) {          if ($found) {
450                    $log->debug("format: $format");
451                  if ($eval_code) {                  if ($eval_code) {
452                          my $eval = $self->fill_in($rec,$eval_code,$i);                          my $eval = $self->fill_in($rec,$eval_code,$i);
453                          return if (! eval $eval);                          return if (! $self->_eval($eval));
454                  }                  }
455                  # do we have lookups?                  # do we have lookups?
456                  if ($format =~ /\[[^\[\]]+\]/o) {                  if ($format =~ /$LOOKUP_REGEX/o) {
457                            $log->debug("format '$format' has lookup");
458                          return $self->lookup($format);                          return $self->lookup($format);
459                  } else {                  } else {
460                          return $format;                          return $format;
# Line 398  Lookups can be nested (like C<[d:[a:[v90 Line 477  Lookups can be nested (like C<[d:[a:[v90
477  sub lookup {  sub lookup {
478          my $self = shift;          my $self = shift;
479    
480          my $tmp = shift || confess "need format";          my $log = $self->_get_logger();
481    
482          if ($tmp =~ /\[[^\[\]]+\]/o) {          my $tmp = shift || $log->logconfess("need format");
483    
484            if ($tmp =~ /$LOOKUP_REGEX/o) {
485                  my @in = ( $tmp );                  my @in = ( $tmp );
486    
487                    $log->debug("lookup for: ",$tmp);
488    
489                  my @out;                  my @out;
490                  while (my $f = shift @in) {                  while (my $f = shift @in) {
491                          if ($f =~ /\[([^\[\]]+)\]/) {                          if ($f =~ /$LOOKUP_REGEX_SAVE/o) {
492                                  my $k = $1;                                  my $k = $1;
493                                  if ($self->{'lookup'}->{$k}) {                                  if ($self->{'lookup'}->{$k}) {
494                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {
495                                                  my $tmp2 = $f;                                                  my $tmp2 = $f;
496                                                  $tmp2 =~ s/\[$k\]/$nv/g;                                                  $tmp2 =~ s/lookup{$k}/$nv/g;
497                                                  push @in, $tmp2;                                                  push @in, $tmp2;
498                                          }                                          }
499                                  } else {                                  } else {
# Line 419  sub lookup { Line 503  sub lookup {
503                                  push @out, $f;                                  push @out, $f;
504                          }                          }
505                  }                  }
506                    $log->logconfess("return is array and it's not expected!") unless wantarray;
507                  return @out;                  return @out;
508          } else {          } else {
509                  return $tmp;                  return $tmp;
# Line 442  sub parse { Line 527  sub parse {
527    
528          return if (! $format_utf8);          return if (! $format_utf8);
529    
530          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          my $log = $self->_get_logger();
531          confess("need utf2cp Text::Iconv object!") if (! $self->{'utf2cp'});  
532            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
533            $log->logconfess("need utf2cp Text::Iconv object!") if (! $self->{'utf2cp'});
534    
535          $i = 0 if (! $i);          $i = 0 if (! $i);
536    
537          my $format = $self->{'utf2cp'}->convert($format_utf8) || confess("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'});
538    
539          my @out;          my @out;
540    
541            $log->debug("format: $format");
542    
543          my $eval_code;          my $eval_code;
544          # remove eval{...} from beginning          # remove eval{...} from beginning
545          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
# Line 458  sub parse { Line 547  sub parse {
547          my $prefix;          my $prefix;
548          my $all_found=0;          my $all_found=0;
549    
550          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))*//s) {          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))?//s) {
551    
552                  my $del = $1 || '';                  my $del = $1 || '';
553                  $prefix ||= $del if ($all_found == 0);                  $prefix ||= $del if ($all_found == 0);
# Line 475  sub parse { Line 564  sub parse {
564    
565          return if (! $all_found);          return if (! $all_found);
566    
567          my $out = join('',@out) . $format;          my $out = join('',@out);
568    
569            if ($out) {
570                    # add rest of format (suffix)
571                    $out .= $format;
572    
573          # add prefix if not there                  # add prefix if not there
574          $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);                  $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);
575    
576                    $log->debug("result: $out");
577            }
578    
579          if ($eval_code) {          if ($eval_code) {
580                  my $eval = $self->fill_in($rec,$eval_code,$i);                  my $eval = $self->fill_in($rec,$eval_code,$i);
581                  return if (! eval $eval);                  $log->debug("about to eval{",$eval,"} format: $out");
582                    return if (! $self->_eval($eval));
583          }          }
584    
585          return $out;          return $out;
# Line 501  sub parse_to_arr { Line 598  sub parse_to_arr {
598    
599          my ($rec, $format_utf8) = @_;          my ($rec, $format_utf8) = @_;
600    
601          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          my $log = $self->_get_logger();
602    
603            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
604          return if (! $format_utf8);          return if (! $format_utf8);
605    
606          my $i = 0;          my $i = 0;
# Line 511  sub parse_to_arr { Line 610  sub parse_to_arr {
610                  push @arr, $v;                  push @arr, $v;
611          }          }
612    
613            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
614    
615          return @arr;          return @arr;
616  }  }
617    
618  =head2 data_structure  =head2 fill_in_to_arr
619    
620  Create in-memory data structure which represents layout from C<import_xml>.  Similar to C<fill_in>, but returns array of all repeatable fields. Usable
621  It is used later to produce output.  for fields which have lookups, so they shouldn't be parsed but rather
622    C<fill_id>ed.
623    
624   my @ds = $webpac->data_structure($rec);   my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]');
625    
626  =cut  =cut
627    
628  # private method _sort_by_order  sub fill_in_to_arr {
 # sort subrouting using order="" attribute  
 sub _sort_by_order {  
629          my $self = shift;          my $self = shift;
630    
631          my $va = $self->{'import_xml'}->{'indexer'}->{$a}->{'order'} ||          my ($rec, $format_utf8) = @_;
                 $self->{'import_xml'}->{'indexer'}->{$a};  
         my $vb = $self->{'import_xml'}->{'indexer'}->{$b}->{'order'} ||  
                 $self->{'import_xml'}->{'indexer'}->{$b};  
632    
633          return $va <=> $vb;          my $log = $self->_get_logger();
634    
635            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
636            return if (! $format_utf8);
637    
638            my $i = 0;
639            my @arr;
640    
641            while (my @v = $self->fill_in($rec,$format_utf8,$i++)) {
642                    push @arr, @v;
643            }
644    
645            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
646    
647            return @arr;
648  }  }
649    
650    
651    =head2 data_structure
652    
653    Create in-memory data structure which represents layout from C<import_xml>.
654    It is used later to produce output.
655    
656     my @ds = $webpac->data_structure($rec);
657    
658    This method will also set C<$webpac->{'currnet_filename'}> if there is
659    <filename> tag in C<import_xml> and C<$webpac->{'headline'}> if there is
660    <headline> tag.
661    
662    =cut
663    
664  sub data_structure {  sub data_structure {
665          my $self = shift;          my $self = shift;
666    
667            my $log = $self->_get_logger();
668    
669          my $rec = shift;          my $rec = shift;
670          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
671    
672            undef $self->{'currnet_filename'};
673            undef $self->{'headline'};
674    
675          my @sorted_tags;          my @sorted_tags;
676          if ($self->{tags_by_order}) {          if ($self->{tags_by_order}) {
# Line 552  sub data_structure { Line 682  sub data_structure {
682    
683          my @ds;          my @ds;
684    
685            $log->debug("tags: ",sub { join(", ",@sorted_tags) });
686    
687          foreach my $field (@sorted_tags) {          foreach my $field (@sorted_tags) {
688    
689                  my $row;                  my $row;
# Line 559  sub data_structure { Line 691  sub data_structure {
691  #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'}});
692    
693                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
694                          my @v = $self->parse_to_arr($rec,$tag->{'content'});                          my $format = $tag->{'value'} || $tag->{'content'};
695    
696                            $log->debug("format: $format");
697    
698                            my @v;
699                            if ($format =~ /$LOOKUP_REGEX/o) {
700                                    @v = $self->fill_in_to_arr($rec,$format);
701                            } else {
702                                    @v = $self->parse_to_arr($rec,$format);
703                            }
704                          next if (! @v);                          next if (! @v);
705    
706                            # use format?
707                            if ($tag->{'format_name'}) {
708                                    @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
709                            }
710    
711                            if ($field eq 'filename') {
712                                    $self->{'current_filename'} = join('',@v);
713                                    $log->debug("filename: ",$self->{'current_filename'});
714                            } elsif ($field eq 'headline') {
715                                    $self->{'headline'} .= join('',@v);
716                                    $log->debug("headline: ",$self->{'headline'});
717                                    next; # don't return headline in data_structure!
718                            }
719    
720                          # does tag have type?                          # does tag have type?
721                          if ($tag->{'type'}) {                          if ($tag->{'type'}) {
722                                  push @{$row->{$tag->{'type'}}}, @v;                                  push @{$row->{$tag->{'type'}}}, @v;
# Line 570  sub data_structure { Line 724  sub data_structure {
724                                  push @{$row->{'display'}}, @v;                                  push @{$row->{'display'}}, @v;
725                                  push @{$row->{'swish'}}, @v;                                  push @{$row->{'swish'}}, @v;
726                          }                          }
727    
728    
729                  }                  }
730    
731                  if ($row) {                  if ($row) {
732                          $row->{'tag'} = $field;                          $row->{'tag'} = $field;
733    
734                            # TODO: name_sigular, name_plural
735                            my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
736                            $row->{'name'} = $name ? $self->_x($name) : $field;
737    
738                          push @ds, $row;                          push @ds, $row;
739    
740                            $log->debug("row $field: ",sub { Dumper($row) });
741                  }                  }
742    
743          }          }
# Line 596  sub output { Line 759  sub output {
759    
760          my $args = {@_};          my $args = {@_};
761    
762          confess("need template name") if (! $args->{'template'});          my $log = $self->_get_logger();
763          confess("need data array") if (! $args->{'data'});  
764            $log->logconfess("need template name") if (! $args->{'template'});
765            $log->logconfess("need data array") if (! $args->{'data'});
766    
767          my $out;          my $out;
768    
# Line 610  sub output { Line 775  sub output {
775          return $out;          return $out;
776  }  }
777    
778    =head2 output_file
779    
780    Create output from in-memory data structure using Template Toolkit template
781    to a file.
782    
783     $webpac->output_file(
784            file => 'out.txt',
785            template => 'text.tt',
786            data => @ds
787     );
788    
789    =cut
790    
791    sub output_file {
792            my $self = shift;
793    
794            my $args = {@_};
795    
796            my $log = $self->_get_logger();
797    
798            $log->logconfess("need file name") if (! $args->{'file'});
799    
800            $log->debug("creating file ",$args->{'file'});
801    
802            open(my $fh, ">", $args->{'file'}) || $log->logdie("can't open output file '$self->{'file'}': $!");
803            print $fh $self->output(
804                    template => $args->{'template'},
805                    data => $args->{'data'},
806            ) || $log->logdie("print: $!");
807            close($fh) || $log->logdie("close: $!");
808    }
809    
810    =head2 apply_format
811    
812    Apply format specified in tag with C<format_name="name"> and
813    C<format_delimiter=";;">.
814    
815     my $text = $webpac->apply_format($format_name,$format_delimiter,$data);
816    
817    Formats can contain C<lookup{...}> if you need them.
818    
819    =cut
820    
821    sub apply_format {
822            my $self = shift;
823    
824            my ($name,$delimiter,$data) = @_;
825    
826            my $log = $self->_get_logger();
827    
828            if (! $self->{'import_xml'}->{'format'}->{$name}) {
829                    $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});
830                    return $data;
831            }
832    
833            $log->warn("no delimiter for format $name") if (! $delimiter);
834    
835            my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");
836    
837            my @data = split(/\Q$delimiter\E/, $data);
838    
839            my $out = sprintf($format, @data);
840            $log->debug("using format $name [$format] on $data to produce: $out");
841    
842            if ($out =~ m/$LOOKUP_REGEX/o) {
843                    return $self->lookup($out);
844            } else {
845                    return $out;
846            }
847    
848    }
849    
850    
851    #
852    #
853    #
854    
855    =head1 INTERNAL METHODS
856    
857    Here is a quick list of internal methods, mostly useful to turn debugging
858    on them (see L<LOGGING> below for explanation).
859    
860    =cut
861    
862    =head2 _eval
863    
864    Internal function to eval code without C<strict 'subs'>.
865    
866    =cut
867    
868    sub _eval {
869            my $self = shift;
870    
871            my $code = shift || return;
872    
873            my $log = $self->_get_logger();
874    
875            no strict 'subs';
876            my $ret = eval $code;
877            if ($@) {
878                    $log->error("problem with eval code [$code]: $@");
879            }
880    
881            $log->debug("eval: ",$code," [",$ret,"]");
882    
883            return $ret || 0;
884    }
885    
886    =head2 _sort_by_order
887    
888    Sort xml tags data structure accoding to C<order=""> attribute.
889    
890    =cut
891    
892    sub _sort_by_order {
893            my $self = shift;
894    
895            my $va = $self->{'import_xml'}->{'indexer'}->{$a}->{'order'} ||
896                    $self->{'import_xml'}->{'indexer'}->{$a};
897            my $vb = $self->{'import_xml'}->{'indexer'}->{$b}->{'order'} ||
898                    $self->{'import_xml'}->{'indexer'}->{$b};
899    
900            return $va <=> $vb;
901    }
902    
903    =head2 _get_logger
904    
905    Get C<Log::Log4perl> object with a twist: domains are defined for each
906    method
907    
908     my $log = $webpac->_get_logger();
909    
910    =cut
911    
912    sub _get_logger {
913            my $self = shift;
914    
915            my $name = (caller(1))[3] || caller;
916            return get_logger($name);
917    }
918    
919    =head2 _x
920    
921    Convert string from UTF-8 to code page defined in C<import_xml>.
922    
923     my $text = $webpac->_x('utf8 text');
924    
925    =cut
926    
927    sub _x {
928            my $self = shift;
929            my $utf8 = shift || return;
930    
931            return $self->{'utf2cp'}->convert($utf8) ||
932                    $self->_get_logger()->logwarn("can't convert '$utf8'");
933    }
934    
935    #
936    #
937    #
938    
939    =head1 LOGGING
940    
941    Logging in WebPAC is performed by L<Log::Log4perl> with config file
942    C<log.conf>.
943    
944    Methods defined above have different levels of logging, so
945    it's descriptions will be useful to turn (mostry B<debug> logging) on
946    or off to see why WabPAC isn't perforing as you expect it (it might even
947    be a bug!).
948    
949    B<This is different from normal Log4perl behaviour>. To repeat, you can
950    also use method names, and not only classes (which are just few)
951    to filter logging.
952    
953    =cut
954    
955  1;  1;
Legend:
Removed from v.370  
changed lines
  Added in v.411
  ViewVC Help
Powered by ViewVC 1.1.26