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

Legend:
Removed from v.355  
changed lines
  Added in v.418

  ViewVC Help
Powered by ViewVC 1.1.26