/[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 412 by dpavlin, Tue Sep 7 18:01:36 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            print STDERR "\n" if ($p == 100);
272    }
273    
274  =head2 open_import_xml  =head2 open_import_xml
275    
276  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 282  Read file from C<import_xml/> directory
282  sub open_import_xml {  sub open_import_xml {
283          my $self = shift;          my $self = shift;
284    
285            my $log = $self->_get_logger();
286    
287          my $arg = {@_};          my $arg = {@_};
288          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'});
289    
290          $self->{'type'} = $arg->{'type'};          $self->{'type'} = $arg->{'type'};
291    
# Line 233  sub open_import_xml { Line 294  sub open_import_xml {
294    
295          $self->{'tag'} = $type2tag{$type_base};          $self->{'tag'} = $type2tag{$type_base};
296    
297          print STDERR "using type ",$self->{'type'}," tag ",$self->{'tag'},"\n" if ($self->{'debug'});          $log->info("using type '",$self->{'type'},"' tag <",$self->{'tag'},">");
298    
299          my $f = "./import_xml/".$self->{'type'}.".xml";          my $f = "./import_xml/".$self->{'type'}.".xml";
300          confess "import_xml file '$f' doesn't exist!" if (! -e "$f");          $log->logconfess("import_xml file '$f' doesn't exist!") if (! -e "$f");
301    
302            $log->info("reading '$f'");
303    
304          print STDERR "reading '$f'\n" if ($self->{'debug'});          $self->{'import_xml_file'} = $f;
305    
306          $self->{'import_xml'} = XMLin($f,          $self->{'import_xml'} = XMLin($f,
307                  ForceArray => [ $self->{'tag'}, 'config', 'format' ],                  ForceArray => [ $self->{'tag'}, 'config', 'format' ],
                 ForceContent => 1  
308          );          );
309    
310            $log->debug("import xml is ",sub { Dumper($self->{'import_xml'}) });
311    
312  }  }
313    
314  =head2 create_lookup  =head2 create_lookup
# Line 260  Called internally by C<open_*> methods. Line 324  Called internally by C<open_*> methods.
324  sub create_lookup {  sub create_lookup {
325          my $self = shift;          my $self = shift;
326    
327          my $rec = shift || confess "need record to create lookup";          my $log = $self->_get_logger();
328          confess("need HASH as first argument!") if ($rec !~ /HASH/o);  
329            my $rec = shift || $log->logconfess("need record to create lookup");
330            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
331    
332          foreach my $i (@_) {          foreach my $i (@_) {
333                  if ($i->{'eval'}) {                  if ($i->{'eval'}) {
# Line 269  sub create_lookup { Line 335  sub create_lookup {
335                          my $key = $self->fill_in($rec,$i->{'key'});                          my $key = $self->fill_in($rec,$i->{'key'});
336                          my @val = $self->fill_in($rec,$i->{'val'});                          my @val = $self->fill_in($rec,$i->{'val'});
337                          if ($key && @val && eval $eval) {                          if ($key && @val && eval $eval) {
338                                    $log->debug("stored $key = ",sub { join(" | ",@val) });
339                                  push @{$self->{'lookup'}->{$key}}, @val;                                  push @{$self->{'lookup'}->{$key}}, @val;
340                          }                          }
341                  } else {                  } else {
342                          my $key = $self->fill_in($rec,$i->{'key'});                          my $key = $self->fill_in($rec,$i->{'key'});
343                          my @val = $self->fill_in($rec,$i->{'val'});                          my @val = $self->fill_in($rec,$i->{'val'});
344                          if ($key && @val) {                          if ($key && @val) {
345                                    $log->debug("stored $key = ",sub { join(" | ",@val) });
346                                  push @{$self->{'lookup'}->{$key}}, @val;                                  push @{$self->{'lookup'}->{$key}}, @val;
347                          }                          }
348                  }                  }
# Line 307  sub get_data { Line 375  sub get_data {
375    
376          if ($$rec->{$f}) {          if ($$rec->{$f}) {
377                  return '' if (! $$rec->{$f}->[$i]);                  return '' if (! $$rec->{$f}->[$i]);
378                    no strict 'refs';
379                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {
380                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
381                          return $$rec->{$f}->[$i]->{$sf};                          return $$rec->{$f}->[$i]->{$sf};
# Line 347  Following example will read second value Line 416  Following example will read second value
416  This function B<does not> perform parsing of format to inteligenty skip  This function B<does not> perform parsing of format to inteligenty skip
417  delimiters before fields which aren't used.  delimiters before fields which aren't used.
418    
419    This method will automatically decode UTF-8 string to local code page
420    if needed.
421    
422  =cut  =cut
423    
424  sub fill_in {  sub fill_in {
425          my $self = shift;          my $self = shift;
426    
427          my $rec = shift || confess "need data record";          my $log = $self->_get_logger();
428          my $format = shift || confess "need format to parse";  
429            my $rec = shift || $log->logconfess("need data record");
430            my $format = shift || $log->logconfess("need format to parse");
431          # iteration (for repeatable fields)          # iteration (for repeatable fields)
432          my $i = shift || 0;          my $i = shift || 0;
433    
434          # FIXME remove for speedup?          # FIXME remove for speedup?
435          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
436    
437            if (utf8::is_utf8($format)) {
438                    $format = $self->_x($format);
439            }
440    
441          my $found = 0;          my $found = 0;
442    
# Line 367  sub fill_in { Line 445  sub fill_in {
445          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
446    
447          # do actual replacement of placeholders          # do actual replacement of placeholders
448          $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;
449    
450          if ($found) {          if ($found) {
451                    $log->debug("format: $format");
452                  if ($eval_code) {                  if ($eval_code) {
453                          my $eval = $self->fill_in($rec,$eval_code,$i);                          my $eval = $self->fill_in($rec,$eval_code,$i);
454                          return if (! eval $eval);                          return if (! $self->_eval($eval));
455                  }                  }
456                  # do we have lookups?                  # do we have lookups?
457                  if ($format =~ /\[[^\[\]]+\]/o) {                  if ($format =~ /$LOOKUP_REGEX/o) {
458                            $log->debug("format '$format' has lookup");
459                          return $self->lookup($format);                          return $self->lookup($format);
460                  } else {                  } else {
461                          return $format;                          return $format;
# Line 398  Lookups can be nested (like C<[d:[a:[v90 Line 478  Lookups can be nested (like C<[d:[a:[v90
478  sub lookup {  sub lookup {
479          my $self = shift;          my $self = shift;
480    
481          my $tmp = shift || confess "need format";          my $log = $self->_get_logger();
482    
483          if ($tmp =~ /\[[^\[\]]+\]/o) {          my $tmp = shift || $log->logconfess("need format");
484    
485            if ($tmp =~ /$LOOKUP_REGEX/o) {
486                  my @in = ( $tmp );                  my @in = ( $tmp );
487    
488                    $log->debug("lookup for: ",$tmp);
489    
490                  my @out;                  my @out;
491                  while (my $f = shift @in) {                  while (my $f = shift @in) {
492                          if ($f =~ /\[([^\[\]]+)\]/) {                          if ($f =~ /$LOOKUP_REGEX_SAVE/o) {
493                                  my $k = $1;                                  my $k = $1;
494                                  if ($self->{'lookup'}->{$k}) {                                  if ($self->{'lookup'}->{$k}) {
495                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {
496                                                  my $tmp2 = $f;                                                  my $tmp2 = $f;
497                                                  $tmp2 =~ s/\[$k\]/$nv/g;                                                  $tmp2 =~ s/lookup{$k}/$nv/g;
498                                                  push @in, $tmp2;                                                  push @in, $tmp2;
499                                          }                                          }
500                                  } else {                                  } else {
# Line 419  sub lookup { Line 504  sub lookup {
504                                  push @out, $f;                                  push @out, $f;
505                          }                          }
506                  }                  }
507                    $log->logconfess("return is array and it's not expected!") unless wantarray;
508                  return @out;                  return @out;
509          } else {          } else {
510                  return $tmp;                  return $tmp;
# Line 442  sub parse { Line 528  sub parse {
528    
529          return if (! $format_utf8);          return if (! $format_utf8);
530    
531          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          my $log = $self->_get_logger();
532          confess("need utf2cp Text::Iconv object!") if (! $self->{'utf2cp'});  
533            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
534            $log->logconfess("need utf2cp Text::Iconv object!") if (! $self->{'utf2cp'});
535    
536          $i = 0 if (! $i);          $i = 0 if (! $i);
537    
538          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'});
539    
540          my @out;          my @out;
541    
542            $log->debug("format: $format");
543    
544          my $eval_code;          my $eval_code;
545          # remove eval{...} from beginning          # remove eval{...} from beginning
546          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
# Line 458  sub parse { Line 548  sub parse {
548          my $prefix;          my $prefix;
549          my $all_found=0;          my $all_found=0;
550    
551          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))*//s) {          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))?//s) {
552    
553                  my $del = $1 || '';                  my $del = $1 || '';
554                  $prefix ||= $del if ($all_found == 0);                  $prefix ||= $del if ($all_found == 0);
# Line 475  sub parse { Line 565  sub parse {
565    
566          return if (! $all_found);          return if (! $all_found);
567    
568          my $out = join('',@out) . $format;          my $out = join('',@out);
569    
570            if ($out) {
571                    # add rest of format (suffix)
572                    $out .= $format;
573    
574          # add prefix if not there                  # add prefix if not there
575          $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);                  $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);
576    
577                    $log->debug("result: $out");
578            }
579    
580          if ($eval_code) {          if ($eval_code) {
581                  my $eval = $self->fill_in($rec,$eval_code,$i);                  my $eval = $self->fill_in($rec,$eval_code,$i);
582                  return if (! eval $eval);                  $log->debug("about to eval{",$eval,"} format: $out");
583                    return if (! $self->_eval($eval));
584          }          }
585    
586          return $out;          return $out;
# Line 501  sub parse_to_arr { Line 599  sub parse_to_arr {
599    
600          my ($rec, $format_utf8) = @_;          my ($rec, $format_utf8) = @_;
601    
602          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          my $log = $self->_get_logger();
603    
604            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
605          return if (! $format_utf8);          return if (! $format_utf8);
606    
607          my $i = 0;          my $i = 0;
# Line 511  sub parse_to_arr { Line 611  sub parse_to_arr {
611                  push @arr, $v;                  push @arr, $v;
612          }          }
613    
614            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
615    
616          return @arr;          return @arr;
617  }  }
618    
619  =head2 data_structure  =head2 fill_in_to_arr
620    
621  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
622  It is used later to produce output.  for fields which have lookups, so they shouldn't be parsed but rather
623    C<fill_id>ed.
624    
625   my @ds = $webpac->data_structure($rec);   my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]');
626    
627  =cut  =cut
628    
629  # private method _sort_by_order  sub fill_in_to_arr {
 # sort subrouting using order="" attribute  
 sub _sort_by_order {  
630          my $self = shift;          my $self = shift;
631    
632          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};  
633    
634          return $va <=> $vb;          my $log = $self->_get_logger();
635    
636            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
637            return if (! $format_utf8);
638    
639            my $i = 0;
640            my @arr;
641    
642            while (my @v = $self->fill_in($rec,$format_utf8,$i++)) {
643                    push @arr, @v;
644            }
645    
646            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
647    
648            return @arr;
649  }  }
650    
651    
652    =head2 data_structure
653    
654    Create in-memory data structure which represents layout from C<import_xml>.
655    It is used later to produce output.
656    
657     my @ds = $webpac->data_structure($rec);
658    
659    This method will also set C<$webpac->{'currnet_filename'}> if there is
660    <filename> tag in C<import_xml> and C<$webpac->{'headline'}> if there is
661    <headline> tag.
662    
663    =cut
664    
665  sub data_structure {  sub data_structure {
666          my $self = shift;          my $self = shift;
667    
668            my $log = $self->_get_logger();
669    
670          my $rec = shift;          my $rec = shift;
671          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
672    
673            undef $self->{'currnet_filename'};
674            undef $self->{'headline'};
675    
676          my @sorted_tags;          my @sorted_tags;
677          if ($self->{tags_by_order}) {          if ($self->{tags_by_order}) {
# Line 552  sub data_structure { Line 683  sub data_structure {
683    
684          my @ds;          my @ds;
685    
686            $log->debug("tags: ",sub { join(", ",@sorted_tags) });
687    
688          foreach my $field (@sorted_tags) {          foreach my $field (@sorted_tags) {
689    
690                  my $row;                  my $row;
# Line 559  sub data_structure { Line 692  sub data_structure {
692  #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'}});
693    
694                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
695                          my @v = $self->parse_to_arr($rec,$tag->{'content'});                          my $format = $tag->{'value'} || $tag->{'content'};
696    
697                            $log->debug("format: $format");
698    
699                            my @v;
700                            if ($format =~ /$LOOKUP_REGEX/o) {
701                                    @v = $self->fill_in_to_arr($rec,$format);
702                            } else {
703                                    @v = $self->parse_to_arr($rec,$format);
704                            }
705                          next if (! @v);                          next if (! @v);
706    
707                            # use format?
708                            if ($tag->{'format_name'}) {
709                                    @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
710                            }
711    
712                            if ($field eq 'filename') {
713                                    $self->{'current_filename'} = join('',@v);
714                                    $log->debug("filename: ",$self->{'current_filename'});
715                            } elsif ($field eq 'headline') {
716                                    $self->{'headline'} .= join('',@v);
717                                    $log->debug("headline: ",$self->{'headline'});
718                                    next; # don't return headline in data_structure!
719                            }
720    
721                          # does tag have type?                          # does tag have type?
722                          if ($tag->{'type'}) {                          if ($tag->{'type'}) {
723                                  push @{$row->{$tag->{'type'}}}, @v;                                  push @{$row->{$tag->{'type'}}}, @v;
# Line 570  sub data_structure { Line 725  sub data_structure {
725                                  push @{$row->{'display'}}, @v;                                  push @{$row->{'display'}}, @v;
726                                  push @{$row->{'swish'}}, @v;                                  push @{$row->{'swish'}}, @v;
727                          }                          }
728    
729    
730                  }                  }
731    
732                  if ($row) {                  if ($row) {
733                          $row->{'tag'} = $field;                          $row->{'tag'} = $field;
734    
735                            # TODO: name_sigular, name_plural
736                            my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
737                            $row->{'name'} = $name ? $self->_x($name) : $field;
738    
739                          push @ds, $row;                          push @ds, $row;
740    
741                            $log->debug("row $field: ",sub { Dumper($row) });
742                  }                  }
743    
744          }          }
# Line 596  sub output { Line 760  sub output {
760    
761          my $args = {@_};          my $args = {@_};
762    
763          confess("need template name") if (! $args->{'template'});          my $log = $self->_get_logger();
764          confess("need data array") if (! $args->{'data'});  
765            $log->logconfess("need template name") if (! $args->{'template'});
766            $log->logconfess("need data array") if (! $args->{'data'});
767    
768          my $out;          my $out;
769    
# Line 610  sub output { Line 776  sub output {
776          return $out;          return $out;
777  }  }
778    
779    =head2 output_file
780    
781    Create output from in-memory data structure using Template Toolkit template
782    to a file.
783    
784     $webpac->output_file(
785            file => 'out.txt',
786            template => 'text.tt',
787            data => @ds
788     );
789    
790    =cut
791    
792    sub output_file {
793            my $self = shift;
794    
795            my $args = {@_};
796    
797            my $log = $self->_get_logger();
798    
799            $log->logconfess("need file name") if (! $args->{'file'});
800    
801            $log->debug("creating file ",$args->{'file'});
802    
803            open(my $fh, ">", $args->{'file'}) || $log->logdie("can't open output file '$self->{'file'}': $!");
804            print $fh $self->output(
805                    template => $args->{'template'},
806                    data => $args->{'data'},
807            ) || $log->logdie("print: $!");
808            close($fh) || $log->logdie("close: $!");
809    }
810    
811    =head2 apply_format
812    
813    Apply format specified in tag with C<format_name="name"> and
814    C<format_delimiter=";;">.
815    
816     my $text = $webpac->apply_format($format_name,$format_delimiter,$data);
817    
818    Formats can contain C<lookup{...}> if you need them.
819    
820    =cut
821    
822    sub apply_format {
823            my $self = shift;
824    
825            my ($name,$delimiter,$data) = @_;
826    
827            my $log = $self->_get_logger();
828    
829            if (! $self->{'import_xml'}->{'format'}->{$name}) {
830                    $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});
831                    return $data;
832            }
833    
834            $log->warn("no delimiter for format $name") if (! $delimiter);
835    
836            my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");
837    
838            my @data = split(/\Q$delimiter\E/, $data);
839    
840            my $out = sprintf($format, @data);
841            $log->debug("using format $name [$format] on $data to produce: $out");
842    
843            if ($out =~ m/$LOOKUP_REGEX/o) {
844                    return $self->lookup($out);
845            } else {
846                    return $out;
847            }
848    
849    }
850    
851    
852    #
853    #
854    #
855    
856    =head1 INTERNAL METHODS
857    
858    Here is a quick list of internal methods, mostly useful to turn debugging
859    on them (see L<LOGGING> below for explanation).
860    
861    =cut
862    
863    =head2 _eval
864    
865    Internal function to eval code without C<strict 'subs'>.
866    
867    =cut
868    
869    sub _eval {
870            my $self = shift;
871    
872            my $code = shift || return;
873    
874            my $log = $self->_get_logger();
875    
876            no strict 'subs';
877            my $ret = eval $code;
878            if ($@) {
879                    $log->error("problem with eval code [$code]: $@");
880            }
881    
882            $log->debug("eval: ",$code," [",$ret,"]");
883    
884            return $ret || 0;
885    }
886    
887    =head2 _sort_by_order
888    
889    Sort xml tags data structure accoding to C<order=""> attribute.
890    
891    =cut
892    
893    sub _sort_by_order {
894            my $self = shift;
895    
896            my $va = $self->{'import_xml'}->{'indexer'}->{$a}->{'order'} ||
897                    $self->{'import_xml'}->{'indexer'}->{$a};
898            my $vb = $self->{'import_xml'}->{'indexer'}->{$b}->{'order'} ||
899                    $self->{'import_xml'}->{'indexer'}->{$b};
900    
901            return $va <=> $vb;
902    }
903    
904    =head2 _get_logger
905    
906    Get C<Log::Log4perl> object with a twist: domains are defined for each
907    method
908    
909     my $log = $webpac->_get_logger();
910    
911    =cut
912    
913    sub _get_logger {
914            my $self = shift;
915    
916            my $name = (caller(1))[3] || caller;
917            return get_logger($name);
918    }
919    
920    =head2 _x
921    
922    Convert string from UTF-8 to code page defined in C<import_xml>.
923    
924     my $text = $webpac->_x('utf8 text');
925    
926    =cut
927    
928    sub _x {
929            my $self = shift;
930            my $utf8 = shift || return;
931    
932            return $self->{'utf2cp'}->convert($utf8) ||
933                    $self->_get_logger()->logwarn("can't convert '$utf8'");
934    }
935    
936    #
937    #
938    #
939    
940    =head1 LOGGING
941    
942    Logging in WebPAC is performed by L<Log::Log4perl> with config file
943    C<log.conf>.
944    
945    Methods defined above have different levels of logging, so
946    it's descriptions will be useful to turn (mostry B<debug> logging) on
947    or off to see why WabPAC isn't perforing as you expect it (it might even
948    be a bug!).
949    
950    B<This is different from normal Log4perl behaviour>. To repeat, you can
951    also use method names, and not only classes (which are just few)
952    to filter logging.
953    
954    =cut
955    
956  1;  1;
Legend:
Removed from v.370  
changed lines
  Added in v.412
  ViewVC Help
Powered by ViewVC 1.1.26