/[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 371 by dpavlin, Thu Jun 17 20:44:45 2004 UTC revision 375 by dpavlin, Sun Jun 20 17:52:41 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 202  it's implemented, that is). Line 218  it's implemented, that is).
218  sub fetch_rec {  sub fetch_rec {
219          my $self = shift;          my $self = shift;
220    
221          my $mfn = $self->{'current_mfn'}++ || confess "it seems that you didn't load database!";          my $log = $self->_get_logger();
222    
223            my $mfn = $self->{'current_mfn'}++ || $log->logconfess("it seems that you didn't load database!");
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 223  Read file from C<import_xml/> directory Line 242  Read file from C<import_xml/> directory
242  sub open_import_xml {  sub open_import_xml {
243          my $self = shift;          my $self = shift;
244    
245            my $log = $self->_get_logger();
246    
247          my $arg = {@_};          my $arg = {@_};
248          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'});
249    
250          $self->{'type'} = $arg->{'type'};          $self->{'type'} = $arg->{'type'};
251    
# Line 233  sub open_import_xml { Line 254  sub open_import_xml {
254    
255          $self->{'tag'} = $type2tag{$type_base};          $self->{'tag'} = $type2tag{$type_base};
256    
257          print STDERR "using type '",$self->{'type'},"' tag <",$self->{'tag'},">\n" 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          confess "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->info("reading '$f'");
263    
264          print STDERR "reading '$f'\n" if ($self->{'debug'});          $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 260  Called internally by C<open_*> methods. Line 284  Called internally by C<open_*> methods.
284  sub create_lookup {  sub create_lookup {
285          my $self = shift;          my $self = shift;
286    
287          my $rec = shift || confess "need record to create lookup";          my $log = $self->_get_logger();
288          confess("need HASH as first argument!") if ($rec !~ /HASH/o);  
289            my $rec = shift || $log->logconfess("need record to create lookup");
290            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
291    
292          foreach my $i (@_) {          foreach my $i (@_) {
293                  if ($i->{'eval'}) {                  if ($i->{'eval'}) {
# Line 269  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 349  delimiters before fields which aren't us Line 377  delimiters before fields which aren't us
377    
378  =cut  =cut
379    
 # internal function to eval code  
 sub _eval {  
         my $self = shift;  
   
         my $code = shift || return;  
         no strict 'subs';  
         my $ret = eval $code;  
         if ($@) {  
                 print STDERR "problem with eval code [$code]: $@\n";  
         }  
         return $ret;  
 }  
   
380  sub fill_in {  sub fill_in {
381          my $self = shift;          my $self = shift;
382    
383          my $rec = shift || confess "need data record";          my $log = $self->_get_logger();
384          my $format = shift || confess "need format to parse";  
385            my $rec = shift || $log->logconfess("need data record");
386            my $format = shift || $log->logconfess("need format to parse");
387          # iteration (for repeatable fields)          # iteration (for repeatable fields)
388          my $i = shift || 0;          my $i = shift || 0;
389    
390          # FIXME remove for speedup?          # FIXME remove for speedup?
391          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
392    
393          my $found = 0;          my $found = 0;
394    
# Line 380  sub fill_in { Line 397  sub fill_in {
397          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
398    
399          # do actual replacement of placeholders          # do actual replacement of placeholders
400          $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;
401    
402          if ($found) {          if ($found) {
403                    $log->debug("format: $format");
404                  if ($eval_code) {                  if ($eval_code) {
405                          my $eval = $self->fill_in($rec,$eval_code,$i);                          my $eval = $self->fill_in($rec,$eval_code,$i);
406                          return if (! $self->_eval($eval));                          return if (! $self->_eval($eval));
407                  }                  }
408                  # do we have lookups?                  # do we have lookups?
409                  if ($format =~ /\[[^\[\]]+\]/o) {                  if ($format =~ /$LOOKUP_REGEX/o) {
410  print "## probable lookup: $format\n";                          $log->debug("format '$format' has lookup");
411                          return $self->lookup($format);                          return $self->lookup($format);
412                  } else {                  } else {
413                          return $format;                          return $format;
# Line 412  Lookups can be nested (like C<[d:[a:[v90 Line 430  Lookups can be nested (like C<[d:[a:[v90
430  sub lookup {  sub lookup {
431          my $self = shift;          my $self = shift;
432    
433          my $tmp = shift || confess "need format";          my $log = $self->_get_logger();
434    
435          if ($tmp =~ /\[[^\[\]]+\]/o) {          my $tmp = shift || $log->logconfess("need format");
436    
437            if ($tmp =~ /$LOOKUP_REGEX/o) {
438                  my @in = ( $tmp );                  my @in = ( $tmp );
439  print "## lookup $tmp\n";  
440                    $log->debug("lookup for: ",$tmp);
441    
442                  my @out;                  my @out;
443                  while (my $f = shift @in) {                  while (my $f = shift @in) {
444                          if ($f =~ /\[([^\[\]]+)\]/) {                          if ($f =~ /$LOOKUP_REGEX_SAVE/o) {
445                                  my $k = $1;                                  my $k = $1;
446                                  if ($self->{'lookup'}->{$k}) {                                  if ($self->{'lookup'}->{$k}) {
447                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {
448                                                  my $tmp2 = $f;                                                  my $tmp2 = $f;
449                                                  $tmp2 =~ s/\[$k\]/$nv/g;                                                  $tmp2 =~ s/lookup{$k}/$nv/g;
450                                                  push @in, $tmp2;                                                  push @in, $tmp2;
451                                          }                                          }
452                                  } else {                                  } else {
# Line 434  print "## lookup $tmp\n"; Line 456  print "## lookup $tmp\n";
456                                  push @out, $f;                                  push @out, $f;
457                          }                          }
458                  }                  }
459                    $log->logconfess("return is array and it's not expected!") unless wantarray;
460                  return @out;                  return @out;
461          } else {          } else {
462                  return $tmp;                  return $tmp;
# Line 457  sub parse { Line 480  sub parse {
480    
481          return if (! $format_utf8);          return if (! $format_utf8);
482    
483          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          my $log = $self->_get_logger();
484          confess("need utf2cp Text::Iconv object!") if (! $self->{'utf2cp'});  
485            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
486            $log->logconfess("need utf2cp Text::Iconv object!") if (! $self->{'utf2cp'});
487    
488          $i = 0 if (! $i);          $i = 0 if (! $i);
489    
490          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'});
491    
492          my @out;          my @out;
493    
494            $log->debug("format: $format");
495    
496          my $eval_code;          my $eval_code;
497          # remove eval{...} from beginning          # remove eval{...} from beginning
498          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
# Line 473  sub parse { Line 500  sub parse {
500          my $prefix;          my $prefix;
501          my $all_found=0;          my $all_found=0;
502    
503          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))*//s) {          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))?//s) {
504    
505                  my $del = $1 || '';                  my $del = $1 || '';
506                  $prefix ||= $del if ($all_found == 0);                  $prefix ||= $del if ($all_found == 0);
# Line 490  sub parse { Line 517  sub parse {
517    
518          return if (! $all_found);          return if (! $all_found);
519    
520          my $out = join('',@out) . $format;          my $out = join('',@out);
521    
522          # add prefix if not there          if ($out) {
523          $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);                  # add rest of format (suffix)
524                    $out .= $format;
525    
526                    # add prefix if not there
527                    $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);
528    
529                    $log->debug("result: $out");
530            }
531    
532          if ($eval_code) {          if ($eval_code) {
533                  my $eval = $self->fill_in($rec,$eval_code,$i);                  my $eval = $self->fill_in($rec,$eval_code,$i);
534                    $log->debug("about to eval{",$eval,"} format: $out");
535                  return if (! $self->_eval($eval));                  return if (! $self->_eval($eval));
536          }          }
537    
# Line 516  sub parse_to_arr { Line 551  sub parse_to_arr {
551    
552          my ($rec, $format_utf8) = @_;          my ($rec, $format_utf8) = @_;
553    
554          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          my $log = $self->_get_logger();
555    
556            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
557          return if (! $format_utf8);          return if (! $format_utf8);
558    
559          my $i = 0;          my $i = 0;
# Line 526  sub parse_to_arr { Line 563  sub parse_to_arr {
563                  push @arr, $v;                  push @arr, $v;
564          }          }
565    
566            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
567    
568          return @arr;          return @arr;
569  }  }
570    
571  =head2 data_structure  =head2 fill_in_to_arr
572    
573  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
574  It is used later to produce output.  for fields which have lookups, so they shouldn't be parsed but rather
575    C<fill_id>ed.
576    
577   my @ds = $webpac->data_structure($rec);   my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]');
578    
579  =cut  =cut
580    
581  # private method _sort_by_order  sub fill_in_to_arr {
 # sort subrouting using order="" attribute  
 sub _sort_by_order {  
582          my $self = shift;          my $self = shift;
583    
584          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};  
585    
586          return $va <=> $vb;          my $log = $self->_get_logger();
587    
588            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
589            return if (! $format_utf8);
590    
591            my $i = 0;
592            my @arr;
593    
594            while (my @v = $self->fill_in($rec,$format_utf8,$i++)) {
595                    push @arr, @v;
596            }
597    
598            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
599    
600            return @arr;
601  }  }
602    
603    
604    =head2 data_structure
605    
606    Create in-memory data structure which represents layout from C<import_xml>.
607    It is used later to produce output.
608    
609     my @ds = $webpac->data_structure($rec);
610    
611    This method will also set C<$webpac->{'currnet_filename'}> if there is
612    <filename> tag in C<import_xml>.
613    
614    =cut
615    
616  sub data_structure {  sub data_structure {
617          my $self = shift;          my $self = shift;
618    
619            my $log = $self->_get_logger();
620    
621          my $rec = shift;          my $rec = shift;
622          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
623    
624            undef $self->{'currnet_filename'};
625    
626          my @sorted_tags;          my @sorted_tags;
627          if ($self->{tags_by_order}) {          if ($self->{tags_by_order}) {
# Line 567  sub data_structure { Line 633  sub data_structure {
633    
634          my @ds;          my @ds;
635    
636            $log->debug("tags: ",sub { join(", ",@sorted_tags) });
637    
638          foreach my $field (@sorted_tags) {          foreach my $field (@sorted_tags) {
639    
640                  my $row;                  my $row;
# Line 574  sub data_structure { Line 642  sub data_structure {
642  #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'}});
643    
644                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
645                          my @v = $self->parse_to_arr($rec,$tag->{'content'});                          my $format = $tag->{'value'} || $tag->{'content'};
646    
647                            $log->debug("format: $format");
648    
649                            my @v;
650                            if ($format =~ /$LOOKUP_REGEX/o) {
651                                    @v = $self->fill_in_to_arr($rec,$format);
652                            } else {
653                                    @v = $self->parse_to_arr($rec,$format);
654                            }
655                          next if (! @v);                          next if (! @v);
656    
657                            # use format?
658                            if ($tag->{'format_name'}) {
659                                    @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
660                            }
661    
662                          # does tag have type?                          # does tag have type?
663                          if ($tag->{'type'}) {                          if ($tag->{'type'}) {
664                                  push @{$row->{$tag->{'type'}}}, @v;                                  push @{$row->{$tag->{'type'}}}, @v;
# Line 585  sub data_structure { Line 666  sub data_structure {
666                                  push @{$row->{'display'}}, @v;                                  push @{$row->{'display'}}, @v;
667                                  push @{$row->{'swish'}}, @v;                                  push @{$row->{'swish'}}, @v;
668                          }                          }
669    
670                            if ($field eq 'filename') {
671                                    $self->{'current_filename'} = join('',@v);
672                                    $log->debug("filename: ",$self->{'current_filename'});
673                            }
674    
675                  }                  }
676    
677                  if ($row) {                  if ($row) {
678                          $row->{'tag'} = $field;                          $row->{'tag'} = $field;
679    
680                            # TODO: name_sigular, name_plural
681                            my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
682                            $row->{'name'} = $name ? $self->_x($name) : $field;
683    
684                          push @ds, $row;                          push @ds, $row;
685    
686                            $log->debug("row $field: ",sub { Dumper($row) });
687                  }                  }
688    
689          }          }
# Line 611  sub output { Line 705  sub output {
705    
706          my $args = {@_};          my $args = {@_};
707    
708          confess("need template name") if (! $args->{'template'});          my $log = $self->_get_logger();
709          confess("need data array") if (! $args->{'data'});  
710            $log->logconfess("need template name") if (! $args->{'template'});
711            $log->logconfess("need data array") if (! $args->{'data'});
712    
713          my $out;          my $out;
714    
# Line 625  sub output { Line 721  sub output {
721          return $out;          return $out;
722  }  }
723    
724    =head2 apply_format
725    
726    Apply format specified in tag with C<format_name="name"> and
727    C<format_delimiter=";;">.
728    
729     my $text = $webpac->apply_format($format_name,$format_delimiter,$data);
730    
731    Formats can contain C<lookup{...}> if you need them.
732    
733    =cut
734    
735    sub apply_format {
736            my $self = shift;
737    
738            my ($name,$delimiter,$data) = @_;
739    
740            my $log = $self->_get_logger();
741    
742            if (! $self->{'import_xml'}->{'format'}->{$name}) {
743                    $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});
744                    return $data;
745            }
746    
747            $log->warn("no delimiter for format $name") if (! $delimiter);
748    
749            my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");
750    
751            my @data = split(/\Q$delimiter\E/, $data);
752    
753            my $out = sprintf($format, @data);
754            $log->debug("using format $name [$format] on $data to produce: $out");
755    
756            if ($out =~ m/$LOOKUP_REGEX/o) {
757                    return $self->lookup($out);
758            } else {
759                    return $out;
760            }
761    
762    }
763    
764    
765    #
766    #
767    #
768    
769    =head1 INTERNAL METHODS
770    
771    Here is a quick list of internal methods, mostly useful to turn debugging
772    on them (see L<LOGGING> below for explanation).
773    
774    =cut
775    
776    =head2 _eval
777    
778    Internal function to eval code without C<strict 'subs'>.
779    
780    =cut
781    
782    sub _eval {
783            my $self = shift;
784    
785            my $code = shift || return;
786    
787            my $log = $self->_get_logger();
788    
789            no strict 'subs';
790            my $ret = eval $code;
791            if ($@) {
792                    $log->error("problem with eval code [$code]: $@");
793            }
794    
795            $log->debug("eval: ",$code," [",$ret,"]");
796    
797            return $ret || 0;
798    }
799    
800    =head2 _sort_by_order
801    
802    Sort xml tags data structure accoding to C<order=""> attribute.
803    
804    =cut
805    
806    sub _sort_by_order {
807            my $self = shift;
808    
809            my $va = $self->{'import_xml'}->{'indexer'}->{$a}->{'order'} ||
810                    $self->{'import_xml'}->{'indexer'}->{$a};
811            my $vb = $self->{'import_xml'}->{'indexer'}->{$b}->{'order'} ||
812                    $self->{'import_xml'}->{'indexer'}->{$b};
813    
814            return $va <=> $vb;
815    }
816    
817    =head2 _get_logger
818    
819    Get C<Log::Log4perl> object with a twist: domains are defined for each
820    method
821    
822     my $log = $webpac->_get_logger();
823    
824    =cut
825    
826    sub _get_logger {
827            my $self = shift;
828    
829            my $name = (caller(1))[3] || caller;
830            return get_logger($name);
831    }
832    
833    =head2 _x
834    
835    Convert string from UTF-8 to code page defined in C<import_xml>.
836    
837     my $text = $webpac->_x('utf8 text');
838    
839    =cut
840    
841    sub _x {
842            my $self = shift;
843            my $utf8 = shift || return;
844    
845            return $self->{'utf2cp'}->convert($utf8) ||
846                    $self->_get_logger()->logwarn("can't convert '$utf8'");
847    }
848    
849    #
850    #
851    #
852    
853    =head1 LOGGING
854    
855    Logging in WebPAC is performed by L<Log::Log4perl> with config file
856    C<log.conf>.
857    
858    Methods defined above have different levels of logging, so
859    it's descriptions will be useful to turn (mostry B<debug> logging) on
860    or off to see why WabPAC isn't perforing as you expect it (it might even
861    be a bug!).
862    
863    B<This is different from normal Log4perl behaviour>. To repeat, you can
864    also use method names, and not only classes (which are just few)
865    to filter logging.
866    
867    =cut
868    
869  1;  1;
Legend:
Removed from v.371  
changed lines
  Added in v.375
  ViewVC Help
Powered by ViewVC 1.1.26