/[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 367 by dpavlin, Thu Jun 17 12:05:01 2004 UTC revision 418 by dpavlin, Thu Sep 9 18:08:38 2004 UTC
# Line 7  use Carp; Line 7  use Carp;
7  use Text::Iconv;  use Text::Iconv;
8  use Config::IniFiles;  use Config::IniFiles;
9  use XML::Simple;  use XML::Simple;
10    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 52  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 59  sub new { Line 71  sub new {
71          #          #
72          # read global.conf          # read global.conf
73          #          #
74            $log->debug("read 'global.conf'");
75    
76          $self->{global_config_file} = 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 70  sub new { Line 83  sub new {
83                          dbi_passwd                          dbi_passwd
84                          show_progress                          show_progress
85                          my_unac_filter                          my_unac_filter
86                            output_template
87                  )) {                  )) {
88                  $self->{global_config}->{$var} = $self->{global_config_file}->val('global', $var);                  $self->{'global_config'}->{$var} = $config->val('global', $var);
89          }          }
90    
91          #          #
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
98          $self->{'utf2cp'} = Text::Iconv->new('UTF-8' ,$self->{'code_page'});          $self->{'utf2cp'} = Text::Iconv->new('UTF-8' ,$self->{'code_page'});
99    
100            # create Template toolkit instance
101            $self->{'tt'} = Template->new(
102                    INCLUDE_PATH => ($self->{'global_config_file'}->{'output_template'} || './output_template'),
103    #               FILTERS => {
104    #                       'foo' => \&foo_filter,
105    #               },
106                    EVAL_PERL => 1,
107            );
108    
109          return $self;          return $self;
110  }  }
111    
# Line 119  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 129  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 137  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++) {
171    
172    
173                    $log->debug("mfn: $mfn\n");
174    
175                  # read record                  # read record
176                  my $row = OpenIsis::read( $isis_db, $mfn );                  my $row = OpenIsis::read( $isis_db, $mfn );
177                  foreach my $k (keys %{$row}) {                  foreach my $k (keys %{$row}) {
# Line 161  sub open_isis { Line 191  sub open_isis {
191    
192                                          push @{$self->{'data'}->{$mfn}->{$k}}, $val;                                          push @{$self->{'data'}->{$mfn}->{$k}}, $val;
193                                  }                                  }
194                            } else {
195                                    push @{$self->{'data'}->{$mfn}->{'000'}}, $mfn;
196                          }                          }
197    
198                  }                  }
199    
200                  # create lookup                  # create lookup
201                  my $rec = $self->{'data'}->{$mfn};                  my $rec = $self->{'data'}->{$mfn} || $log->confess("record $mfn empty?");
202                  $self->create_lookup($rec, @{$arg->{'lookup'}});                  $self->create_lookup($rec, @{$arg->{'lookup'}});
203    
204                    $self->progress_bar($mfn,$maxmfn);
205    
206          }          }
207    
208          $self->{'current_mfn'} = 1;          $self->{'current_mfn'} = 1;
209            $self->{'last_pcnt'} = 0;
210    
211            $log->debug("max mfn: $maxmfn");
212    
213          # store max mfn and return it.          # store max mfn and return it.
214          return $self->{'max_mfn'} = $maxmfn;          return $self->{'max_mfn'} = $maxmfn;
# Line 189  it's implemented, that is). Line 226  it's implemented, that is).
226  sub fetch_rec {  sub fetch_rec {
227          my $self = shift;          my $self = shift;
228    
229          my $mfn = $self->{'current_mfn'}++ || confess "it seems that you didn't load database!";          my $log = $self->_get_logger();
230    
231            my $mfn = $self->{'current_mfn'}++ || $log->logconfess("it seems that you didn't load database!");
232    
233          if ($mfn > $self->{'max_mfn'}) {          if ($mfn > $self->{'max_mfn'}) {
234                  $self->{'current_mfn'} = $self->{'max_mfn'};                  $self->{'current_mfn'} = $self->{'max_mfn'};
235                    $log->debug("at EOF");
236                  return;                  return;
237          }          }
238    
239            $self->progress_bar($mfn,$self->{'max_mfn'});
240    
241          return $self->{'data'}->{$mfn};          return $self->{'data'}->{$mfn};
242  }  }
243    
244    =head2 progress_bar
245    
246    Draw progress bar on STDERR.
247    
248     $webpac->progress_bar($current, $max);
249    
250    =cut
251    
252    sub progress_bar {
253            my $self = shift;
254    
255            my ($curr,$max) = @_;
256    
257            my $log = $self->_get_logger();
258    
259            $log->logconfess("no current value!") if (! $curr);
260            $log->logconfess("no maximum value!") if (! $max);
261    
262            if ($curr > $max) {
263                    $max = $curr;
264                    $log->debug("overflow to $curr");
265            }
266    
267            $self->{'last_pcnt'} ||= 1;
268    
269            $self->{'last_pcnt'} = $curr if ($curr < $self->{'last_pcnt'});
270    
271            my $p = int($curr * 100 / $max);
272            if ($p != $self->{'last_pcnt'}) {
273                    printf STDERR ("%5d / %5d [%-51s] %-2d %% \r",$curr,$max,"=" x ($p/2).">", $p );
274                    $self->{'last_pcnt'} = $p;
275            }
276            print STDERR "\n" if ($p == 100);
277    }
278    
279  =head2 open_import_xml  =head2 open_import_xml
280    
281  Read file from C<import_xml/> directory and parse it.  Read file from C<import_xml/> directory and parse it.
# Line 210  Read file from C<import_xml/> directory Line 287  Read file from C<import_xml/> directory
287  sub open_import_xml {  sub open_import_xml {
288          my $self = shift;          my $self = shift;
289    
290            my $log = $self->_get_logger();
291    
292          my $arg = {@_};          my $arg = {@_};
293          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'});
294    
295          $self->{'type'} = $arg->{'type'};          $self->{'type'} = $arg->{'type'};
296    
# Line 220  sub open_import_xml { Line 299  sub open_import_xml {
299    
300          $self->{'tag'} = $type2tag{$type_base};          $self->{'tag'} = $type2tag{$type_base};
301    
302          print STDERR "using type ",$self->{'type'}," tag ",$self->{'tag'},"\n" if ($self->{'debug'});          $log->info("using type '",$self->{'type'},"' tag <",$self->{'tag'},">");
303    
304          my $f = "./import_xml/".$self->{'type'}.".xml";          my $f = "./import_xml/".$self->{'type'}.".xml";
305          confess "import_xml file '$f' doesn't exist!" if (! -e "$f");          $log->logconfess("import_xml file '$f' doesn't exist!") if (! -e "$f");
306    
307            $log->info("reading '$f'");
308    
309          print STDERR "reading '$f'\n" if ($self->{'debug'});          $self->{'import_xml_file'} = $f;
310    
311          $self->{'import_xml'} = XMLin($f,          $self->{'import_xml'} = XMLin($f,
312                  ForceArray => [ $self->{'tag'}, 'config', 'format' ],                  ForceArray => [ $self->{'tag'}, 'config', 'format' ],
                 ForceContent => 1  
313          );          );
314    
315          print Dumper($self->{'import_xml'});          $log->debug("import xml is ",sub { Dumper($self->{'import_xml'}) });
316    
317  }  }
318    
# Line 249  Called internally by C<open_*> methods. Line 329  Called internally by C<open_*> methods.
329  sub create_lookup {  sub create_lookup {
330          my $self = shift;          my $self = shift;
331    
332          my $rec = shift || confess "need record to create lookup";          my $log = $self->_get_logger();
333          confess("need HASH as first argument!") if ($rec !~ /HASH/o);  
334            my $rec = shift || $log->logconfess("need record to create lookup");
335            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
336    
337          foreach my $i (@_) {          foreach my $i (@_) {
338                  if ($i->{'eval'}) {                  $log->logconfess("need key") unless defined($i->{'key'});
339                          my $eval = $self->fill_in($rec,$i->{'eval'});                  $log->logconfess("need val") unless defined($i->{'val'});
340                          my $key = $self->fill_in($rec,$i->{'key'});  
341                          my @val = $self->fill_in($rec,$i->{'val'});                  if (defined($i->{'eval'})) {
342                          if ($key && @val && eval $eval) {                          # eval first, so we can skip fill_in for key and val
343                            my $eval = $self->fill_in($rec,$i->{'eval'}) || next;
344                            if ($self->_eval($eval)) {
345                                    my $key = $self->fill_in($rec,$i->{'key'}) || next;
346                                    my @val = $self->fill_in($rec,$i->{'val'}) || next;
347                                    $log->debug("stored $key = ",sub { join(" | ",@val) });
348                                  push @{$self->{'lookup'}->{$key}}, @val;                                  push @{$self->{'lookup'}->{$key}}, @val;
349                          }                          }
350                  } else {                  } else {
351                          my $key = $self->fill_in($rec,$i->{'key'});                          my $key = $self->fill_in($rec,$i->{'key'}) || next;
352                          my @val = $self->fill_in($rec,$i->{'val'});                          my @val = $self->fill_in($rec,$i->{'val'}) || next;
353                          if ($key && @val) {                          $log->debug("stored $key = ",sub { join(" | ",@val) });
354                                  push @{$self->{'lookup'}->{$key}}, @val;                          push @{$self->{'lookup'}->{$key}}, @val;
                         }  
355                  }                  }
356          }          }
357  }  }
# Line 296  sub get_data { Line 382  sub get_data {
382    
383          if ($$rec->{$f}) {          if ($$rec->{$f}) {
384                  return '' if (! $$rec->{$f}->[$i]);                  return '' if (! $$rec->{$f}->[$i]);
385                    no strict 'refs';
386                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {
387                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
388                          return $$rec->{$f}->[$i]->{$sf};                          return $$rec->{$f}->[$i]->{$sf};
# Line 336  Following example will read second value Line 423  Following example will read second value
423  This function B<does not> perform parsing of format to inteligenty skip  This function B<does not> perform parsing of format to inteligenty skip
424  delimiters before fields which aren't used.  delimiters before fields which aren't used.
425    
426    This method will automatically decode UTF-8 string to local code page
427    if needed.
428    
429  =cut  =cut
430    
431  sub fill_in {  sub fill_in {
432          my $self = shift;          my $self = shift;
433    
434          my $rec = shift || confess "need data record";          my $log = $self->_get_logger();
435          my $format = shift || confess "need format to parse";  
436            my $rec = shift || $log->logconfess("need data record");
437            my $format = shift || $log->logconfess("need format to parse");
438          # iteration (for repeatable fields)          # iteration (for repeatable fields)
439          my $i = shift || 0;          my $i = shift || 0;
440    
441          # FIXME remove for speedup?          # FIXME remove for speedup?
442          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
443    
444            if (utf8::is_utf8($format)) {
445                    $format = $self->_x($format);
446            }
447    
448          my $found = 0;          my $found = 0;
449    
# Line 356  sub fill_in { Line 452  sub fill_in {
452          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
453    
454          # do actual replacement of placeholders          # do actual replacement of placeholders
455          $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;
456    
457          if ($found) {          if ($found) {
458                    $log->debug("format: $format");
459                  if ($eval_code) {                  if ($eval_code) {
460                          my $eval = $self->fill_in($rec,$eval_code,$i);                          my $eval = $self->fill_in($rec,$eval_code,$i);
461                          return if (! eval $eval);                          return if (! $self->_eval($eval));
462                  }                  }
463                  # do we have lookups?                  # do we have lookups?
464                  if ($format =~ /\[[^\[\]]+\]/o) {                  if ($format =~ /$LOOKUP_REGEX/o) {
465                            $log->debug("format '$format' has lookup");
466                          return $self->lookup($format);                          return $self->lookup($format);
467                  } else {                  } else {
468                          return $format;                          return $format;
# Line 387  Lookups can be nested (like C<[d:[a:[v90 Line 485  Lookups can be nested (like C<[d:[a:[v90
485  sub lookup {  sub lookup {
486          my $self = shift;          my $self = shift;
487    
488          my $tmp = shift || confess "need format";          my $log = $self->_get_logger();
489    
490          if ($tmp =~ /\[[^\[\]]+\]/o) {          my $tmp = shift || $log->logconfess("need format");
491    
492            if ($tmp =~ /$LOOKUP_REGEX/o) {
493                  my @in = ( $tmp );                  my @in = ( $tmp );
494    
495                    $log->debug("lookup for: ",$tmp);
496    
497                  my @out;                  my @out;
498                  while (my $f = shift @in) {                  while (my $f = shift @in) {
499                          if ($f =~ /\[([^\[\]]+)\]/) {                          if ($f =~ /$LOOKUP_REGEX_SAVE/o) {
500                                  my $k = $1;                                  my $k = $1;
501                                  if ($self->{'lookup'}->{$k}) {                                  if ($self->{'lookup'}->{$k}) {
502                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {
503                                                  my $tmp2 = $f;                                                  my $tmp2 = $f;
504                                                  $tmp2 =~ s/\[$k\]/$nv/g;                                                  $tmp2 =~ s/lookup{$k}/$nv/g;
505                                                  push @in, $tmp2;                                                  push @in, $tmp2;
506                                          }                                          }
507                                  } else {                                  } else {
# Line 408  sub lookup { Line 511  sub lookup {
511                                  push @out, $f;                                  push @out, $f;
512                          }                          }
513                  }                  }
514                    $log->logconfess("return is array and it's not expected!") unless wantarray;
515                  return @out;                  return @out;
516          } else {          } else {
517                  return $tmp;                  return $tmp;
# Line 431  sub parse { Line 535  sub parse {
535    
536          return if (! $format_utf8);          return if (! $format_utf8);
537    
538          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          my $log = $self->_get_logger();
539          confess("need utf2cp Text::Iconv object!") if (! $self->{'utf2cp'});  
540            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
541            $log->logconfess("need utf2cp Text::Iconv object!") if (! $self->{'utf2cp'});
542    
543          $i = 0 if (! $i);          $i = 0 if (! $i);
544    
545          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'});
546    
547          my @out;          my @out;
548    
549            $log->debug("format: $format");
550    
551          my $eval_code;          my $eval_code;
552          # remove eval{...} from beginning          # remove eval{...} from beginning
553          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
# Line 447  sub parse { Line 555  sub parse {
555          my $prefix;          my $prefix;
556          my $all_found=0;          my $all_found=0;
557    
558          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))*//s) {          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))?//s) {
559    
560                  my $del = $1 || '';                  my $del = $1 || '';
561                  $prefix ||= $del if ($all_found == 0);                  $prefix ||= $del if ($all_found == 0);
# Line 464  sub parse { Line 572  sub parse {
572    
573          return if (! $all_found);          return if (! $all_found);
574    
575          my $out = join('',@out) . $format;          my $out = join('',@out);
576    
577          # add prefix if not there          if ($out) {
578          $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);                  # add rest of format (suffix)
579                    $out .= $format;
580    
581                    # add prefix if not there
582                    $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);
583    
584                    $log->debug("result: $out");
585            }
586    
587          if ($eval_code) {          if ($eval_code) {
588                  my $eval = $self->fill_in($rec,$eval_code,$i);                  my $eval = $self->fill_in($rec,$eval_code,$i);
589                  return if (! eval $eval);                  $log->debug("about to eval{",$eval,"} format: $out");
590                    return if (! $self->_eval($eval));
591          }          }
592    
593          return $out;          return $out;
# Line 490  sub parse_to_arr { Line 606  sub parse_to_arr {
606    
607          my ($rec, $format_utf8) = @_;          my ($rec, $format_utf8) = @_;
608    
609          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          my $log = $self->_get_logger();
610    
611            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
612          return if (! $format_utf8);          return if (! $format_utf8);
613    
614          my $i = 0;          my $i = 0;
# Line 500  sub parse_to_arr { Line 618  sub parse_to_arr {
618                  push @arr, $v;                  push @arr, $v;
619          }          }
620    
621            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
622    
623          return @arr;          return @arr;
624  }  }
625    
626  =head2 data_structure  =head2 fill_in_to_arr
627    
628  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
629  It is used later to produce output.  for fields which have lookups, so they shouldn't be parsed but rather
630    C<fill_id>ed.
631    
632   my $ds = $webpac->data_structure($rec);   my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]');
633    
634  =cut  =cut
635    
636  # private method _sort_by_order  sub fill_in_to_arr {
 # sort subrouting using order="" attribute  
 sub _sort_by_order {  
637          my $self = shift;          my $self = shift;
638    
639          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};  
640    
641          return $va <=> $vb;          my $log = $self->_get_logger();
642    
643            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
644            return if (! $format_utf8);
645    
646            my $i = 0;
647            my @arr;
648    
649            while (my @v = $self->fill_in($rec,$format_utf8,$i++)) {
650                    push @arr, @v;
651            }
652    
653            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
654    
655            return @arr;
656  }  }
657    
658    
659    =head2 data_structure
660    
661    Create in-memory data structure which represents layout from C<import_xml>.
662    It is used later to produce output.
663    
664     my @ds = $webpac->data_structure($rec);
665    
666    This method will also set C<$webpac->{'currnet_filename'}> if there is
667    <filename> tag in C<import_xml> and C<$webpac->{'headline'}> if there is
668    <headline> tag.
669    
670    =cut
671    
672  sub data_structure {  sub data_structure {
673          my $self = shift;          my $self = shift;
674    
675            my $log = $self->_get_logger();
676    
677          my $rec = shift;          my $rec = shift;
678          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
679    
680            undef $self->{'currnet_filename'};
681            undef $self->{'headline'};
682    
683          my @sorted_tags;          my @sorted_tags;
684          if ($self->{tags_by_order}) {          if ($self->{tags_by_order}) {
# Line 539  sub data_structure { Line 688  sub data_structure {
688                  $self->{tags_by_order} = \@sorted_tags;                  $self->{tags_by_order} = \@sorted_tags;
689          }          }
690    
691          my $ds;          my @ds;
692    
693            $log->debug("tags: ",sub { join(", ",@sorted_tags) });
694    
695          foreach my $field (@sorted_tags) {          foreach my $field (@sorted_tags) {
696    
# Line 548  sub data_structure { Line 699  sub data_structure {
699  #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'}});
700    
701                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
702                          my @v = $self->parse_to_arr($rec,$tag->{'content'});                          my $format = $tag->{'value'} || $tag->{'content'};
703    
704                            $log->debug("format: $format");
705    
706                            my @v;
707                            if ($format =~ /$LOOKUP_REGEX/o) {
708                                    @v = $self->fill_in_to_arr($rec,$format);
709                            } else {
710                                    @v = $self->parse_to_arr($rec,$format);
711                            }
712                          next if (! @v);                          next if (! @v);
713    
714                            # use format?
715                            if ($tag->{'format_name'}) {
716                                    @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
717                            }
718    
719                            if ($field eq 'filename') {
720                                    $self->{'current_filename'} = join('',@v);
721                                    $log->debug("filename: ",$self->{'current_filename'});
722                            } elsif ($field eq 'headline') {
723                                    $self->{'headline'} .= join('',@v);
724                                    $log->debug("headline: ",$self->{'headline'});
725                                    next; # don't return headline in data_structure!
726                            }
727    
728                          # does tag have type?                          # does tag have type?
729                          if ($tag->{'type'}) {                          if ($tag->{'type'}) {
730                                  push @{$row->{$tag->{'type'}}}, @v;                                  push @{$row->{$tag->{'type'}}}, @v;
# Line 559  sub data_structure { Line 732  sub data_structure {
732                                  push @{$row->{'display'}}, @v;                                  push @{$row->{'display'}}, @v;
733                                  push @{$row->{'swish'}}, @v;                                  push @{$row->{'swish'}}, @v;
734                          }                          }
735    
736    
737                    }
738    
739                    if ($row) {
740                            $row->{'tag'} = $field;
741    
742                            # TODO: name_sigular, name_plural
743                            my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
744                            $row->{'name'} = $name ? $self->_x($name) : $field;
745    
746                            push @ds, $row;
747    
748                            $log->debug("row $field: ",sub { Dumper($row) });
749                  }                  }
750    
751                  push @{$ds->{$field}}, $row if ($row);          }
752    
753            return @ds;
754    
755    }
756    
757    =head2 output
758    
759    Create output from in-memory data structure using Template Toolkit template.
760    
761    my $text = $webpac->output( template => 'text.tt', data => @ds );
762    
763    =cut
764    
765    sub output {
766            my $self = shift;
767    
768            my $args = {@_};
769    
770            my $log = $self->_get_logger();
771    
772            $log->logconfess("need template name") if (! $args->{'template'});
773            $log->logconfess("need data array") if (! $args->{'data'});
774    
775            my $out;
776    
777            $self->{'tt'}->process(
778                    $args->{'template'},
779                    $args,
780                    \$out
781            ) || confess $self->{'tt'}->error();
782    
783            return $out;
784    }
785    
786    =head2 output_file
787    
788    Create output from in-memory data structure using Template Toolkit template
789    to a file.
790    
791     $webpac->output_file(
792            file => 'out.txt',
793            template => 'text.tt',
794            data => @ds
795     );
796    
797    =cut
798    
799    sub output_file {
800            my $self = shift;
801    
802            my $args = {@_};
803    
804            my $log = $self->_get_logger();
805    
806            $log->logconfess("need file name") if (! $args->{'file'});
807    
808            $log->debug("creating file ",$args->{'file'});
809    
810            open(my $fh, ">", $args->{'file'}) || $log->logdie("can't open output file '$self->{'file'}': $!");
811            print $fh $self->output(
812                    template => $args->{'template'},
813                    data => $args->{'data'},
814            ) || $log->logdie("print: $!");
815            close($fh) || $log->logdie("close: $!");
816    }
817    
818    =head2 apply_format
819    
820    Apply format specified in tag with C<format_name="name"> and
821    C<format_delimiter=";;">.
822    
823     my $text = $webpac->apply_format($format_name,$format_delimiter,$data);
824    
825    Formats can contain C<lookup{...}> if you need them.
826    
827    =cut
828    
829    sub apply_format {
830            my $self = shift;
831    
832            my ($name,$delimiter,$data) = @_;
833    
834            my $log = $self->_get_logger();
835    
836            if (! $self->{'import_xml'}->{'format'}->{$name}) {
837                    $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});
838                    return $data;
839          }          }
840    
841          print "data_structure => ",Dumper($ds);          $log->warn("no delimiter for format $name") if (! $delimiter);
842    
843            my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");
844    
845            my @data = split(/\Q$delimiter\E/, $data);
846    
847            my $out = sprintf($format, @data);
848            $log->debug("using format $name [$format] on $data to produce: $out");
849    
850            if ($out =~ m/$LOOKUP_REGEX/o) {
851                    return $self->lookup($out);
852            } else {
853                    return $out;
854            }
855    
856  }  }
857    
858    
859    #
860    #
861    #
862    
863    =head1 INTERNAL METHODS
864    
865    Here is a quick list of internal methods, mostly useful to turn debugging
866    on them (see L<LOGGING> below for explanation).
867    
868    =cut
869    
870    =head2 _eval
871    
872    Internal function to eval code without C<strict 'subs'>.
873    
874    =cut
875    
876    sub _eval {
877            my $self = shift;
878    
879            my $code = shift || return;
880    
881            my $log = $self->_get_logger();
882    
883            no strict 'subs';
884            my $ret = eval $code;
885            if ($@) {
886                    $log->error("problem with eval code [$code]: $@");
887            }
888    
889            $log->debug("eval: ",$code," [",$ret,"]");
890    
891            return $ret || 0;
892    }
893    
894    =head2 _sort_by_order
895    
896    Sort xml tags data structure accoding to C<order=""> attribute.
897    
898    =cut
899    
900    sub _sort_by_order {
901            my $self = shift;
902    
903            my $va = $self->{'import_xml'}->{'indexer'}->{$a}->{'order'} ||
904                    $self->{'import_xml'}->{'indexer'}->{$a};
905            my $vb = $self->{'import_xml'}->{'indexer'}->{$b}->{'order'} ||
906                    $self->{'import_xml'}->{'indexer'}->{$b};
907    
908            return $va <=> $vb;
909    }
910    
911    =head2 _get_logger
912    
913    Get C<Log::Log4perl> object with a twist: domains are defined for each
914    method
915    
916     my $log = $webpac->_get_logger();
917    
918    =cut
919    
920    sub _get_logger {
921            my $self = shift;
922    
923            my $name = (caller(1))[3] || caller;
924            return get_logger($name);
925    }
926    
927    =head2 _x
928    
929    Convert string from UTF-8 to code page defined in C<import_xml>.
930    
931     my $text = $webpac->_x('utf8 text');
932    
933    =cut
934    
935    sub _x {
936            my $self = shift;
937            my $utf8 = shift || return;
938    
939            return $self->{'utf2cp'}->convert($utf8) ||
940                    $self->_get_logger()->logwarn("can't convert '$utf8'");
941    }
942    
943    #
944    #
945    #
946    
947    =head1 LOGGING
948    
949    Logging in WebPAC is performed by L<Log::Log4perl> with config file
950    C<log.conf>.
951    
952    Methods defined above have different levels of logging, so
953    it's descriptions will be useful to turn (mostry B<debug> logging) on
954    or off to see why WabPAC isn't perforing as you expect it (it might even
955    be a bug!).
956    
957    B<This is different from normal Log4perl behaviour>. To repeat, you can
958    also use method names, and not only classes (which are just few)
959    to filter logging.
960    
961    =cut
962    
963  1;  1;
Legend:
Removed from v.367  
changed lines
  Added in v.418
  ViewVC Help
Powered by ViewVC 1.1.26