/[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 352 by dpavlin, Tue Jun 15 22:40:07 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;
8    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 class does basic thing for 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   );   );
38    
39  Default C<code_page> is C<ISO-8859-2>.  Default C<code_page> is C<ISO-8859-2>.
40    
41    It will also read configuration files
42    C<global.conf> (used by indexer and Web font-end)
43    and configuration file specified by C<config_file>
44    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'});
70    
71          return $self;          #
72  }          # read global.conf
73            #
74  =head2 read_global_config          $log->debug("read 'global.conf'");
   
 Read global configuration (used by indexer and Web font-end)  
75    
76  =cut          my $config = new Config::IniFiles( -file => 'global.conf' ) || $log->logcroak("can't open 'global.conf'");
   
 sub read_global_config {  
         my $self = shift;  
   
         $self->{global_config_file} = new Config::IniFiles( -file => 'global.conf' ) || croak "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 56  sub read_global_config { Line 83  sub read_global_config {
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          return $self;          #
92  }          # read indexer config file
93            #
94  =head2 read_indexer_config  
95            $self->{indexer_config_file} = new Config::IniFiles( -file => $self->{config_file} ) || $log->logcroak("can't open '",$self->{config_file},"'");
96  Read indexer configuration (specify databases, types etc.)  
97            # create UTF-8 convertor for import_xml files
98  =cut          $self->{'utf2cp'} = Text::Iconv->new('UTF-8' ,$self->{'code_page'});
99    
100  sub read_indexer_config {          # create Template toolkit instance
101          my $self = shift;          $self->{'tt'} = Template->new(
102                    INCLUDE_PATH => ($self->{'global_config_file'}->{'output_template'} || './output_template'),
103          $self->{indexer_config_file} = new Config::IniFiles( -file => $self->{config_file} ) || croak "can't open '$self->{config_file}'";  #               FILTERS => {
104    #                       'foo' => \&foo_filter,
105          # read global config parametars  #               },
106          foreach my $var (qw(                  EVAL_PERL => 1,
107                          dbi_dbd          );
                         dbi_dsn  
                         dbi_user  
                         dbi_passwd  
                         show_progress  
                         my_unac_filter  
                 )) {  
                 $self->{global_config}->{$var} = $self->{global_config_file}->val('global', $var);  
         }  
108    
109          return $self;          return $self;
110  }  }
# Line 102  Open CDS/ISIS database using OpenIsis mo Line 122  Open CDS/ISIS database using OpenIsis mo
122    
123  By default, ISIS code page is assumed to be C<852>.  By default, ISIS code page is assumed to be C<852>.
124    
125  If C<limit_mfn> is set, it will read just 500 records from  If optional parametar C<limit_mfn> is set, it will read just 500 records
126  database in example above.  from database in example above.
   
 Returns number of last record read into memory (size of database, really).  
127    
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
# Line 118  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;
153    
154          #$self->{'isis_code_page'} = $code_page;          #$self->{'isis_code_page'} = $code_page;
155    
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 158  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                  }                  }
196    
197                  # create lookup                  # create lookup
198                    my $rec = $self->{'data'}->{$mfn};
199                    $self->create_lookup($rec, @{$arg->{'lookup'}});
200    
201                    $self->progress_bar($mfn,$maxmfn);
202    
203            }
204    
205                  foreach my $i (@{$arg->{lookup}}) {          $self->{'current_mfn'} = 1;
206                          my $rec = $self->{'data'}->{$mfn};          $self->{'last_pcnt'} = 0;
207                          if ($i->{'eval'}) {  
208                                  my $eval = $self->fill_in($rec,$i->{'eval'});          # store max mfn and return it.
209                                  my $key = $self->fill_in($rec,$i->{'key'});          return $self->{'max_mfn'} = $maxmfn;
210                                  my @val = $self->fill_in($rec,$i->{'val'});  }
211                                  if ($key && @val && eval $eval) {  
212                                          push @{$self->{'lookup'}->{$key}}, @val;  =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
315    
316    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
323    
324    sub create_lookup {
325            my $self = shift;
326    
327            my $log = $self->_get_logger();
328    
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 (@_) {
333                    if ($i->{'eval'}) {
334                            my $eval = $self->fill_in($rec,$i->{'eval'});
335                            my $key = $self->fill_in($rec,$i->{'key'});
336                            my @val = $self->fill_in($rec,$i->{'val'});
337                            if ($key && @val && eval $eval) {
338                                    $log->debug("stored $key = ",sub { join(" | ",@val) });
339                                    push @{$self->{'lookup'}->{$key}}, @val;
340                            }
341                    } else {
342                            my $key = $self->fill_in($rec,$i->{'key'});
343                            my @val = $self->fill_in($rec,$i->{'val'});
344                            if ($key && @val) {
345                                    $log->debug("stored $key = ",sub { join(" | ",@val) });
346                                    push @{$self->{'lookup'}->{$key}}, @val;
347                            }
348                    }
349            }
350    }
351    
352    =head2 get_data
353    
354    Returns value from record.
355    
356     my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);
357    
358    Arguments are:
359    record reference C<$rec>,
360    field C<$f>,
361    optional subfiled C<$sf>,
362    index for repeatable values C<$i>.
363    
364    Optinal variable C<$found> will be incremeted if there
365    is field.
366    
367    Returns value or empty string.
368    
369    =cut
370    
371    sub get_data {
372            my $self = shift;
373    
374            my ($rec,$f,$sf,$i,$found) = @_;
375    
376            if ($$rec->{$f}) {
377                    return '' if (! $$rec->{$f}->[$i]);
378                    no strict 'refs';
379                    if ($sf && $$rec->{$f}->[$i]->{$sf}) {
380                            $$found++ if (defined($$found));
381                            return $$rec->{$f}->[$i]->{$sf};
382                    } elsif ($$rec->{$f}->[$i]) {
383                            $$found++ if (defined($$found));
384                            # 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 {                          } else {
393                                  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;  
                                 }  
394                          }                          }
395                  }                  }
396            } else {
397                    return '';
398          }          }
   
         # store max mfn and return it.  
         return $self->{'max_mfn'} = $maxmfn;  
399  }  }
400    
401  =head2 fill_in  =head2 fill_in
# Line 193  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.  it's assume to be first repeatable field (fields are perl array, so first
411    element is 0).
412    Following example will read second value from repeatable field.
413    
414     my $text = $webpac->fill_in($rec,'Title: v250^a',1);
415    
416    This function B<does not> perform parsing of format to inteligenty skip
417    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          if ($rec !~ /HASH/) {          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
436                  confess("need HASH as first argument!");  
437            if (utf8::is_utf8($format)) {
438                    $format = $self->_x($format);
439          }          }
440    
441          my $found = 0;          my $found = 0;
442    
443          # get field with subfield          my $eval_code;
444          sub get_sf {          # remove eval{...} from beginning
445                  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 '';  
                 }  
         }  
446    
447          # do actual replacement of placeholders          # do actual replacement of placeholders
448          $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;  
449    
450          if ($found) {            if ($found) {
451                  return $format;                  $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?
457                    if ($format =~ /$LOOKUP_REGEX/o) {
458                            $log->debug("format '$format' has lookup");
459                            return $self->lookup($format);
460                    } else {
461                            return $format;
462                    }
463          } else {          } else {
464                  return;                  return;
465          }          }
# Line 250  sub fill_in { Line 467  sub fill_in {
467    
468  =head2 lookup  =head2 lookup
469    
470  This function will perform lookups on format supplied to it.  Perform lookups on format supplied to it.
471    
472     my $text = $self->lookup('[v900]');
473    
474   my $txt = $self->lookup('[v900]');  Lookups can be nested (like C<[d:[a:[v900]]]>).
475    
476  =cut  =cut
477    
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            my $tmp = shift || $log->logconfess("need format");
484    
485          if ($tmp =~ /\[[^\[\]]+\]/) {          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;
511          }          }
512  }  }
513    
514    =head2 parse
515    
516    Perform smart parsing of string, skipping delimiters for fields which aren't
517    defined. It can also eval code in format starting with C<eval{...}> and
518    return output or nothing depending on eval code.
519    
520     my $text = $webpac->parse($rec,'eval{"v901^a" eq "Deskriptor"}descriptor: v250^a', $i);
521    
522    =cut
523    
524    sub parse {
525            my $self = shift;
526    
527            my ($rec, $format_utf8, $i) = @_;
528    
529            return if (! $format_utf8);
530    
531            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);
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;
541    
542            $log->debug("format: $format");
543    
544            my $eval_code;
545            # remove eval{...} from beginning
546            $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
547    
548            my $prefix;
549            my $all_found=0;
550    
551            while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))?//s) {
552    
553                    my $del = $1 || '';
554                    $prefix ||= $del if ($all_found == 0);
555    
556                    my $found = 0;
557                    my $tmp = $self->get_data(\$rec,$2,$3,$i,\$found);
558    
559                    if ($found) {
560                            push @out, $del;
561                            push @out, $tmp;
562                            $all_found += $found;
563                    }
564            }
565    
566            return if (! $all_found);
567    
568            my $out = join('',@out);
569    
570            if ($out) {
571                    # add rest of format (suffix)
572                    $out .= $format;
573    
574                    # 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    
586            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.352  
changed lines
  Added in v.412

  ViewVC Help
Powered by ViewVC 1.1.26