/[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 412 by dpavlin, Tue Sep 7 18:01:36 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 163  sub open_isis { Line 198  sub open_isis {
198                  my $rec = $self->{'data'}->{$mfn};                  my $rec = $self->{'data'}->{$mfn};
199                  $self->create_lookup($rec, @{$arg->{'lookup'}});                  $self->create_lookup($rec, @{$arg->{'lookup'}});
200    
201                    $self->progress_bar($mfn,$maxmfn);
202    
203          }          }
204    
205            $self->{'current_mfn'} = 1;
206            $self->{'last_pcnt'} = 0;
207    
208          # store max mfn and return it.          # store max mfn and return it.
209          return $self->{'max_mfn'} = $maxmfn;          return $self->{'max_mfn'} = $maxmfn;
210  }  }
211    
212    =head2 fetch_rec
213    
214    Fetch next record from database. It will also display progress bar (once
215    it's implemented, that is).
216    
217     my $rec = $webpac->fetch_rec;
218    
219    =cut
220    
221    sub fetch_rec {
222            my $self = shift;
223    
224            my $log = $self->_get_logger();
225    
226            my $mfn = $self->{'current_mfn'}++ || $log->logconfess("it seems that you didn't load database!");
227    
228            if ($mfn > $self->{'max_mfn'}) {
229                    $self->{'current_mfn'} = $self->{'max_mfn'};
230                    $log->debug("at EOF");
231                    return;
232            }
233    
234            $self->progress_bar($mfn,$self->{'max_mfn'});
235    
236            return $self->{'data'}->{$mfn};
237    }
238    
239    =head2 progress_bar
240    
241    Draw progress bar on STDERR.
242    
243     $webpac->progress_bar($current, $max);
244    
245    =cut
246    
247    sub progress_bar {
248            my $self = shift;
249    
250            my ($curr,$max) = @_;
251    
252            my $log = $self->_get_logger();
253    
254            $log->logconfess("no current value!") if (! $curr);
255            $log->logconfess("no maximum value!") if (! $max);
256    
257            if ($curr > $max) {
258                    $max = $curr;
259                    $log->debug("overflow to $curr");
260            }
261    
262            $self->{'last_pcnt'} ||= 1;
263    
264            $self->{'last_pcnt'} = $curr if ($curr < $self->{'last_pcnt'});
265    
266            my $p = int($curr * 100 / $max);
267            if ($p != $self->{'last_pcnt'}) {
268                    printf STDERR ("%5d / %5d [%-51s] %-2d %% \r",$curr,$max,"=" x ($p/2).">", $p );
269                    $self->{'last_pcnt'} = $p;
270            }
271            print STDERR "\n" if ($p == 100);
272    }
273    
274    =head2 open_import_xml
275    
276    Read file from C<import_xml/> directory and parse it.
277    
278     $webpac->open_import_xml(type => 'isis');
279    
280    =cut
281    
282    sub open_import_xml {
283            my $self = shift;
284    
285            my $log = $self->_get_logger();
286    
287            my $arg = {@_};
288            $log->logconfess("need type to load file from import_xml/") if (! $arg->{'type'});
289    
290            $self->{'type'} = $arg->{'type'};
291    
292            my $type_base = $arg->{'type'};
293            $type_base =~ s/_.*$//g;
294    
295            $self->{'tag'} = $type2tag{$type_base};
296    
297            $log->info("using type '",$self->{'type'},"' tag <",$self->{'tag'},">");
298    
299            my $f = "./import_xml/".$self->{'type'}.".xml";
300            $log->logconfess("import_xml file '$f' doesn't exist!") if (! -e "$f");
301    
302            $log->info("reading '$f'");
303    
304            $self->{'import_xml_file'} = $f;
305    
306            $self->{'import_xml'} = XMLin($f,
307                    ForceArray => [ $self->{'tag'}, 'config', 'format' ],
308            );
309    
310            $log->debug("import xml is ",sub { Dumper($self->{'import_xml'}) });
311    
312    }
313    
314  =head2 create_lookup  =head2 create_lookup
315    
316  Create lookup from record using lookup definition.  Create lookup from record using lookup definition.
317    
318     $self->create_lookup($rec, @lookups);
319    
320    Called internally by C<open_*> methods.
321    
322  =cut  =cut
323    
324  sub create_lookup {  sub create_lookup {
325          my $self = shift;          my $self = shift;
326    
327          my $rec = shift || confess "need record to create lookup";          my $log = $self->_get_logger();
328          confess("need HASH as first argument!") if ($rec !~ /HASH/o);  
329            my $rec = shift || $log->logconfess("need record to create lookup");
330            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
331    
332          foreach my $i (@_) {          foreach my $i (@_) {
333                  if ($i->{'eval'}) {                  if ($i->{'eval'}) {
# Line 187  sub create_lookup { Line 335  sub create_lookup {
335                          my $key = $self->fill_in($rec,$i->{'key'});                          my $key = $self->fill_in($rec,$i->{'key'});
336                          my @val = $self->fill_in($rec,$i->{'val'});                          my @val = $self->fill_in($rec,$i->{'val'});
337                          if ($key && @val && eval $eval) {                          if ($key && @val && eval $eval) {
338                                    $log->debug("stored $key = ",sub { join(" | ",@val) });
339                                  push @{$self->{'lookup'}->{$key}}, @val;                                  push @{$self->{'lookup'}->{$key}}, @val;
340                          }                          }
341                  } else {                  } else {
342                          my $key = $self->fill_in($rec,$i->{'key'});                          my $key = $self->fill_in($rec,$i->{'key'});
343                          my @val = $self->fill_in($rec,$i->{'val'});                          my @val = $self->fill_in($rec,$i->{'val'});
344                          if ($key && @val) {                          if ($key && @val) {
345                                    $log->debug("stored $key = ",sub { join(" | ",@val) });
346                                  push @{$self->{'lookup'}->{$key}}, @val;                                  push @{$self->{'lookup'}->{$key}}, @val;
347                          }                          }
348                  }                  }
# Line 203  sub create_lookup { Line 353  sub create_lookup {
353    
354  Returns value from record.  Returns value from record.
355    
356   $self->get_data(\$rec,$f,$sf,$i,\$found);   my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);
357    
358  Arguments are:  Arguments are:
359  record reference C<$rec>,  record reference C<$rec>,
# Line 211  field C<$f>, Line 361  field C<$f>,
361  optional subfiled C<$sf>,  optional subfiled C<$sf>,
362  index for repeatable values C<$i>.  index for repeatable values C<$i>.
363    
364  Optinal variable C<$found> will be incremeted if thre  Optinal variable C<$found> will be incremeted if there
365  is field.  is field.
366    
367  Returns value or empty string.  Returns value or empty string.
# Line 222  sub get_data { Line 372  sub get_data {
372          my $self = shift;          my $self = shift;
373    
374          my ($rec,$f,$sf,$i,$found) = @_;          my ($rec,$f,$sf,$i,$found) = @_;
375    
376          if ($$rec->{$f}) {          if ($$rec->{$f}) {
377                    return '' if (! $$rec->{$f}->[$i]);
378                    no strict 'refs';
379                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {
380                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
381                          return $$rec->{$f}->[$i]->{$sf};                          return $$rec->{$f}->[$i]->{$sf};
382                  } elsif ($$rec->{$f}->[$i]) {                  } elsif ($$rec->{$f}->[$i]) {
383                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
384                          return $$rec->{$f}->[$i];                          # it still might have subfield, just
385                            # not specified, so we'll dump all
386                            if ($$rec->{$f}->[$i] =~ /HASH/o) {
387                                    my $out;
388                                    foreach my $k (keys %{$$rec->{$f}->[$i]}) {
389                                            $out .= $$rec->{$f}->[$i]->{$k}." ";
390                                    }
391                                    return $out;
392                            } else {
393                                    return $$rec->{$f}->[$i];
394                            }
395                  }                  }
396          } else {          } else {
397                  return '';                  return '';
# Line 241  Workhourse of all: takes record from in- Line 404  Workhourse of all: takes record from in-
404  strings with placeholders and returns string or array of with substituted  strings with placeholders and returns string or array of with substituted
405  values from record.  values from record.
406    
407   $webpac->fill_in($rec,'v250^a');   my $text = $webpac->fill_in($rec,'v250^a');
408    
409  Optional argument is ordinal number for repeatable fields. By default,  Optional argument is ordinal number for repeatable fields. By default,
410  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
411  element is 0).  element is 0).
412  Following example will read second value from repeatable field.  Following example will read second value from repeatable field.
413    
414   $webpac->fill_in($rec,'Title: v250^a',1);   my $text = $webpac->fill_in($rec,'Title: v250^a',1);
415    
416  This function B<does not> perform parsing of format to inteligenty skip  This function B<does not> perform parsing of format to inteligenty skip
417  delimiters before fields which aren't used.  delimiters before fields which aren't used.
418    
419    This method will automatically decode UTF-8 string to local code page
420    if needed.
421    
422  =cut  =cut
423    
424  sub fill_in {  sub fill_in {
425          my $self = shift;          my $self = shift;
426    
427          my $rec = shift || confess "need data record";          my $log = $self->_get_logger();
428          my $format = shift || confess "need format to parse";  
429            my $rec = shift || $log->logconfess("need data record");
430            my $format = shift || $log->logconfess("need format to parse");
431          # iteration (for repeatable fields)          # iteration (for repeatable fields)
432          my $i = shift || 0;          my $i = shift || 0;
433    
434          # FIXME remove for speedup?          # FIXME remove for speedup?
435          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
436    
437            if (utf8::is_utf8($format)) {
438                    $format = $self->_x($format);
439            }
440    
441          my $found = 0;          my $found = 0;
442    
443            my $eval_code;
444            # remove eval{...} from beginning
445            $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
446    
447          # do actual replacement of placeholders          # do actual replacement of placeholders
448          $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;
449    
450          if ($found) {          if ($found) {
451                    $log->debug("format: $format");
452                    if ($eval_code) {
453                            my $eval = $self->fill_in($rec,$eval_code,$i);
454                            return if (! $self->_eval($eval));
455                    }
456                  # do we have lookups?                  # do we have lookups?
457                  if ($format =~ /\[[^\[\]]+\]/o) {                  if ($format =~ /$LOOKUP_REGEX/o) {
458                            $log->debug("format '$format' has lookup");
459                          return $self->lookup($format);                          return $self->lookup($format);
460                  } else {                  } else {
461                          return $format;                          return $format;
# Line 287  sub fill_in { Line 469  sub fill_in {
469    
470  Perform lookups on format supplied to it.  Perform lookups on format supplied to it.
471    
472   my $txt = $self->lookup('[v900]');   my $text = $self->lookup('[v900]');
473    
474  Lookups can be nested (like C<[d:[a:[v900]]]>).  Lookups can be nested (like C<[d:[a:[v900]]]>).
475    
# Line 296  Lookups can be nested (like C<[d:[a:[v90 Line 478  Lookups can be nested (like C<[d:[a:[v90
478  sub lookup {  sub lookup {
479          my $self = shift;          my $self = shift;
480    
481          my $tmp = shift || confess "need format";          my $log = $self->_get_logger();
482    
483          if ($tmp =~ /\[[^\[\]]+\]/o) {          my $tmp = shift || $log->logconfess("need format");
484    
485            if ($tmp =~ /$LOOKUP_REGEX/o) {
486                  my @in = ( $tmp );                  my @in = ( $tmp );
487  #print "##lookup $tmp\n";  
488                    $log->debug("lookup for: ",$tmp);
489    
490                  my @out;                  my @out;
491                  while (my $f = shift @in) {                  while (my $f = shift @in) {
492                          if ($f =~ /\[([^\[\]]+)\]/) {                          if ($f =~ /$LOOKUP_REGEX_SAVE/o) {
493                                  my $k = $1;                                  my $k = $1;
494                                  if ($self->{'lookup'}->{$k}) {                                  if ($self->{'lookup'}->{$k}) {
 #print "## lookup key = $k\n";  
495                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {
496                                                  my $tmp2 = $f;                                                  my $tmp2 = $f;
497                                                  $tmp2 =~ s/\[$k\]/$nv/g;                                                  $tmp2 =~ s/lookup{$k}/$nv/g;
498                                                  push @in, $tmp2;                                                  push @in, $tmp2;
 #print "## lookup in => $tmp2\n";  
499                                          }                                          }
500                                  } else {                                  } else {
501                                          undef $f;                                          undef $f;
502                                  }                                  }
503                          } elsif ($f) {                          } elsif ($f) {
504                                  push @out, $f;                                  push @out, $f;
 #print "## lookup out => $f\n";  
505                          }                          }
506                  }                  }
507                    $log->logconfess("return is array and it's not expected!") unless wantarray;
508                  return @out;                  return @out;
509          } else {          } else {
510                  return $tmp;                  return $tmp;
# Line 333  Perform smart parsing of string, skippin Line 517  Perform smart parsing of string, skippin
517  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
518  return output or nothing depending on eval code.  return output or nothing depending on eval code.
519    
520   $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);
521    
522  =cut  =cut
523    
524  sub parse {  sub parse {
525          my $self = shift;          my $self = shift;
526    
527          my ($rec, $format, $i) = @_;          my ($rec, $format_utf8, $i) = @_;
528    
529            return if (! $format_utf8);
530    
531          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          my $log = $self->_get_logger();
532    
533            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
534            $log->logconfess("need utf2cp Text::Iconv object!") if (! $self->{'utf2cp'});
535    
536          $i = 0 if (! $i);          $i = 0 if (! $i);
537    
538            my $format = $self->_x($format_utf8) || $log->logconfess("can't convert '$format_utf8' from UTF-8 to ",$self->{'code_page'});
539    
540          my @out;          my @out;
541    
542            $log->debug("format: $format");
543    
544          my $eval_code;          my $eval_code;
545          # remove eval{...} from beginning          # remove eval{...} from beginning
546          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
# Line 355  sub parse { Line 548  sub parse {
548          my $prefix;          my $prefix;
549          my $all_found=0;          my $all_found=0;
550    
551  print "## $format\n";          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))?//s) {
         while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))*//s) {  
 print "## [ $1 | $2 | $3 ] $format\n";  
552    
553                  my $del = $1 || '';                  my $del = $1 || '';
554                  $prefix ||= $del;                  $prefix ||= $del if ($all_found == 0);
555    
556                  my $found = 0;                  my $found = 0;
557                  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 565  print "## [ $1 | $2 | $3 ] $format\n";
565    
566          return if (! $all_found);          return if (! $all_found);
567    
568          print Dumper($prefix, \@out);          my $out = join('',@out);
569    
570            if ($out) {
571                    # add rest of format (suffix)
572                    $out .= $format;
573    
574          my $out = join('',@out) . $format;                  # add prefix if not there
575                    $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);
576    
577                    $log->debug("result: $out");
578            }
579    
580            if ($eval_code) {
581                    my $eval = $self->fill_in($rec,$eval_code,$i);
582                    $log->debug("about to eval{",$eval,"} format: $out");
583                    return if (! $self->_eval($eval));
584            }
585    
         # add prefix if not there  
         $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);  
           
586          return $out;          return $out;
587  }  }
588    
589    =head2 parse_to_arr
590    
591    Similar to C<parse>, but returns array of all repeatable fields
592    
593     my @arr = $webpac->parse_to_arr($rec,'v250^a');
594    
595    =cut
596    
597    sub parse_to_arr {
598            my $self = shift;
599    
600            my ($rec, $format_utf8) = @_;
601    
602            my $log = $self->_get_logger();
603    
604            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
605            return if (! $format_utf8);
606    
607            my $i = 0;
608            my @arr;
609    
610            while (my $v = $self->parse($rec,$format_utf8,$i++)) {
611                    push @arr, $v;
612            }
613    
614            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
615    
616            return @arr;
617    }
618    
619    =head2 fill_in_to_arr
620    
621    Similar to C<fill_in>, but returns array of all repeatable fields. Usable
622    for fields which have lookups, so they shouldn't be parsed but rather
623    C<fill_id>ed.
624    
625     my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]');
626    
627    =cut
628    
629    sub fill_in_to_arr {
630            my $self = shift;
631    
632            my ($rec, $format_utf8) = @_;
633    
634            my $log = $self->_get_logger();
635    
636            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
637            return if (! $format_utf8);
638    
639            my $i = 0;
640            my @arr;
641    
642            while (my @v = $self->fill_in($rec,$format_utf8,$i++)) {
643                    push @arr, @v;
644            }
645    
646            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
647    
648            return @arr;
649    }
650    
651    
652    =head2 data_structure
653    
654    Create in-memory data structure which represents layout from C<import_xml>.
655    It is used later to produce output.
656    
657     my @ds = $webpac->data_structure($rec);
658    
659    This method will also set C<$webpac->{'currnet_filename'}> if there is
660    <filename> tag in C<import_xml> and C<$webpac->{'headline'}> if there is
661    <headline> tag.
662    
663    =cut
664    
665    sub data_structure {
666            my $self = shift;
667    
668            my $log = $self->_get_logger();
669    
670            my $rec = shift;
671            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
672    
673            undef $self->{'currnet_filename'};
674            undef $self->{'headline'};
675    
676            my @sorted_tags;
677            if ($self->{tags_by_order}) {
678                    @sorted_tags = @{$self->{tags_by_order}};
679            } else {
680                    @sorted_tags = sort { $self->_sort_by_order } keys %{$self->{'import_xml'}->{'indexer'}};
681                    $self->{tags_by_order} = \@sorted_tags;
682            }
683    
684            my @ds;
685    
686            $log->debug("tags: ",sub { join(", ",@sorted_tags) });
687    
688            foreach my $field (@sorted_tags) {
689    
690                    my $row;
691    
692    #print "field $field [",$self->{'tag'},"] = ",Dumper($self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}});
693    
694                    foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
695                            my $format = $tag->{'value'} || $tag->{'content'};
696    
697                            $log->debug("format: $format");
698    
699                            my @v;
700                            if ($format =~ /$LOOKUP_REGEX/o) {
701                                    @v = $self->fill_in_to_arr($rec,$format);
702                            } else {
703                                    @v = $self->parse_to_arr($rec,$format);
704                            }
705                            next if (! @v);
706    
707                            # use format?
708                            if ($tag->{'format_name'}) {
709                                    @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
710                            }
711    
712                            if ($field eq 'filename') {
713                                    $self->{'current_filename'} = join('',@v);
714                                    $log->debug("filename: ",$self->{'current_filename'});
715                            } elsif ($field eq 'headline') {
716                                    $self->{'headline'} .= join('',@v);
717                                    $log->debug("headline: ",$self->{'headline'});
718                                    next; # don't return headline in data_structure!
719                            }
720    
721                            # does tag have type?
722                            if ($tag->{'type'}) {
723                                    push @{$row->{$tag->{'type'}}}, @v;
724                            } else {
725                                    push @{$row->{'display'}}, @v;
726                                    push @{$row->{'swish'}}, @v;
727                            }
728    
729    
730                    }
731    
732                    if ($row) {
733                            $row->{'tag'} = $field;
734    
735                            # TODO: name_sigular, name_plural
736                            my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
737                            $row->{'name'} = $name ? $self->_x($name) : $field;
738    
739                            push @ds, $row;
740    
741                            $log->debug("row $field: ",sub { Dumper($row) });
742                    }
743    
744            }
745    
746            return @ds;
747    
748    }
749    
750    =head2 output
751    
752    Create output from in-memory data structure using Template Toolkit template.
753    
754    my $text = $webpac->output( template => 'text.tt', data => @ds );
755    
756    =cut
757    
758    sub output {
759            my $self = shift;
760    
761            my $args = {@_};
762    
763            my $log = $self->_get_logger();
764    
765            $log->logconfess("need template name") if (! $args->{'template'});
766            $log->logconfess("need data array") if (! $args->{'data'});
767    
768            my $out;
769    
770            $self->{'tt'}->process(
771                    $args->{'template'},
772                    $args,
773                    \$out
774            ) || confess $self->{'tt'}->error();
775    
776            return $out;
777    }
778    
779    =head2 output_file
780    
781    Create output from in-memory data structure using Template Toolkit template
782    to a file.
783    
784     $webpac->output_file(
785            file => 'out.txt',
786            template => 'text.tt',
787            data => @ds
788     );
789    
790    =cut
791    
792    sub output_file {
793            my $self = shift;
794    
795            my $args = {@_};
796    
797            my $log = $self->_get_logger();
798    
799            $log->logconfess("need file name") if (! $args->{'file'});
800    
801            $log->debug("creating file ",$args->{'file'});
802    
803            open(my $fh, ">", $args->{'file'}) || $log->logdie("can't open output file '$self->{'file'}': $!");
804            print $fh $self->output(
805                    template => $args->{'template'},
806                    data => $args->{'data'},
807            ) || $log->logdie("print: $!");
808            close($fh) || $log->logdie("close: $!");
809    }
810    
811    =head2 apply_format
812    
813    Apply format specified in tag with C<format_name="name"> and
814    C<format_delimiter=";;">.
815    
816     my $text = $webpac->apply_format($format_name,$format_delimiter,$data);
817    
818    Formats can contain C<lookup{...}> if you need them.
819    
820    =cut
821    
822    sub apply_format {
823            my $self = shift;
824    
825            my ($name,$delimiter,$data) = @_;
826    
827            my $log = $self->_get_logger();
828    
829            if (! $self->{'import_xml'}->{'format'}->{$name}) {
830                    $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});
831                    return $data;
832            }
833    
834            $log->warn("no delimiter for format $name") if (! $delimiter);
835    
836            my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");
837    
838            my @data = split(/\Q$delimiter\E/, $data);
839    
840            my $out = sprintf($format, @data);
841            $log->debug("using format $name [$format] on $data to produce: $out");
842    
843            if ($out =~ m/$LOOKUP_REGEX/o) {
844                    return $self->lookup($out);
845            } else {
846                    return $out;
847            }
848    
849    }
850    
851    
852    #
853    #
854    #
855    
856    =head1 INTERNAL METHODS
857    
858    Here is a quick list of internal methods, mostly useful to turn debugging
859    on them (see L<LOGGING> below for explanation).
860    
861    =cut
862    
863    =head2 _eval
864    
865    Internal function to eval code without C<strict 'subs'>.
866    
867    =cut
868    
869    sub _eval {
870            my $self = shift;
871    
872            my $code = shift || return;
873    
874            my $log = $self->_get_logger();
875    
876            no strict 'subs';
877            my $ret = eval $code;
878            if ($@) {
879                    $log->error("problem with eval code [$code]: $@");
880            }
881    
882            $log->debug("eval: ",$code," [",$ret,"]");
883    
884            return $ret || 0;
885    }
886    
887    =head2 _sort_by_order
888    
889    Sort xml tags data structure accoding to C<order=""> attribute.
890    
891    =cut
892    
893    sub _sort_by_order {
894            my $self = shift;
895    
896            my $va = $self->{'import_xml'}->{'indexer'}->{$a}->{'order'} ||
897                    $self->{'import_xml'}->{'indexer'}->{$a};
898            my $vb = $self->{'import_xml'}->{'indexer'}->{$b}->{'order'} ||
899                    $self->{'import_xml'}->{'indexer'}->{$b};
900    
901            return $va <=> $vb;
902    }
903    
904    =head2 _get_logger
905    
906    Get C<Log::Log4perl> object with a twist: domains are defined for each
907    method
908    
909     my $log = $webpac->_get_logger();
910    
911    =cut
912    
913    sub _get_logger {
914            my $self = shift;
915    
916            my $name = (caller(1))[3] || caller;
917            return get_logger($name);
918    }
919    
920    =head2 _x
921    
922    Convert string from UTF-8 to code page defined in C<import_xml>.
923    
924     my $text = $webpac->_x('utf8 text');
925    
926    =cut
927    
928    sub _x {
929            my $self = shift;
930            my $utf8 = shift || return;
931    
932            return $self->{'utf2cp'}->convert($utf8) ||
933                    $self->_get_logger()->logwarn("can't convert '$utf8'");
934    }
935    
936    #
937    #
938    #
939    
940    =head1 LOGGING
941    
942    Logging in WebPAC is performed by L<Log::Log4perl> with config file
943    C<log.conf>.
944    
945    Methods defined above have different levels of logging, so
946    it's descriptions will be useful to turn (mostry B<debug> logging) on
947    or off to see why WabPAC isn't perforing as you expect it (it might even
948    be a bug!).
949    
950    B<This is different from normal Log4perl behaviour>. To repeat, you can
951    also use method names, and not only classes (which are just few)
952    to filter logging.
953    
954    =cut
955    
956  1;  1;

Legend:
Removed from v.358  
changed lines
  Added in v.412

  ViewVC Help
Powered by ViewVC 1.1.26