/[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 356 by dpavlin, Wed Jun 16 13:41:54 2004 UTC revision 375 by dpavlin, Sun Jun 20 17:52:41 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    
# 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 151  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 161  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->info("using type '",$self->{'type'},"' tag <",$self->{'tag'},">");
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->info("reading '$f'");
263    
264            $self->{'import_xml_file'} = $f;
265    
266            $self->{'import_xml'} = XMLin($f,
267                    ForceArray => [ $self->{'tag'}, 'config', 'format' ],
268            );
269    
270            $log->debug("import xml is ",sub { Dumper($self->{'import_xml'}) });
271    
272    }
273    
274  =head2 create_lookup  =head2 create_lookup
275    
276  Create lookup from record using lookup definition.  Create lookup from record using lookup definition.
277    
278     $self->create_lookup($rec, @lookups);
279    
280    Called internally by C<open_*> methods.
281    
282  =cut  =cut
283    
284  sub create_lookup {  sub create_lookup {
285          my $self = shift;          my $self = shift;
286    
287          my $rec = shift || confess "need record to create lookup";          my $log = $self->_get_logger();
288          confess("need HASH as first argument!") if ($rec !~ /HASH/o);  
289            my $rec = shift || $log->logconfess("need record to create lookup");
290            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
291    
292          foreach my $i (@_) {          foreach my $i (@_) {
293                  if ($i->{'eval'}) {                  if ($i->{'eval'}) {
# Line 183  sub create_lookup { Line 295  sub create_lookup {
295                          my $key = $self->fill_in($rec,$i->{'key'});                          my $key = $self->fill_in($rec,$i->{'key'});
296                          my @val = $self->fill_in($rec,$i->{'val'});                          my @val = $self->fill_in($rec,$i->{'val'});
297                          if ($key && @val && eval $eval) {                          if ($key && @val && eval $eval) {
298                                    $log->debug("stored $key = ",sub { join(" | ",@val) });
299                                  push @{$self->{'lookup'}->{$key}}, @val;                                  push @{$self->{'lookup'}->{$key}}, @val;
300                          }                          }
301                  } else {                  } else {
302                          my $key = $self->fill_in($rec,$i->{'key'});                          my $key = $self->fill_in($rec,$i->{'key'});
303                          my @val = $self->fill_in($rec,$i->{'val'});                          my @val = $self->fill_in($rec,$i->{'val'});
304                          if ($key && @val) {                          if ($key && @val) {
305                                    $log->debug("stored $key = ",sub { join(" | ",@val) });
306                                  push @{$self->{'lookup'}->{$key}}, @val;                                  push @{$self->{'lookup'}->{$key}}, @val;
307                          }                          }
308                  }                  }
# Line 199  sub create_lookup { Line 313  sub create_lookup {
313    
314  Returns value from record.  Returns value from record.
315    
316   $self->get_data(\$rec,$f,$sf,$i,\$found);   my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);
317    
318  Arguments are:  Arguments are:
319  record reference C<$rec>,  record reference C<$rec>,
# Line 207  field C<$f>, Line 321  field C<$f>,
321  optional subfiled C<$sf>,  optional subfiled C<$sf>,
322  index for repeatable values C<$i>.  index for repeatable values C<$i>.
323    
324  Optinal variable C<$found> will be incremeted if thre  Optinal variable C<$found> will be incremeted if there
325  is field.  is field.
326    
327  Returns value or empty string.  Returns value or empty string.
# Line 218  sub get_data { Line 332  sub get_data {
332          my $self = shift;          my $self = shift;
333    
334          my ($rec,$f,$sf,$i,$found) = @_;          my ($rec,$f,$sf,$i,$found) = @_;
335    
336          if ($$rec->{$f}) {          if ($$rec->{$f}) {
337                    return '' if (! $$rec->{$f}->[$i]);
338                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {
339                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
340                          return $$rec->{$f}->[$i]->{$sf};                          return $$rec->{$f}->[$i]->{$sf};
341                  } elsif ($$rec->{$f}->[$i]) {                  } elsif ($$rec->{$f}->[$i]) {
342                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
343                          return $$rec->{$f}->[$i];                          # it still might have subfield, just
344                            # not specified, so we'll dump all
345                            if ($$rec->{$f}->[$i] =~ /HASH/o) {
346                                    my $out;
347                                    foreach my $k (keys %{$$rec->{$f}->[$i]}) {
348                                            $out .= $$rec->{$f}->[$i]->{$k}." ";
349                                    }
350                                    return $out;
351                            } else {
352                                    return $$rec->{$f}->[$i];
353                            }
354                  }                  }
355          } else {          } else {
356                  return '';                  return '';
# Line 237  Workhourse of all: takes record from in- Line 363  Workhourse of all: takes record from in-
363  strings with placeholders and returns string or array of with substituted  strings with placeholders and returns string or array of with substituted
364  values from record.  values from record.
365    
366   $webpac->fill_in($rec,'v250^a');   my $text = $webpac->fill_in($rec,'v250^a');
367    
368  Optional argument is ordinal number for repeatable fields. By default,  Optional argument is ordinal number for repeatable fields. By default,
369  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
370  element is 0).  element is 0).
371  Following example will read second value from repeatable field.  Following example will read second value from repeatable field.
372    
373   $webpac->fill_in($rec,'Title: v250^a',1);   my $text = $webpac->fill_in($rec,'Title: v250^a',1);
374    
375  This function B<does not> perform parsing of format to inteligenty skip  This function B<does not> perform parsing of format to inteligenty skip
376  delimiters before fields which aren't used.  delimiters before fields which aren't used.
# Line 254  delimiters before fields which aren't us Line 380  delimiters before fields which aren't us
380  sub fill_in {  sub fill_in {
381          my $self = shift;          my $self = shift;
382    
383          my $rec = shift || confess "need data record";          my $log = $self->_get_logger();
384          my $format = shift || confess "need format to parse";  
385            my $rec = shift || $log->logconfess("need data record");
386            my $format = shift || $log->logconfess("need format to parse");
387          # iteration (for repeatable fields)          # iteration (for repeatable fields)
388          my $i = shift || 0;          my $i = shift || 0;
389    
390          # FIXME remove for speedup?          # FIXME remove for speedup?
391          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
392    
393          my $found = 0;          my $found = 0;
394    
395            my $eval_code;
396            # remove eval{...} from beginning
397            $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
398    
399          # do actual replacement of placeholders          # do actual replacement of placeholders
400          $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;
401    
402          if ($found) {          if ($found) {
403                    $log->debug("format: $format");
404                    if ($eval_code) {
405                            my $eval = $self->fill_in($rec,$eval_code,$i);
406                            return if (! $self->_eval($eval));
407                    }
408                  # do we have lookups?                  # do we have lookups?
409                  if ($format =~ /\[[^\[\]]+\]/o) {                  if ($format =~ /$LOOKUP_REGEX/o) {
410                            $log->debug("format '$format' has lookup");
411                          return $self->lookup($format);                          return $self->lookup($format);
412                  } else {                  } else {
413                          return $format;                          return $format;
# Line 283  sub fill_in { Line 421  sub fill_in {
421    
422  Perform lookups on format supplied to it.  Perform lookups on format supplied to it.
423    
424   my $txt = $self->lookup('[v900]');   my $text = $self->lookup('[v900]');
425    
426  Lookups can be nested (like C<[d:[a:[v900]]]>).  Lookups can be nested (like C<[d:[a:[v900]]]>).
427    
# Line 292  Lookups can be nested (like C<[d:[a:[v90 Line 430  Lookups can be nested (like C<[d:[a:[v90
430  sub lookup {  sub lookup {
431          my $self = shift;          my $self = shift;
432    
433          my $tmp = shift || confess "need format";          my $log = $self->_get_logger();
434    
435            my $tmp = shift || $log->logconfess("need format");
436    
437          if ($tmp =~ /\[[^\[\]]+\]/o) {          if ($tmp =~ /$LOOKUP_REGEX/o) {
438                  my @in = ( $tmp );                  my @in = ( $tmp );
439  #print "##lookup $tmp\n";  
440                    $log->debug("lookup for: ",$tmp);
441    
442                  my @out;                  my @out;
443                  while (my $f = shift @in) {                  while (my $f = shift @in) {
444                          if ($f =~ /\[([^\[\]]+)\]/) {                          if ($f =~ /$LOOKUP_REGEX_SAVE/o) {
445                                  my $k = $1;                                  my $k = $1;
446                                  if ($self->{'lookup'}->{$k}) {                                  if ($self->{'lookup'}->{$k}) {
 #print "## lookup key = $k\n";  
447                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {
448                                                  my $tmp2 = $f;                                                  my $tmp2 = $f;
449                                                  $tmp2 =~ s/\[$k\]/$nv/g;                                                  $tmp2 =~ s/lookup{$k}/$nv/g;
450                                                  push @in, $tmp2;                                                  push @in, $tmp2;
 #print "## lookup in => $tmp2\n";  
451                                          }                                          }
452                                  } else {                                  } else {
453                                          undef $f;                                          undef $f;
454                                  }                                  }
455                          } elsif ($f) {                          } elsif ($f) {
456                                  push @out, $f;                                  push @out, $f;
 #print "## lookup out => $f\n";  
457                          }                          }
458                  }                  }
459                    $log->logconfess("return is array and it's not expected!") unless wantarray;
460                  return @out;                  return @out;
461          } else {          } else {
462                  return $tmp;                  return $tmp;
# Line 329  Perform smart parsing of string, skippin Line 469  Perform smart parsing of string, skippin
469  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
470  return output or nothing depending on eval code.  return output or nothing depending on eval code.
471    
472   $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);
473    
474  =cut  =cut
475    
476  sub parse {  sub parse {
477          my $self = shift;          my $self = shift;
478    
479          my ($rec, $format, $i) = @_;          my ($rec, $format_utf8, $i) = @_;
480    
481            return if (! $format_utf8);
482    
483            my $log = $self->_get_logger();
484    
485            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
486            $log->logconfess("need utf2cp Text::Iconv object!") if (! $self->{'utf2cp'});
487    
488            $i = 0 if (! $i);
489    
490            my $format = $self->_x($format_utf8) || $log->logconfess("can't convert '$format_utf8' from UTF-8 to ",$self->{'code_page'});
491    
492          my @out;          my @out;
493    
494            $log->debug("format: $format");
495    
496          my $eval_code;          my $eval_code;
497          # remove eval{...} from beginning          # remove eval{...} from beginning
498          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
499    
500          my $prefix = '';          my $prefix;
501          $prefix = $1 if ($format =~ s/^(.+)(v\d+(?:\^\w)*)/$2/s);          my $all_found=0;
502    
503            while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))?//s) {
504    
505                    my $del = $1 || '';
506                    $prefix ||= $del if ($all_found == 0);
507    
508          sub f_sf_del {                  my $found = 0;
509                  my ($self,$rec,$out,$f,$sf,$del,$i) = @_;                  my $tmp = $self->get_data(\$rec,$2,$3,$i,\$found);
510    
                 my $found=0;  
                 my $tmp = $self->get_data($rec,$f,$sf,$i,\$found);  
511                  if ($found) {                  if ($found) {
512                          push @{$$out}, $tmp;                          push @out, $del;
513                          push @{$$out}, $del;                          push @out, $tmp;
514                            $all_found += $found;
515                  }                  }
                 return '';  
516          }          }
517    
518          #$format =~ s/(.*)v(\d+)(?:\^(\w))*/f_sf_del($self,\$rec,\@out,$2,$3,$1,$i/ges;          return if (! $all_found);
519    
520            my $out = join('',@out);
521    
522            if ($out) {
523                    # add rest of format (suffix)
524                    $out .= $format;
525    
526                    # add prefix if not there
527                    $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);
528    
529                    $log->debug("result: $out");
530            }
531    
532            if ($eval_code) {
533                    my $eval = $self->fill_in($rec,$eval_code,$i);
534                    $log->debug("about to eval{",$eval,"} format: $out");
535                    return if (! $self->_eval($eval));
536            }
537    
538            return $out;
539    }
540    
541    =head2 parse_to_arr
542    
543    Similar to C<parse>, but returns array of all repeatable fields
544    
545     my @arr = $webpac->parse_to_arr($rec,'v250^a');
546    
547    =cut
548    
549    sub parse_to_arr {
550            my $self = shift;
551    
552            my ($rec, $format_utf8) = @_;
553    
554            my $log = $self->_get_logger();
555    
556            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
557            return if (! $format_utf8);
558    
559            my $i = 0;
560            my @arr;
561    
562            while (my $v = $self->parse($rec,$format_utf8,$i++)) {
563                    push @arr, $v;
564            }
565    
566            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
567    
568            return @arr;
569    }
570    
571    =head2 fill_in_to_arr
572    
573          print Dumper(@out);  Similar to C<fill_in>, but returns array of all repeatable fields. Usable
574    for fields which have lookups, so they shouldn't be parsed but rather
575    C<fill_id>ed.
576    
577     my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]');
578    
579    =cut
580    
581    sub fill_in_to_arr {
582            my $self = shift;
583    
584            my ($rec, $format_utf8) = @_;
585    
586            my $log = $self->_get_logger();
587    
588            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
589            return if (! $format_utf8);
590    
591            my $i = 0;
592            my @arr;
593    
594            while (my @v = $self->fill_in($rec,$format_utf8,$i++)) {
595                    push @arr, @v;
596            }
597    
598            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
599    
600            return @arr;
601  }  }
602    
603    
604    =head2 data_structure
605    
606    Create in-memory data structure which represents layout from C<import_xml>.
607    It is used later to produce output.
608    
609     my @ds = $webpac->data_structure($rec);
610    
611    This method will also set C<$webpac->{'currnet_filename'}> if there is
612    <filename> tag in C<import_xml>.
613    
614    =cut
615    
616    sub data_structure {
617            my $self = shift;
618    
619            my $log = $self->_get_logger();
620    
621            my $rec = shift;
622            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
623    
624            undef $self->{'currnet_filename'};
625    
626            my @sorted_tags;
627            if ($self->{tags_by_order}) {
628                    @sorted_tags = @{$self->{tags_by_order}};
629            } else {
630                    @sorted_tags = sort { $self->_sort_by_order } keys %{$self->{'import_xml'}->{'indexer'}};
631                    $self->{tags_by_order} = \@sorted_tags;
632            }
633    
634            my @ds;
635    
636            $log->debug("tags: ",sub { join(", ",@sorted_tags) });
637    
638            foreach my $field (@sorted_tags) {
639    
640                    my $row;
641    
642    #print "field $field [",$self->{'tag'},"] = ",Dumper($self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}});
643    
644                    foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
645                            my $format = $tag->{'value'} || $tag->{'content'};
646    
647                            $log->debug("format: $format");
648    
649                            my @v;
650                            if ($format =~ /$LOOKUP_REGEX/o) {
651                                    @v = $self->fill_in_to_arr($rec,$format);
652                            } else {
653                                    @v = $self->parse_to_arr($rec,$format);
654                            }
655                            next if (! @v);
656    
657                            # use format?
658                            if ($tag->{'format_name'}) {
659                                    @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
660                            }
661    
662                            # does tag have type?
663                            if ($tag->{'type'}) {
664                                    push @{$row->{$tag->{'type'}}}, @v;
665                            } else {
666                                    push @{$row->{'display'}}, @v;
667                                    push @{$row->{'swish'}}, @v;
668                            }
669    
670                            if ($field eq 'filename') {
671                                    $self->{'current_filename'} = join('',@v);
672                                    $log->debug("filename: ",$self->{'current_filename'});
673                            }
674    
675                    }
676    
677                    if ($row) {
678                            $row->{'tag'} = $field;
679    
680                            # TODO: name_sigular, name_plural
681                            my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
682                            $row->{'name'} = $name ? $self->_x($name) : $field;
683    
684                            push @ds, $row;
685    
686                            $log->debug("row $field: ",sub { Dumper($row) });
687                    }
688    
689            }
690    
691            return @ds;
692    
693    }
694    
695    =head2 output
696    
697    Create output from in-memory data structure using Template Toolkit template.
698    
699    my $text = $webpac->output( template => 'text.tt', data => @ds );
700    
701    =cut
702    
703    sub output {
704            my $self = shift;
705    
706            my $args = {@_};
707    
708            my $log = $self->_get_logger();
709    
710            $log->logconfess("need template name") if (! $args->{'template'});
711            $log->logconfess("need data array") if (! $args->{'data'});
712    
713            my $out;
714    
715            $self->{'tt'}->process(
716                    $args->{'template'},
717                    $args,
718                    \$out
719            ) || confess $self->{'tt'}->error();
720    
721            return $out;
722    }
723    
724    =head2 apply_format
725    
726    Apply format specified in tag with C<format_name="name"> and
727    C<format_delimiter=";;">.
728    
729     my $text = $webpac->apply_format($format_name,$format_delimiter,$data);
730    
731    Formats can contain C<lookup{...}> if you need them.
732    
733    =cut
734    
735    sub apply_format {
736            my $self = shift;
737    
738            my ($name,$delimiter,$data) = @_;
739    
740            my $log = $self->_get_logger();
741    
742            if (! $self->{'import_xml'}->{'format'}->{$name}) {
743                    $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});
744                    return $data;
745            }
746    
747            $log->warn("no delimiter for format $name") if (! $delimiter);
748    
749            my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");
750    
751            my @data = split(/\Q$delimiter\E/, $data);
752    
753            my $out = sprintf($format, @data);
754            $log->debug("using format $name [$format] on $data to produce: $out");
755    
756            if ($out =~ m/$LOOKUP_REGEX/o) {
757                    return $self->lookup($out);
758            } else {
759                    return $out;
760            }
761    
762    }
763    
764    
765    #
766    #
767    #
768    
769    =head1 INTERNAL METHODS
770    
771    Here is a quick list of internal methods, mostly useful to turn debugging
772    on them (see L<LOGGING> below for explanation).
773    
774    =cut
775    
776    =head2 _eval
777    
778    Internal function to eval code without C<strict 'subs'>.
779    
780    =cut
781    
782    sub _eval {
783            my $self = shift;
784    
785            my $code = shift || return;
786    
787            my $log = $self->_get_logger();
788    
789            no strict 'subs';
790            my $ret = eval $code;
791            if ($@) {
792                    $log->error("problem with eval code [$code]: $@");
793            }
794    
795            $log->debug("eval: ",$code," [",$ret,"]");
796    
797            return $ret || 0;
798    }
799    
800    =head2 _sort_by_order
801    
802    Sort xml tags data structure accoding to C<order=""> attribute.
803    
804    =cut
805    
806    sub _sort_by_order {
807            my $self = shift;
808    
809            my $va = $self->{'import_xml'}->{'indexer'}->{$a}->{'order'} ||
810                    $self->{'import_xml'}->{'indexer'}->{$a};
811            my $vb = $self->{'import_xml'}->{'indexer'}->{$b}->{'order'} ||
812                    $self->{'import_xml'}->{'indexer'}->{$b};
813    
814            return $va <=> $vb;
815    }
816    
817    =head2 _get_logger
818    
819    Get C<Log::Log4perl> object with a twist: domains are defined for each
820    method
821    
822     my $log = $webpac->_get_logger();
823    
824    =cut
825    
826    sub _get_logger {
827            my $self = shift;
828    
829            my $name = (caller(1))[3] || caller;
830            return get_logger($name);
831    }
832    
833    =head2 _x
834    
835    Convert string from UTF-8 to code page defined in C<import_xml>.
836    
837     my $text = $webpac->_x('utf8 text');
838    
839    =cut
840    
841    sub _x {
842            my $self = shift;
843            my $utf8 = shift || return;
844    
845            return $self->{'utf2cp'}->convert($utf8) ||
846                    $self->_get_logger()->logwarn("can't convert '$utf8'");
847    }
848    
849    #
850    #
851    #
852    
853    =head1 LOGGING
854    
855    Logging in WebPAC is performed by L<Log::Log4perl> with config file
856    C<log.conf>.
857    
858    Methods defined above have different levels of logging, so
859    it's descriptions will be useful to turn (mostry B<debug> logging) on
860    or off to see why WabPAC isn't perforing as you expect it (it might even
861    be a bug!).
862    
863    B<This is different from normal Log4perl behaviour>. To repeat, you can
864    also use method names, and not only classes (which are just few)
865    to filter logging.
866    
867    =cut
868    
869  1;  1;

Legend:
Removed from v.356  
changed lines
  Added in v.375

  ViewVC Help
Powered by ViewVC 1.1.26