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