/[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 362 by dpavlin, Wed Jun 16 16:50:30 2004 UTC revision 373 by dpavlin, Sun Jun 20 15:49:09 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;
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 34  which describes databases to be indexed. Line 45  which describes databases to be indexed.
45    
46  =cut  =cut
47    
48    # mapping between data type and tag which specify
49    # format in XML file
50    my %type2tag = (
51            'isis' => 'isis',
52    #       'excel' => 'column',
53    #       'marc' => 'marc',
54    #       'feed' => 'feed'
55    );
56    
57  sub new {  sub new {
58          my $class = shift;          my $class = shift;
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 46  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 57  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          # read global config parametars          # create UTF-8 convertor for import_xml files
98          foreach my $var (qw(          $self->{'utf2cp'} = Text::Iconv->new('UTF-8' ,$self->{'code_page'});
99                          dbi_dbd  
100                          dbi_dsn          # create Template toolkit instance
101                          dbi_user          $self->{'tt'} = Template->new(
102                          dbi_passwd                  INCLUDE_PATH => ($self->{'global_config_file'}->{'output_template'} || './output_template'),
103                          show_progress  #               FILTERS => {
104                          my_unac_filter  #                       'foo' => \&foo_filter,
105                  )) {  #               },
106                  $self->{global_config}->{$var} = $self->{global_config_file}->val('global', $var);                  EVAL_PERL => 1,
107          }          );
108    
109          return $self;          return $self;
110  }  }
# Line 98  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 111  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 127  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            $log->info("reading ISIS database '",$arg->{'filename'},"'");
160    
161          my $isis_db = OpenIsis::open($arg->{'filename'});          my $isis_db = OpenIsis::open($arg->{'filename'});
162    
163          my $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;          my $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;
164    
165          $maxmfn = $self->{limit_mfn} if ($self->{limit_mfn});          $maxmfn = $self->{limit_mfn} if ($self->{limit_mfn});
166    
167            $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    
# Line 183  it's implemented, that is). Line 216  it's implemented, that is).
216  sub fetch_rec {  sub fetch_rec {
217          my $self = shift;          my $self = shift;
218    
219          my $mfn = $self->{'current_mfn'}++ || confess "it seems that you didn't load database!";          my $log = $self->_get_logger();
220    
221            my $mfn = $self->{'current_mfn'}++ || $log->logconfess("it seems that you didn't load database!");
222    
223          if ($mfn > $self->{'max_mfn'}) {          if ($mfn > $self->{'max_mfn'}) {
224                  $self->{'current_mfn'} = $self->{'max_mfn'};                  $self->{'current_mfn'} = $self->{'max_mfn'};
225                    $log->debug("at EOF");
226                  return;                  return;
227          }          }
228    
229          return $self->{'data'}->{$mfn};          return $self->{'data'}->{$mfn};
230  }  }
231    
232    =head2 open_import_xml
233    
234    Read file from C<import_xml/> directory and parse it.
235    
236     $webpac->open_import_xml(type => 'isis');
237    
238    =cut
239    
240    sub open_import_xml {
241            my $self = shift;
242    
243            my $log = $self->_get_logger();
244    
245            my $arg = {@_};
246            $log->logconfess("need type to load file from import_xml/") if (! $arg->{'type'});
247    
248            $self->{'type'} = $arg->{'type'};
249    
250            my $type_base = $arg->{'type'};
251            $type_base =~ s/_.*$//g;
252    
253            $self->{'tag'} = $type2tag{$type_base};
254    
255            $log->debug("using type '",$self->{'type'},"' tag <",$self->{'tag'},">") if ($self->{'debug'});
256    
257            my $f = "./import_xml/".$self->{'type'}.".xml";
258            $log->logconfess("import_xml file '$f' doesn't exist!") if (! -e "$f");
259    
260            $log->debug("reading '$f'") if ($self->{'debug'});
261    
262            $self->{'import_xml'} = XMLin($f,
263                    ForceArray => [ $self->{'tag'}, 'config', 'format' ],
264            );
265    
266    }
267    
268  =head2 create_lookup  =head2 create_lookup
269    
270  Create lookup from record using lookup definition.  Create lookup from record using lookup definition.
271    
272     $self->create_lookup($rec, @lookups);
273    
274    Called internally by C<open_*> methods.
275    
276  =cut  =cut
277    
278  sub create_lookup {  sub create_lookup {
279          my $self = shift;          my $self = shift;
280    
281          my $rec = shift || confess "need record to create lookup";          my $log = $self->_get_logger();
282          confess("need HASH as first argument!") if ($rec !~ /HASH/o);  
283            my $rec = shift || $log->logconfess("need record to create lookup");
284            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
285    
286          foreach my $i (@_) {          foreach my $i (@_) {
287                  if ($i->{'eval'}) {                  if ($i->{'eval'}) {
# Line 211  sub create_lookup { Line 289  sub create_lookup {
289                          my $key = $self->fill_in($rec,$i->{'key'});                          my $key = $self->fill_in($rec,$i->{'key'});
290                          my @val = $self->fill_in($rec,$i->{'val'});                          my @val = $self->fill_in($rec,$i->{'val'});
291                          if ($key && @val && eval $eval) {                          if ($key && @val && eval $eval) {
292                                    $log->debug("stored $key = ",sub { join(" | ",@val) });
293                                  push @{$self->{'lookup'}->{$key}}, @val;                                  push @{$self->{'lookup'}->{$key}}, @val;
294                          }                          }
295                  } else {                  } else {
296                          my $key = $self->fill_in($rec,$i->{'key'});                          my $key = $self->fill_in($rec,$i->{'key'});
297                          my @val = $self->fill_in($rec,$i->{'val'});                          my @val = $self->fill_in($rec,$i->{'val'});
298                          if ($key && @val) {                          if ($key && @val) {
299                                    $log->debug("stored $key = ",sub { join(" | ",@val) });
300                                  push @{$self->{'lookup'}->{$key}}, @val;                                  push @{$self->{'lookup'}->{$key}}, @val;
301                          }                          }
302                  }                  }
# Line 227  sub create_lookup { Line 307  sub create_lookup {
307    
308  Returns value from record.  Returns value from record.
309    
310   $self->get_data(\$rec,$f,$sf,$i,\$found);   my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);
311    
312  Arguments are:  Arguments are:
313  record reference C<$rec>,  record reference C<$rec>,
# Line 235  field C<$f>, Line 315  field C<$f>,
315  optional subfiled C<$sf>,  optional subfiled C<$sf>,
316  index for repeatable values C<$i>.  index for repeatable values C<$i>.
317    
318  Optinal variable C<$found> will be incremeted if thre  Optinal variable C<$found> will be incremeted if there
319  is field.  is field.
320    
321  Returns value or empty string.  Returns value or empty string.
# Line 246  sub get_data { Line 326  sub get_data {
326          my $self = shift;          my $self = shift;
327    
328          my ($rec,$f,$sf,$i,$found) = @_;          my ($rec,$f,$sf,$i,$found) = @_;
329    
330          if ($$rec->{$f}) {          if ($$rec->{$f}) {
331                    return '' if (! $$rec->{$f}->[$i]);
332                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {
333                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
334                          return $$rec->{$f}->[$i]->{$sf};                          return $$rec->{$f}->[$i]->{$sf};
335                  } elsif ($$rec->{$f}->[$i]) {                  } elsif ($$rec->{$f}->[$i]) {
336                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
337                          return $$rec->{$f}->[$i];                          # it still might have subfield, just
338                            # not specified, so we'll dump all
339                            if ($$rec->{$f}->[$i] =~ /HASH/o) {
340                                    my $out;
341                                    foreach my $k (keys %{$$rec->{$f}->[$i]}) {
342                                            $out .= $$rec->{$f}->[$i]->{$k}." ";
343                                    }
344                                    return $out;
345                            } else {
346                                    return $$rec->{$f}->[$i];
347                            }
348                  }                  }
349          } else {          } else {
350                  return '';                  return '';
# Line 265  Workhourse of all: takes record from in- Line 357  Workhourse of all: takes record from in-
357  strings with placeholders and returns string or array of with substituted  strings with placeholders and returns string or array of with substituted
358  values from record.  values from record.
359    
360   $webpac->fill_in($rec,'v250^a');   my $text = $webpac->fill_in($rec,'v250^a');
361    
362  Optional argument is ordinal number for repeatable fields. By default,  Optional argument is ordinal number for repeatable fields. By default,
363  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
364  element is 0).  element is 0).
365  Following example will read second value from repeatable field.  Following example will read second value from repeatable field.
366    
367   $webpac->fill_in($rec,'Title: v250^a',1);   my $text = $webpac->fill_in($rec,'Title: v250^a',1);
368    
369  This function B<does not> perform parsing of format to inteligenty skip  This function B<does not> perform parsing of format to inteligenty skip
370  delimiters before fields which aren't used.  delimiters before fields which aren't used.
# Line 282  delimiters before fields which aren't us Line 374  delimiters before fields which aren't us
374  sub fill_in {  sub fill_in {
375          my $self = shift;          my $self = shift;
376    
377          my $rec = shift || confess "need data record";          my $log = $self->_get_logger();
378          my $format = shift || confess "need format to parse";  
379            my $rec = shift || $log->logconfess("need data record");
380            my $format = shift || $log->logconfess("need format to parse");
381          # iteration (for repeatable fields)          # iteration (for repeatable fields)
382          my $i = shift || 0;          my $i = shift || 0;
383    
384          # FIXME remove for speedup?          # FIXME remove for speedup?
385          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
386    
387          my $found = 0;          my $found = 0;
388    
# Line 297  sub fill_in { Line 391  sub fill_in {
391          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
392    
393          # do actual replacement of placeholders          # do actual replacement of placeholders
394          $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;
395    
396          if ($found) {          if ($found) {
397                    $log->debug("format: $format");
398                  if ($eval_code) {                  if ($eval_code) {
399                          my $eval = $self->fill_in($rec,$eval_code,$i);                          my $eval = $self->fill_in($rec,$eval_code,$i);
400                          return if (! eval $eval);                          return if (! $self->_eval($eval));
401                  }                  }
402                  # do we have lookups?                  # do we have lookups?
403                  if ($format =~ /\[[^\[\]]+\]/o) {                  if ($format =~ /$LOOKUP_REGEX/o) {
404                            $log->debug("format '$format' has lookup");
405                          return $self->lookup($format);                          return $self->lookup($format);
406                  } else {                  } else {
407                          return $format;                          return $format;
# Line 319  sub fill_in { Line 415  sub fill_in {
415    
416  Perform lookups on format supplied to it.  Perform lookups on format supplied to it.
417    
418   my $txt = $self->lookup('[v900]');   my $text = $self->lookup('[v900]');
419    
420  Lookups can be nested (like C<[d:[a:[v900]]]>).  Lookups can be nested (like C<[d:[a:[v900]]]>).
421    
# Line 328  Lookups can be nested (like C<[d:[a:[v90 Line 424  Lookups can be nested (like C<[d:[a:[v90
424  sub lookup {  sub lookup {
425          my $self = shift;          my $self = shift;
426    
427          my $tmp = shift || confess "need format";          my $log = $self->_get_logger();
428    
429          if ($tmp =~ /\[[^\[\]]+\]/o) {          my $tmp = shift || $log->logconfess("need format");
430    
431            if ($tmp =~ /$LOOKUP_REGEX/o) {
432                  my @in = ( $tmp );                  my @in = ( $tmp );
433  #print "##lookup $tmp\n";  
434                    $log->debug("lookup for: ",$tmp);
435    
436                  my @out;                  my @out;
437                  while (my $f = shift @in) {                  while (my $f = shift @in) {
438                          if ($f =~ /\[([^\[\]]+)\]/) {                          if ($f =~ /$LOOKUP_REGEX_SAVE/o) {
439                                  my $k = $1;                                  my $k = $1;
440                                  if ($self->{'lookup'}->{$k}) {                                  if ($self->{'lookup'}->{$k}) {
 #print "## lookup key = $k\n";  
441                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {
442                                                  my $tmp2 = $f;                                                  my $tmp2 = $f;
443                                                  $tmp2 =~ s/\[$k\]/$nv/g;                                                  $tmp2 =~ s/lookup{$k}/$nv/g;
444                                                  push @in, $tmp2;                                                  push @in, $tmp2;
 #print "## lookup in => $tmp2\n";  
445                                          }                                          }
446                                  } else {                                  } else {
447                                          undef $f;                                          undef $f;
448                                  }                                  }
449                          } elsif ($f) {                          } elsif ($f) {
450                                  push @out, $f;                                  push @out, $f;
 #print "## lookup out => $f\n";  
451                          }                          }
452                  }                  }
453                    $log->logconfess("return is array and it's not expected!") unless wantarray;
454                  return @out;                  return @out;
455          } else {          } else {
456                  return $tmp;                  return $tmp;
# Line 365  Perform smart parsing of string, skippin Line 463  Perform smart parsing of string, skippin
463  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
464  return output or nothing depending on eval code.  return output or nothing depending on eval code.
465    
466   $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);
467    
468  =cut  =cut
469    
470  sub parse {  sub parse {
471          my $self = shift;          my $self = shift;
472    
473          my ($rec, $format, $i) = @_;          my ($rec, $format_utf8, $i) = @_;
474    
475            return if (! $format_utf8);
476    
477            my $log = $self->_get_logger();
478    
479          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
480            $log->logconfess("need utf2cp Text::Iconv object!") if (! $self->{'utf2cp'});
481    
482          $i = 0 if (! $i);          $i = 0 if (! $i);
483    
484            my $format = $self->{'utf2cp'}->convert($format_utf8) || $log->logconfess("can't convert '$format_utf8' from UTF-8 to ",$self->{'code_page'});
485    
486          my @out;          my @out;
487    
488            $log->debug("format: $format");
489    
490          my $eval_code;          my $eval_code;
491          # remove eval{...} from beginning          # remove eval{...} from beginning
492          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
# Line 387  sub parse { Line 494  sub parse {
494          my $prefix;          my $prefix;
495          my $all_found=0;          my $all_found=0;
496    
497  #print "## $format\n";          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))?//s) {
         while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))*//s) {  
 #print "## [ $1 | $2 | $3 ] $format\n";  
498    
499                  my $del = $1 || '';                  my $del = $1 || '';
500                  $prefix ||= $del if ($all_found == 0);                  $prefix ||= $del if ($all_found == 0);
# Line 406  sub parse { Line 511  sub parse {
511    
512          return if (! $all_found);          return if (! $all_found);
513    
514          my $out = join('',@out) . $format;          my $out = join('',@out);
515    
516            if ($out) {
517                    # add rest of format (suffix)
518                    $out .= $format;
519    
520                    # add prefix if not there
521                    $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);
522    
523                    $log->debug("result: $out");
524            }
525    
         # add prefix if not there  
         $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);  
           
526          if ($eval_code) {          if ($eval_code) {
527                  my $eval = $self->fill_in($rec,$eval_code,$i);                  my $eval = $self->fill_in($rec,$eval_code,$i);
528                  return if (! eval $eval);                  $log->debug("about to eval{",$eval,"} format: $out");
529                    return if (! $self->_eval($eval));
530          }          }
531    
532          return $out;          return $out;
533  }  }
534    
535    =head2 parse_to_arr
536    
537    Similar to C<parse>, but returns array of all repeatable fields
538    
539     my @arr = $webpac->parse_to_arr($rec,'v250^a');
540    
541    =cut
542    
543    sub parse_to_arr {
544            my $self = shift;
545    
546            my ($rec, $format_utf8) = @_;
547    
548            my $log = $self->_get_logger();
549    
550            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
551            return if (! $format_utf8);
552    
553            my $i = 0;
554            my @arr;
555    
556            while (my $v = $self->parse($rec,$format_utf8,$i++)) {
557                    push @arr, $v;
558            }
559    
560            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
561    
562            return @arr;
563    }
564    
565    =head2 fill_in_to_arr
566    
567    Similar to C<fill_in>, but returns array of all repeatable fields. Usable
568    for fields which have lookups, so they shouldn't be parsed but rather
569    C<fill_id>ed.
570    
571     my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]');
572    
573    =cut
574    
575    sub fill_in_to_arr {
576            my $self = shift;
577    
578            my ($rec, $format_utf8) = @_;
579    
580            my $log = $self->_get_logger();
581    
582            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
583            return if (! $format_utf8);
584    
585            my $i = 0;
586            my @arr;
587    
588            while (my @v = $self->fill_in($rec,$format_utf8,$i++)) {
589                    push @arr, @v;
590            }
591    
592            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
593    
594            return @arr;
595    }
596    
597    
598    =head2 data_structure
599    
600    Create in-memory data structure which represents layout from C<import_xml>.
601    It is used later to produce output.
602    
603     my @ds = $webpac->data_structure($rec);
604    
605    =cut
606    
607    sub data_structure {
608            my $self = shift;
609    
610            my $log = $self->_get_logger();
611    
612            my $rec = shift;
613            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
614    
615            my @sorted_tags;
616            if ($self->{tags_by_order}) {
617                    @sorted_tags = @{$self->{tags_by_order}};
618            } else {
619                    @sorted_tags = sort { $self->_sort_by_order } keys %{$self->{'import_xml'}->{'indexer'}};
620                    $self->{tags_by_order} = \@sorted_tags;
621            }
622    
623            my @ds;
624    
625            $log->debug("tags: ",sub { join(", ",@sorted_tags) });
626    
627            foreach my $field (@sorted_tags) {
628    
629                    my $row;
630    
631    #print "field $field [",$self->{'tag'},"] = ",Dumper($self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}});
632    
633                    foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
634                            my $format = $tag->{'value'} || $tag->{'content'};
635    
636                            $log->debug("format: $format");
637    
638                            my @v;
639                            if ($format =~ /$LOOKUP_REGEX/o) {
640                                    @v = $self->fill_in_to_arr($rec,$format);
641                            } else {
642                                    @v = $self->parse_to_arr($rec,$format);
643                            }
644                            next if (! @v);
645    
646                            # does tag have type?
647                            if ($tag->{'type'}) {
648                                    push @{$row->{$tag->{'type'}}}, @v;
649                            } else {
650                                    push @{$row->{'display'}}, @v;
651                                    push @{$row->{'swish'}}, @v;
652                            }
653    
654                    }
655    
656                    if ($row) {
657                            $row->{'tag'} = $field;
658                            push @ds, $row;
659                            $log->debug("row $field: ",sub { Dumper($row) });
660                    }
661    
662            }
663    
664            return @ds;
665    
666    }
667    
668    =head2 output
669    
670    Create output from in-memory data structure using Template Toolkit template.
671    
672    my $text = $webpac->output( template => 'text.tt', data => @ds );
673    
674    =cut
675    
676    sub output {
677            my $self = shift;
678    
679            my $args = {@_};
680    
681            my $log = $self->_get_logger();
682    
683            $log->logconfess("need template name") if (! $args->{'template'});
684            $log->logconfess("need data array") if (! $args->{'data'});
685    
686            my $out;
687    
688            $self->{'tt'}->process(
689                    $args->{'template'},
690                    $args,
691                    \$out
692            ) || confess $self->{'tt'}->error();
693    
694            return $out;
695    }
696    
697    #
698    #
699    #
700    
701    =head1 INTERNAL METHODS
702    
703    Here is a quick list of internal methods, mostly useful to turn debugging
704    on them (see L<LOGGING> below for explanation).
705    
706    =cut
707    
708    =head2 _eval
709    
710    Internal function to eval code without C<strict 'subs'>.
711    
712    =cut
713    
714    sub _eval {
715            my $self = shift;
716    
717            my $code = shift || return;
718    
719            my $log = $self->_get_logger();
720    
721            no strict 'subs';
722            my $ret = eval $code;
723            if ($@) {
724                    $log->error("problem with eval code [$code]: $@");
725            }
726    
727            $log->debug("eval: ",$code," [",$ret,"]");
728    
729            return $ret || 0;
730    }
731    
732    =head2 _sort_by_order
733    
734    Sort xml tags data structure accoding to C<order=""> attribute.
735    
736    =cut
737    
738    sub _sort_by_order {
739            my $self = shift;
740    
741            my $va = $self->{'import_xml'}->{'indexer'}->{$a}->{'order'} ||
742                    $self->{'import_xml'}->{'indexer'}->{$a};
743            my $vb = $self->{'import_xml'}->{'indexer'}->{$b}->{'order'} ||
744                    $self->{'import_xml'}->{'indexer'}->{$b};
745    
746            return $va <=> $vb;
747    }
748    
749    sub _get_logger {
750            my $self = shift;
751    
752            my @c = caller(1);
753            return get_logger($c[3]);
754    }
755    
756    #
757    #
758    #
759    
760    =head1 LOGGING
761    
762    Logging in WebPAC is performed by L<Log::Log4perl> with config file
763    C<log.conf>.
764    
765    Methods defined above have different levels of logging, so
766    it's descriptions will be useful to turn (mostry B<debug> logging) on
767    or off to see why WabPAC isn't perforing as you expect it (it might even
768    be a bug!).
769    
770    B<This is different from normal Log4perl behaviour>. To repeat, you can
771    also use method names, and not only classes (which are just few)
772    to filter logging.
773    
774    =cut
775    
776  1;  1;

Legend:
Removed from v.362  
changed lines
  Added in v.373

  ViewVC Help
Powered by ViewVC 1.1.26