/[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 366 by dpavlin, Thu Jun 17 01:44:25 2004 UTC revision 374 by dpavlin, Sun Jun 20 16:57:52 2004 UTC
# Line 1  Line 1 
1  package WebPAC;  package WebPAC;
2    
3    use warnings;
4    use strict;
5    
6  use Carp;  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 49  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 56  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 67  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 97  By default, ISIS code page is assumed to Line 125  By default, ISIS code page is assumed to
125  If optional parametar C<limit_mfn> is set, it will read just 500 records  If optional parametar C<limit_mfn> is set, it will read just 500 records
126  from database in example above.  from database in example above.
127    
 Returns number of last record read into memory (size of database, really).  
   
128  C<lookup> argument is an array of lookups to create. Each lookup must have C<key> and  C<lookup> argument is an array of lookups to create. Each lookup must have C<key> and
129  C<val>. Optional parametar C<eval> is perl code to evaluate before storing  C<val>. Optional parametar C<eval> is perl code to evaluate before storing
130  value in index.  value in index.
# Line 110  value in index. Line 136  value in index.
136      'val' => 'v900' },      'val' => 'v900' },
137   ]   ]
138    
139    Returns number of last record read into memory (size of database, really).
140    
141  =cut  =cut
142    
143  sub open_isis {  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 126  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 134  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 158  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 186  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 207  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 217  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->debug("using type '",$self->{'type'},"' tag <",$self->{'tag'},">") if ($self->{'debug'});
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          print STDERR "reading '$f'\n" if ($self->{'debug'});          $log->debug("reading '$f'") if ($self->{'debug'});
263    
264          $self->{'import_xml'} = XMLin($f,          $self->{'import_xml'} = XMLin($f,
265                  ForceArray => [ $self->{'tag'}, 'config', 'format' ],                  ForceArray => [ $self->{'tag'}, 'config', 'format' ],
                 ForceContent => 1  
266          );          );
267    
         print Dumper($self->{'import_xml'});  
   
268  }  }
269    
270  =head2 create_lookup  =head2 create_lookup
271    
272  Create lookup from record using lookup definition.  Create lookup from record using lookup definition.
273    
274     $self->create_lookup($rec, @lookups);
275    
276    Called internally by C<open_*> methods.
277    
278  =cut  =cut
279    
280  sub create_lookup {  sub create_lookup {
281          my $self = shift;          my $self = shift;
282    
283          my $rec = shift || confess "need record to create lookup";          my $log = $self->_get_logger();
284          confess("need HASH as first argument!") if ($rec !~ /HASH/o);  
285            my $rec = shift || $log->logconfess("need record to create lookup");
286            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
287    
288          foreach my $i (@_) {          foreach my $i (@_) {
289                  if ($i->{'eval'}) {                  if ($i->{'eval'}) {
# Line 251  sub create_lookup { Line 291  sub create_lookup {
291                          my $key = $self->fill_in($rec,$i->{'key'});                          my $key = $self->fill_in($rec,$i->{'key'});
292                          my @val = $self->fill_in($rec,$i->{'val'});                          my @val = $self->fill_in($rec,$i->{'val'});
293                          if ($key && @val && eval $eval) {                          if ($key && @val && eval $eval) {
294                                    $log->debug("stored $key = ",sub { join(" | ",@val) });
295                                  push @{$self->{'lookup'}->{$key}}, @val;                                  push @{$self->{'lookup'}->{$key}}, @val;
296                          }                          }
297                  } else {                  } else {
298                          my $key = $self->fill_in($rec,$i->{'key'});                          my $key = $self->fill_in($rec,$i->{'key'});
299                          my @val = $self->fill_in($rec,$i->{'val'});                          my @val = $self->fill_in($rec,$i->{'val'});
300                          if ($key && @val) {                          if ($key && @val) {
301                                    $log->debug("stored $key = ",sub { join(" | ",@val) });
302                                  push @{$self->{'lookup'}->{$key}}, @val;                                  push @{$self->{'lookup'}->{$key}}, @val;
303                          }                          }
304                  }                  }
# Line 267  sub create_lookup { Line 309  sub create_lookup {
309    
310  Returns value from record.  Returns value from record.
311    
312   $self->get_data(\$rec,$f,$sf,$i,\$found);   my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);
313    
314  Arguments are:  Arguments are:
315  record reference C<$rec>,  record reference C<$rec>,
# Line 275  field C<$f>, Line 317  field C<$f>,
317  optional subfiled C<$sf>,  optional subfiled C<$sf>,
318  index for repeatable values C<$i>.  index for repeatable values C<$i>.
319    
320  Optinal variable C<$found> will be incremeted if thre  Optinal variable C<$found> will be incremeted if there
321  is field.  is field.
322    
323  Returns value or empty string.  Returns value or empty string.
# Line 286  sub get_data { Line 328  sub get_data {
328          my $self = shift;          my $self = shift;
329    
330          my ($rec,$f,$sf,$i,$found) = @_;          my ($rec,$f,$sf,$i,$found) = @_;
331    
332          if ($$rec->{$f}) {          if ($$rec->{$f}) {
333                    return '' if (! $$rec->{$f}->[$i]);
334                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {
335                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
336                          return $$rec->{$f}->[$i]->{$sf};                          return $$rec->{$f}->[$i]->{$sf};
# Line 315  Workhourse of all: takes record from in- Line 359  Workhourse of all: takes record from in-
359  strings with placeholders and returns string or array of with substituted  strings with placeholders and returns string or array of with substituted
360  values from record.  values from record.
361    
362   $webpac->fill_in($rec,'v250^a');   my $text = $webpac->fill_in($rec,'v250^a');
363    
364  Optional argument is ordinal number for repeatable fields. By default,  Optional argument is ordinal number for repeatable fields. By default,
365  it's assume to be first repeatable field (fields are perl array, so first  it's assume to be first repeatable field (fields are perl array, so first
366  element is 0).  element is 0).
367  Following example will read second value from repeatable field.  Following example will read second value from repeatable field.
368    
369   $webpac->fill_in($rec,'Title: v250^a',1);   my $text = $webpac->fill_in($rec,'Title: v250^a',1);
370    
371  This function B<does not> perform parsing of format to inteligenty skip  This function B<does not> perform parsing of format to inteligenty skip
372  delimiters before fields which aren't used.  delimiters before fields which aren't used.
# Line 332  delimiters before fields which aren't us Line 376  delimiters before fields which aren't us
376  sub fill_in {  sub fill_in {
377          my $self = shift;          my $self = shift;
378    
379          my $rec = shift || confess "need data record";          my $log = $self->_get_logger();
380          my $format = shift || confess "need format to parse";  
381            my $rec = shift || $log->logconfess("need data record");
382            my $format = shift || $log->logconfess("need format to parse");
383          # iteration (for repeatable fields)          # iteration (for repeatable fields)
384          my $i = shift || 0;          my $i = shift || 0;
385    
386          # FIXME remove for speedup?          # FIXME remove for speedup?
387          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
388    
389          my $found = 0;          my $found = 0;
390    
# Line 347  sub fill_in { Line 393  sub fill_in {
393          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
394    
395          # do actual replacement of placeholders          # do actual replacement of placeholders
396          $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;
397    
398          if ($found) {          if ($found) {
399                    $log->debug("format: $format");
400                  if ($eval_code) {                  if ($eval_code) {
401                          my $eval = $self->fill_in($rec,$eval_code,$i);                          my $eval = $self->fill_in($rec,$eval_code,$i);
402                          return if (! eval $eval);                          return if (! $self->_eval($eval));
403                  }                  }
404                  # do we have lookups?                  # do we have lookups?
405                  if ($format =~ /\[[^\[\]]+\]/o) {                  if ($format =~ /$LOOKUP_REGEX/o) {
406                            $log->debug("format '$format' has lookup");
407                          return $self->lookup($format);                          return $self->lookup($format);
408                  } else {                  } else {
409                          return $format;                          return $format;
# Line 369  sub fill_in { Line 417  sub fill_in {
417    
418  Perform lookups on format supplied to it.  Perform lookups on format supplied to it.
419    
420   my $txt = $self->lookup('[v900]');   my $text = $self->lookup('[v900]');
421    
422  Lookups can be nested (like C<[d:[a:[v900]]]>).  Lookups can be nested (like C<[d:[a:[v900]]]>).
423    
# Line 378  Lookups can be nested (like C<[d:[a:[v90 Line 426  Lookups can be nested (like C<[d:[a:[v90
426  sub lookup {  sub lookup {
427          my $self = shift;          my $self = shift;
428    
429          my $tmp = shift || confess "need format";          my $log = $self->_get_logger();
430    
431          if ($tmp =~ /\[[^\[\]]+\]/o) {          my $tmp = shift || $log->logconfess("need format");
432    
433            if ($tmp =~ /$LOOKUP_REGEX/o) {
434                  my @in = ( $tmp );                  my @in = ( $tmp );
435  #print "##lookup $tmp\n";  
436                    $log->debug("lookup for: ",$tmp);
437    
438                  my @out;                  my @out;
439                  while (my $f = shift @in) {                  while (my $f = shift @in) {
440                          if ($f =~ /\[([^\[\]]+)\]/) {                          if ($f =~ /$LOOKUP_REGEX_SAVE/o) {
441                                  my $k = $1;                                  my $k = $1;
442                                  if ($self->{'lookup'}->{$k}) {                                  if ($self->{'lookup'}->{$k}) {
 #print "## lookup key = $k\n";  
443                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {
444                                                  my $tmp2 = $f;                                                  my $tmp2 = $f;
445                                                  $tmp2 =~ s/\[$k\]/$nv/g;                                                  $tmp2 =~ s/lookup{$k}/$nv/g;
446                                                  push @in, $tmp2;                                                  push @in, $tmp2;
 #print "## lookup in => $tmp2\n";  
447                                          }                                          }
448                                  } else {                                  } else {
449                                          undef $f;                                          undef $f;
450                                  }                                  }
451                          } elsif ($f) {                          } elsif ($f) {
452                                  push @out, $f;                                  push @out, $f;
 #print "## lookup out => $f\n";  
453                          }                          }
454                  }                  }
455                    $log->logconfess("return is array and it's not expected!") unless wantarray;
456                  return @out;                  return @out;
457          } else {          } else {
458                  return $tmp;                  return $tmp;
# Line 415  Perform smart parsing of string, skippin Line 465  Perform smart parsing of string, skippin
465  defined. It can also eval code in format starting with C<eval{...}> and  defined. It can also eval code in format starting with C<eval{...}> and
466  return output or nothing depending on eval code.  return output or nothing depending on eval code.
467    
468   $webpac->parse($rec,'eval{"v901^a" eq "Deskriptor"}descriptor: v250^a', $i);   my $text = $webpac->parse($rec,'eval{"v901^a" eq "Deskriptor"}descriptor: v250^a', $i);
469    
470  =cut  =cut
471    
# Line 426  sub parse { Line 476  sub parse {
476    
477          return if (! $format_utf8);          return if (! $format_utf8);
478    
479          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          my $log = $self->_get_logger();
480          confess("need utf2cp Text::Iconv object!") if (! $self->{'utf2cp'});  
481            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
482            $log->logconfess("need utf2cp Text::Iconv object!") if (! $self->{'utf2cp'});
483    
484          $i = 0 if (! $i);          $i = 0 if (! $i);
485    
486          my $format = $self->{'utf2cp'}->convert($format_utf8) || confess("can't convert '$format_utf8' from UTF-8 to ",$self->{'code_page'});          my $format = $self->{'utf2cp'}->convert($format_utf8) || $log->logconfess("can't convert '$format_utf8' from UTF-8 to ",$self->{'code_page'});
487    
488          my @out;          my @out;
489    
490            $log->debug("format: $format");
491    
492          my $eval_code;          my $eval_code;
493          # remove eval{...} from beginning          # remove eval{...} from beginning
494          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
# Line 442  sub parse { Line 496  sub parse {
496          my $prefix;          my $prefix;
497          my $all_found=0;          my $all_found=0;
498    
499  #print "## $format\n";          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))?//s) {
         while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))*//s) {  
 #print "## [ $1 | $2 | $3 ] $format\n";  
500    
501                  my $del = $1 || '';                  my $del = $1 || '';
502                  $prefix ||= $del if ($all_found == 0);                  $prefix ||= $del if ($all_found == 0);
# Line 461  sub parse { Line 513  sub parse {
513    
514          return if (! $all_found);          return if (! $all_found);
515    
516          my $out = join('',@out) . $format;          my $out = join('',@out);
517    
518            if ($out) {
519                    # add rest of format (suffix)
520                    $out .= $format;
521    
522                    # add prefix if not there
523                    $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);
524    
525                    $log->debug("result: $out");
526            }
527    
         # add prefix if not there  
         $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);  
           
528          if ($eval_code) {          if ($eval_code) {
529                  my $eval = $self->fill_in($rec,$eval_code,$i);                  my $eval = $self->fill_in($rec,$eval_code,$i);
530                  return if (! eval $eval);                  $log->debug("about to eval{",$eval,"} format: $out");
531                    return if (! $self->_eval($eval));
532          }          }
533    
534          return $out;          return $out;
535  }  }
536    
537  =head2 data_structure  =head2 parse_to_arr
538    
539  Create in-memory data structure which represents layout from C<import_xml>.  Similar to C<parse>, but returns array of all repeatable fields
 It is used later to produce output.  
540    
541   my $ds = $webpac->data_structure($rec);   my @arr = $webpac->parse_to_arr($rec,'v250^a');
542    
543  =cut  =cut
544    
545  # private method _sort_by_order  sub parse_to_arr {
 # sort subrouting using order="" attribute  
 sub _sort_by_order {  
546          my $self = shift;          my $self = shift;
547    
548          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};  
549    
550          return $va <=> $vb;          my $log = $self->_get_logger();
551    
552            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
553            return if (! $format_utf8);
554    
555            my $i = 0;
556            my @arr;
557    
558            while (my $v = $self->parse($rec,$format_utf8,$i++)) {
559                    push @arr, $v;
560            }
561    
562            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
563    
564            return @arr;
565  }  }
566    
567    =head2 fill_in_to_arr
568    
569    Similar to C<fill_in>, but returns array of all repeatable fields. Usable
570    for fields which have lookups, so they shouldn't be parsed but rather
571    C<fill_id>ed.
572    
573     my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]');
574    
575    =cut
576    
577    sub fill_in_to_arr {
578            my $self = shift;
579    
580            my ($rec, $format_utf8) = @_;
581    
582            my $log = $self->_get_logger();
583    
584            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
585            return if (! $format_utf8);
586    
587            my $i = 0;
588            my @arr;
589    
590            while (my @v = $self->fill_in($rec,$format_utf8,$i++)) {
591                    push @arr, @v;
592            }
593    
594            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
595    
596            return @arr;
597    }
598    
599    
600    =head2 data_structure
601    
602    Create in-memory data structure which represents layout from C<import_xml>.
603    It is used later to produce output.
604    
605     my @ds = $webpac->data_structure($rec);
606    
607    This method will also set C<$webpac->{'currnet_filename'}> if there is
608    <filename> tag in C<import_xml>.
609    
610    =cut
611    
612  sub data_structure {  sub data_structure {
613          my $self = shift;          my $self = shift;
614    
615            my $log = $self->_get_logger();
616    
617          my $rec = shift;          my $rec = shift;
618          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
619    
620            undef $self->{'currnet_filename'};
621    
622          my @sorted_tags;          my @sorted_tags;
623          if ($self->{tags_by_order}) {          if ($self->{tags_by_order}) {
# Line 510  sub data_structure { Line 627  sub data_structure {
627                  $self->{tags_by_order} = \@sorted_tags;                  $self->{tags_by_order} = \@sorted_tags;
628          }          }
629    
630          my $ds;          my @ds;
631    
632            $log->debug("tags: ",sub { join(", ",@sorted_tags) });
633    
634          foreach my $field (@sorted_tags) {          foreach my $field (@sorted_tags) {
635    
636                  my $row;                  my $row;
                 my $i = 0;  
637    
638  #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'}});
639    
640                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
641                            my $format = $tag->{'value'} || $tag->{'content'};
642    
643                          my $v = $self->parse($rec,$tag->{'content'},$i);                          $log->debug("format: $format");
 print "## $i:",$tag->{'content'}," = ",($v || 'null'),"\n";  
644    
645                          next if (!$v || $v && $v eq '');                          my @v;
646                            if ($format =~ /$LOOKUP_REGEX/o) {
647                                    @v = $self->fill_in_to_arr($rec,$format);
648                            } else {
649                                    @v = $self->parse_to_arr($rec,$format);
650                            }
651                            next if (! @v);
652    
653                          # does tag have type?                          # does tag have type?
654                          if ($tag->{'type'}) {                          if ($tag->{'type'}) {
655                                  push @{$row->{$tag->{'type'}}}, $v;                                  push @{$row->{$tag->{'type'}}}, @v;
656                          } else {                          } else {
657                                  push @{$row->{'display'}}, $v;                                  push @{$row->{'display'}}, @v;
658                                  push @{$row->{'swish'}}, $v;                                  push @{$row->{'swish'}}, @v;
659                            }
660    
661                            if ($field eq 'filename') {
662                                    $self->{'current_filename'} = join('',@v);
663                                    $log->debug("filename: ",$self->{'current_filename'});
664                          }                          }
665    
666                  }                  }
667    
668                  push @{$ds->{$field}}, $row if ($row);                  if ($row) {
669                            $row->{'tag'} = $field;
670                            push @ds, $row;
671    
672                            $log->debug("row $field: ",sub { Dumper($row) });
673                    }
674    
675          }          }
676    
677          print Dumper($ds);          return @ds;
678    
679    }
680    
681    =head2 output
682    
683    Create output from in-memory data structure using Template Toolkit template.
684    
685    my $text = $webpac->output( template => 'text.tt', data => @ds );
686    
687    =cut
688    
689    sub output {
690            my $self = shift;
691    
692            my $args = {@_};
693    
694            my $log = $self->_get_logger();
695    
696            $log->logconfess("need template name") if (! $args->{'template'});
697            $log->logconfess("need data array") if (! $args->{'data'});
698    
699            my $out;
700    
701            $self->{'tt'}->process(
702                    $args->{'template'},
703                    $args,
704                    \$out
705            ) || confess $self->{'tt'}->error();
706    
707            return $out;
708  }  }
709    
710    #
711    #
712    #
713    
714    =head1 INTERNAL METHODS
715    
716    Here is a quick list of internal methods, mostly useful to turn debugging
717    on them (see L<LOGGING> below for explanation).
718    
719    =cut
720    
721    =head2 _eval
722    
723    Internal function to eval code without C<strict 'subs'>.
724    
725    =cut
726    
727    sub _eval {
728            my $self = shift;
729    
730            my $code = shift || return;
731    
732            my $log = $self->_get_logger();
733    
734            no strict 'subs';
735            my $ret = eval $code;
736            if ($@) {
737                    $log->error("problem with eval code [$code]: $@");
738            }
739    
740            $log->debug("eval: ",$code," [",$ret,"]");
741    
742            return $ret || 0;
743    }
744    
745    =head2 _sort_by_order
746    
747    Sort xml tags data structure accoding to C<order=""> attribute.
748    
749    =cut
750    
751    sub _sort_by_order {
752            my $self = shift;
753    
754            my $va = $self->{'import_xml'}->{'indexer'}->{$a}->{'order'} ||
755                    $self->{'import_xml'}->{'indexer'}->{$a};
756            my $vb = $self->{'import_xml'}->{'indexer'}->{$b}->{'order'} ||
757                    $self->{'import_xml'}->{'indexer'}->{$b};
758    
759            return $va <=> $vb;
760    }
761    
762    sub _get_logger {
763            my $self = shift;
764    
765            my $name = (caller(1))[3] || caller;
766            return get_logger($name);
767    }
768    
769    #
770    #
771    #
772    
773    =head1 LOGGING
774    
775    Logging in WebPAC is performed by L<Log::Log4perl> with config file
776    C<log.conf>.
777    
778    Methods defined above have different levels of logging, so
779    it's descriptions will be useful to turn (mostry B<debug> logging) on
780    or off to see why WabPAC isn't perforing as you expect it (it might even
781    be a bug!).
782    
783    B<This is different from normal Log4perl behaviour>. To repeat, you can
784    also use method names, and not only classes (which are just few)
785    to filter logging.
786    
787    =cut
788    
789  1;  1;

Legend:
Removed from v.366  
changed lines
  Added in v.374

  ViewVC Help
Powered by ViewVC 1.1.26