/[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 358 by dpavlin, Wed Jun 16 14:31:33 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;
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 155  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 165  sub open_isis { Line 200  sub open_isis {
200    
201          }          }
202    
203            $self->{'current_mfn'} = 1;
204    
205          # store max mfn and return it.          # store max mfn and return it.
206          return $self->{'max_mfn'} = $maxmfn;          return $self->{'max_mfn'} = $maxmfn;
207  }  }
208    
209    =head2 fetch_rec
210    
211    Fetch next record from database. It will also display progress bar (once
212    it's implemented, that is).
213    
214     my $rec = $webpac->fetch_rec;
215    
216    =cut
217    
218    sub fetch_rec {
219            my $self = shift;
220    
221            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'}) {
226                    $self->{'current_mfn'} = $self->{'max_mfn'};
227                    $log->debug("at EOF");
228                    return;
229            }
230    
231            return $self->{'data'}->{$mfn};
232    }
233    
234    =head2 open_import_xml
235    
236    Read file from C<import_xml/> directory and parse it.
237    
238     $webpac->open_import_xml(type => 'isis');
239    
240    =cut
241    
242    sub open_import_xml {
243            my $self = shift;
244    
245            my $log = $self->_get_logger();
246    
247            my $arg = {@_};
248            $log->logconfess("need type to load file from import_xml/") if (! $arg->{'type'});
249    
250            $self->{'type'} = $arg->{'type'};
251    
252            my $type_base = $arg->{'type'};
253            $type_base =~ s/_.*$//g;
254    
255            $self->{'tag'} = $type2tag{$type_base};
256    
257            $log->debug("using type '",$self->{'type'},"' tag <",$self->{'tag'},">") if ($self->{'debug'});
258    
259            my $f = "./import_xml/".$self->{'type'}.".xml";
260            $log->logconfess("import_xml file '$f' doesn't exist!") if (! -e "$f");
261    
262            $log->debug("reading '$f'") if ($self->{'debug'});
263    
264            $self->{'import_xml'} = XMLin($f,
265                    ForceArray => [ $self->{'tag'}, 'config', 'format' ],
266            );
267    
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 187  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 203  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 211  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 222  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};
337                  } elsif ($$rec->{$f}->[$i]) {                  } elsif ($$rec->{$f}->[$i]) {
338                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
339                          return $$rec->{$f}->[$i];                          # it still might have subfield, just
340                            # not specified, so we'll dump all
341                            if ($$rec->{$f}->[$i] =~ /HASH/o) {
342                                    my $out;
343                                    foreach my $k (keys %{$$rec->{$f}->[$i]}) {
344                                            $out .= $$rec->{$f}->[$i]->{$k}." ";
345                                    }
346                                    return $out;
347                            } else {
348                                    return $$rec->{$f}->[$i];
349                            }
350                  }                  }
351          } else {          } else {
352                  return '';                  return '';
# Line 241  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 258  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    
391            my $eval_code;
392            # remove eval{...} from beginning
393            $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) {
401                            my $eval = $self->fill_in($rec,$eval_code,$i);
402                            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 287  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 296  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 333  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    
472  sub parse {  sub parse {
473          my $self = shift;          my $self = shift;
474    
475          my ($rec, $format, $i) = @_;          my ($rec, $format_utf8, $i) = @_;
476    
477          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          return if (! $format_utf8);
478    
479            my $log = $self->_get_logger();
480    
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) || $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 355  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;                  $prefix ||= $del if ($all_found == 0);
503    
504                  my $found = 0;                  my $found = 0;
505                  my $tmp = $self->get_data(\$rec,$2,$3,$i,\$found);                  my $tmp = $self->get_data(\$rec,$2,$3,$i,\$found);
# Line 374  print "## [ $1 | $2 | $3 ] $format\n"; Line 513  print "## [ $1 | $2 | $3 ] $format\n";
513    
514          return if (! $all_found);          return if (! $all_found);
515    
516          print Dumper($prefix, \@out);          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    
528            if ($eval_code) {
529                    my $eval = $self->fill_in($rec,$eval_code,$i);
530                    $log->debug("about to eval{",$eval,"} format: $out");
531                    return if (! $self->_eval($eval));
532            }
533    
534            return $out;
535    }
536    
537    =head2 parse_to_arr
538    
539    Similar to C<parse>, but returns array of all repeatable fields
540    
541     my @arr = $webpac->parse_to_arr($rec,'v250^a');
542    
543    =cut
544    
545    sub parse_to_arr {
546            my $self = shift;
547    
548            my ($rec, $format_utf8) = @_;
549    
550            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 {
613            my $self = shift;
614    
615            my $log = $self->_get_logger();
616    
617            my $rec = shift;
618            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
619    
620            undef $self->{'currnet_filename'};
621    
622            my @sorted_tags;
623            if ($self->{tags_by_order}) {
624                    @sorted_tags = @{$self->{tags_by_order}};
625            } else {
626                    @sorted_tags = sort { $self->_sort_by_order } keys %{$self->{'import_xml'}->{'indexer'}};
627                    $self->{tags_by_order} = \@sorted_tags;
628            }
629    
630            my @ds;
631    
632            $log->debug("tags: ",sub { join(", ",@sorted_tags) });
633    
634            foreach my $field (@sorted_tags) {
635    
636                    my $row;
637    
638    #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'}}}) {
641                            my $format = $tag->{'value'} || $tag->{'content'};
642    
643                            $log->debug("format: $format");
644    
645                            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?
654                            if ($tag->{'type'}) {
655                                    push @{$row->{$tag->{'type'}}}, @v;
656                            } else {
657                                    push @{$row->{'display'}}, @v;
658                                    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                    if ($row) {
669                            $row->{'tag'} = $field;
670                            push @ds, $row;
671    
672                            $log->debug("row $field: ",sub { Dumper($row) });
673                    }
674    
675          my $out = join('',@out) . $format;          }
676    
677            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    
         # add prefix if not there  
         $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);  
           
707          return $out;          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.358  
changed lines
  Added in v.374
  ViewVC Help
Powered by ViewVC 1.1.26