/[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 353 by dpavlin, Wed Jun 16 11:29:37 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;
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
23    
24  =head1 DESCRIPTION  =head1 DESCRIPTION
25    
26  This module implements methods used by WebPac.  This module implements methods used by WebPAC.
27    
28  =head1 METHODS  =head1 METHODS
29    
30  =head2 new  =head2 new
31    
32  This will create new instance of WebPac using configuration specified by C<config_file>.  This will create new instance of WebPAC using configuration specified by C<config_file>.
33    
34   my $webpac = new WebPac(   my $webpac = new WebPAC(
35          config_file => 'name.conf',          config_file => 'name.conf',
36          [code_page => 'ISO-8859-2',]          [code_page => 'ISO-8859-2',]
37   );   );
# Line 32  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 44  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 55  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 96  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 109  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 125  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});
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 156  sub open_isis { Line 193  sub open_isis {
193                  }                  }
194    
195                  # create lookup                  # create lookup
196                    my $rec = $self->{'data'}->{$mfn};
197                    $self->create_lookup($rec, @{$arg->{'lookup'}});
198    
199            }
200    
201            $self->{'current_mfn'} = 1;
202    
203            # store max mfn and return it.
204            return $self->{'max_mfn'} = $maxmfn;
205    }
206    
207    =head2 fetch_rec
208    
209    Fetch next record from database. It will also display progress bar (once
210    it's implemented, that is).
211    
212     my $rec = $webpac->fetch_rec;
213    
214    =cut
215    
216    sub fetch_rec {
217            my $self = shift;
218    
219            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'}) {
224                    $self->{'current_mfn'} = $self->{'max_mfn'};
225                    $log->debug("at EOF");
226                    return;
227            }
228    
229            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
269    
270    Create lookup from record using lookup definition.
271    
272                  foreach my $i (@{$arg->{lookup}}) {   $self->create_lookup($rec, @lookups);
273                          my $rec = $self->{'data'}->{$mfn};  
274                          if ($i->{'eval'}) {  Called internally by C<open_*> methods.
275                                  my $eval = $self->fill_in($rec,$i->{'eval'});  
276                                  my $key = $self->fill_in($rec,$i->{'key'});  =cut
277                                  my @val = $self->fill_in($rec,$i->{'val'});  
278                                  if ($key && @val && eval $eval) {  sub create_lookup {
279                                          push @{$self->{'lookup'}->{$key}}, @val;          my $self = shift;
280    
281            my $log = $self->_get_logger();
282    
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 (@_) {
287                    if ($i->{'eval'}) {
288                            my $eval = $self->fill_in($rec,$i->{'eval'});
289                            my $key = $self->fill_in($rec,$i->{'key'});
290                            my @val = $self->fill_in($rec,$i->{'val'});
291                            if ($key && @val && eval $eval) {
292                                    $log->debug("stored $key = ",sub { join(" | ",@val) });
293                                    push @{$self->{'lookup'}->{$key}}, @val;
294                            }
295                    } else {
296                            my $key = $self->fill_in($rec,$i->{'key'});
297                            my @val = $self->fill_in($rec,$i->{'val'});
298                            if ($key && @val) {
299                                    $log->debug("stored $key = ",sub { join(" | ",@val) });
300                                    push @{$self->{'lookup'}->{$key}}, @val;
301                            }
302                    }
303            }
304    }
305    
306    =head2 get_data
307    
308    Returns value from record.
309    
310     my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);
311    
312    Arguments are:
313    record reference C<$rec>,
314    field C<$f>,
315    optional subfiled C<$sf>,
316    index for repeatable values C<$i>.
317    
318    Optinal variable C<$found> will be incremeted if there
319    is field.
320    
321    Returns value or empty string.
322    
323    =cut
324    
325    sub get_data {
326            my $self = shift;
327    
328            my ($rec,$f,$sf,$i,$found) = @_;
329    
330            if ($$rec->{$f}) {
331                    return '' if (! $$rec->{$f}->[$i]);
332                    if ($sf && $$rec->{$f}->[$i]->{$sf}) {
333                            $$found++ if (defined($$found));
334                            return $$rec->{$f}->[$i]->{$sf};
335                    } elsif ($$rec->{$f}->[$i]) {
336                            $$found++ if (defined($$found));
337                            # 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 {                          } else {
346                                  my $key = $self->fill_in($rec,$i->{'key'});                                  return $$rec->{$f}->[$i];
                                 my @val = $self->fill_in($rec,$i->{'val'});  
                                 if ($key && @val) {  
                                         push @{$self->{'lookup'}->{$key}}, @val;  
                                 }  
347                          }                          }
348                  }                  }
349            } else {
350                    return '';
351          }          }
   
         # store max mfn and return it.  
         return $self->{'max_mfn'} = $maxmfn;  
352  }  }
353    
354  =head2 fill_in  =head2 fill_in
# Line 186  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 203  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          if ($rec !~ /HASH/o) {          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
                 confess("need HASH as first argument!");  
         }  
386    
387          my $found = 0;          my $found = 0;
388    
389          # get field with subfield          my $eval_code;
390          sub get_sf {          # remove eval{...} from beginning
391                  my ($found,$rec,$f,$sf,$i) = @_;          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
                 if ($$rec->{$f} && $$rec->{$f}->[$i]->{$sf}) {  
                         $$found++;  
                         return $$rec->{$f}->[$i]->{$sf};  
                 } else {  
                         return '';  
                 }  
         }  
   
         # get field (without subfield)  
         sub get_nosf {  
                 my ($found,$rec,$f,$i) = @_;  
                 if ($$rec->{$f} && $$rec->{$f}->[$i]) {  
                         $$found++;  
                         return $$rec->{$f}->[$i];  
                 } else {  
                         return '';  
                 }  
         }  
392    
393          # do actual replacement of placeholders          # do actual replacement of placeholders
394          $format =~ s/v(\d+)\^(\w)/get_sf(\$found,\$rec,$1,$2,$i)/ges;          $format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;
         $format =~ s/v(\d+)/get_nosf(\$found,\$rec,$1,$i)/ges;  
395    
396          if ($found) {          if ($found) {
397                    $log->debug("format: $format");
398                    if ($eval_code) {
399                            my $eval = $self->fill_in($rec,$eval_code,$i);
400                            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 255  sub fill_in { Line 413  sub fill_in {
413    
414  =head2 lookup  =head2 lookup
415    
416  This function will 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]]]>).
421    
422  =cut  =cut
423    
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            my $tmp = shift || $log->logconfess("need format");
430    
431          if ($tmp =~ /\[[^\[\]]+\]/o) {          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;
457          }          }
458  }  }
459    
460    =head2 parse
461    
462    Perform smart parsing of string, skipping delimiters for fields which aren't
463    defined. It can also eval code in format starting with C<eval{...}> and
464    return output or nothing depending on eval code.
465    
466     my $text = $webpac->parse($rec,'eval{"v901^a" eq "Deskriptor"}descriptor: v250^a', $i);
467    
468    =cut
469    
470    sub parse {
471            my $self = shift;
472    
473            my ($rec, $format_utf8, $i) = @_;
474    
475            return if (! $format_utf8);
476    
477            my $log = $self->_get_logger();
478    
479            $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);
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;
487    
488            $log->debug("format: $format");
489    
490            my $eval_code;
491            # remove eval{...} from beginning
492            $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
493    
494            my $prefix;
495            my $all_found=0;
496    
497            while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))?//s) {
498    
499                    my $del = $1 || '';
500                    $prefix ||= $del if ($all_found == 0);
501    
502                    my $found = 0;
503                    my $tmp = $self->get_data(\$rec,$2,$3,$i,\$found);
504    
505                    if ($found) {
506                            push @out, $del;
507                            push @out, $tmp;
508                            $all_found += $found;
509                    }
510            }
511    
512            return if (! $all_found);
513    
514            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    
526            if ($eval_code) {
527                    my $eval = $self->fill_in($rec,$eval_code,$i);
528                    $log->debug("about to eval{",$eval,"} format: $out");
529                    return if (! $self->_eval($eval));
530            }
531    
532            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.353  
changed lines
  Added in v.373

  ViewVC Help
Powered by ViewVC 1.1.26