/[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 362 by dpavlin, Wed Jun 16 16:50:30 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;  use Text::Iconv;
8  use Config::IniFiles;  use Config::IniFiles;
9    use XML::Simple;
10    use Template;
11    use Log::Log4perl qw(get_logger :levels);
12    
13  use Data::Dumper;  use Data::Dumper;
14    
15    #my $LOOKUP_REGEX = '\[[^\[\]]+\]';
16    #my $LOOKUP_REGEX_SAVE = '\[([^\[\]]+)\]';
17    my $LOOKUP_REGEX = 'lookup{[^\{\}]+}';
18    my $LOOKUP_REGEX_SAVE = 'lookup{([^\{\}]+)}';
19    
20  =head1 NAME  =head1 NAME
21    
22  WebPAC - base class for WebPAC  WebPAC - base class for WebPAC
# Line 34  which describes databases to be indexed. Line 45  which describes databases to be indexed.
45    
46  =cut  =cut
47    
48    # mapping between data type and tag which specify
49    # format in XML file
50    my %type2tag = (
51            'isis' => 'isis',
52    #       'excel' => 'column',
53    #       'marc' => 'marc',
54    #       'feed' => 'feed'
55    );
56    
57  sub new {  sub new {
58          my $class = shift;          my $class = shift;
59          my $self = {@_};          my $self = {@_};
60          bless($self, $class);          bless($self, $class);
61    
62            my $log_file = $self->{'log'} || "log.conf";
63            Log::Log4perl->init($log_file);
64    
65            my $log = $self->_get_logger();
66    
67          # fill in default values          # fill in default values
68          # output codepage          # output codepage
69          $self->{'code_page'} = 'ISO-8859-2' if (! $self->{'code_page'});          $self->{'code_page'} = 'ISO-8859-2' if (! $self->{'code_page'});
# Line 46  sub new { Line 71  sub new {
71          #          #
72          # read global.conf          # read global.conf
73          #          #
74            $log->debug("read 'global.conf'");
75    
76          $self->{global_config_file} = new Config::IniFiles( -file => 'global.conf' ) || croak "can't open 'global.conf'";          my $config = new Config::IniFiles( -file => 'global.conf' ) || $log->logcroak("can't open 'global.conf'");
77    
78          # read global config parametars          # read global config parametars
79          foreach my $var (qw(          foreach my $var (qw(
# Line 57  sub new { Line 83  sub new {
83                          dbi_passwd                          dbi_passwd
84                          show_progress                          show_progress
85                          my_unac_filter                          my_unac_filter
86                            output_template
87                  )) {                  )) {
88                  $self->{global_config}->{$var} = $self->{global_config_file}->val('global', $var);                  $self->{'global_config'}->{$var} = $config->val('global', $var);
89          }          }
90    
91          #          #
92          # read indexer config file          # read indexer config file
93          #          #
94    
95          $self->{indexer_config_file} = new Config::IniFiles( -file => $self->{config_file} ) || croak "can't open '$self->{config_file}'";          $self->{indexer_config_file} = new Config::IniFiles( -file => $self->{config_file} ) || $log->logcroak("can't open '",$self->{config_file},"'");
96    
97          # read global config parametars          # create UTF-8 convertor for import_xml files
98          foreach my $var (qw(          $self->{'utf2cp'} = Text::Iconv->new('UTF-8' ,$self->{'code_page'});
99                          dbi_dbd  
100                          dbi_dsn          # create Template toolkit instance
101                          dbi_user          $self->{'tt'} = Template->new(
102                          dbi_passwd                  INCLUDE_PATH => ($self->{'global_config_file'}->{'output_template'} || './output_template'),
103                          show_progress  #               FILTERS => {
104                          my_unac_filter  #                       'foo' => \&foo_filter,
105                  )) {  #               },
106                  $self->{global_config}->{$var} = $self->{global_config_file}->val('global', $var);                  EVAL_PERL => 1,
107          }          );
108    
109          return $self;          return $self;
110  }  }
# Line 98  By default, ISIS code page is assumed to Line 125  By default, ISIS code page is assumed to
125  If optional parametar C<limit_mfn> is set, it will read just 500 records  If optional parametar C<limit_mfn> is set, it will read just 500 records
126  from database in example above.  from database in example above.
127    
 Returns number of last record read into memory (size of database, really).  
   
128  C<lookup> argument is an array of lookups to create. Each lookup must have C<key> and  C<lookup> argument is an array of lookups to create. Each lookup must have C<key> and
129  C<val>. Optional parametar C<eval> is perl code to evaluate before storing  C<val>. Optional parametar C<eval> is perl code to evaluate before storing
130  value in index.  value in index.
# Line 111  value in index. Line 136  value in index.
136      'val' => 'v900' },      'val' => 'v900' },
137   ]   ]
138    
139    Returns number of last record read into memory (size of database, really).
140    
141  =cut  =cut
142    
143  sub open_isis {  sub open_isis {
144          my $self = shift;          my $self = shift;
145          my $arg = {@_};          my $arg = {@_};
146    
147          croak "need filename" if (! $arg->{'filename'});          my $log = $self->_get_logger();
148    
149            $log->logcroak("need filename") if (! $arg->{'filename'});
150          my $code_page = $arg->{'code_page'} || '852';          my $code_page = $arg->{'code_page'} || '852';
151    
152          use OpenIsis;          use OpenIsis;
# Line 127  sub open_isis { Line 156  sub open_isis {
156          # create Text::Iconv object          # create Text::Iconv object
157          my $cp = Text::Iconv->new($code_page,$self->{'code_page'});          my $cp = Text::Iconv->new($code_page,$self->{'code_page'});
158    
159            $log->info("reading ISIS database '",$arg->{'filename'},"'");
160    
161          my $isis_db = OpenIsis::open($arg->{'filename'});          my $isis_db = OpenIsis::open($arg->{'filename'});
162    
163          my $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;          my $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;
164    
165          $maxmfn = $self->{limit_mfn} if ($self->{limit_mfn});          $maxmfn = $self->{limit_mfn} if ($self->{limit_mfn});
166    
167            $log->info("processing $maxmfn records...");
168    
169          # read database          # read database
170          for (my $mfn = 1; $mfn <= $maxmfn; $mfn++) {          for (my $mfn = 1; $mfn <= $maxmfn; $mfn++) {
171    
# Line 155  sub open_isis { Line 188  sub open_isis {
188    
189                                          push @{$self->{'data'}->{$mfn}->{$k}}, $val;                                          push @{$self->{'data'}->{$mfn}->{$k}}, $val;
190                                  }                                  }
191                            } else {
192                                    push @{$self->{'data'}->{$mfn}->{'000'}}, $mfn;
193                          }                          }
194    
195                  }                  }
# Line 183  it's implemented, that is). Line 218  it's implemented, that is).
218  sub fetch_rec {  sub fetch_rec {
219          my $self = shift;          my $self = shift;
220    
221          my $mfn = $self->{'current_mfn'}++ || confess "it seems that you didn't load database!";          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'}) {          if ($mfn > $self->{'max_mfn'}) {
226                  $self->{'current_mfn'} = $self->{'max_mfn'};                  $self->{'current_mfn'} = $self->{'max_mfn'};
227                    $log->debug("at EOF");
228                  return;                  return;
229          }          }
230    
231          return $self->{'data'}->{$mfn};          return $self->{'data'}->{$mfn};
232  }  }
233    
234    =head2 open_import_xml
235    
236    Read file from C<import_xml/> directory and parse it.
237    
238     $webpac->open_import_xml(type => 'isis');
239    
240    =cut
241    
242    sub open_import_xml {
243            my $self = shift;
244    
245            my $log = $self->_get_logger();
246    
247            my $arg = {@_};
248            $log->logconfess("need type to load file from import_xml/") if (! $arg->{'type'});
249    
250            $self->{'type'} = $arg->{'type'};
251    
252            my $type_base = $arg->{'type'};
253            $type_base =~ s/_.*$//g;
254    
255            $self->{'tag'} = $type2tag{$type_base};
256    
257            $log->info("using type '",$self->{'type'},"' tag <",$self->{'tag'},">");
258    
259            my $f = "./import_xml/".$self->{'type'}.".xml";
260            $log->logconfess("import_xml file '$f' doesn't exist!") if (! -e "$f");
261    
262            $log->info("reading '$f'");
263    
264            $self->{'import_xml_file'} = $f;
265    
266            $self->{'import_xml'} = XMLin($f,
267                    ForceArray => [ $self->{'tag'}, 'config', 'format' ],
268            );
269    
270            $log->debug("import xml is ",sub { Dumper($self->{'import_xml'}) });
271    
272    }
273    
274  =head2 create_lookup  =head2 create_lookup
275    
276  Create lookup from record using lookup definition.  Create lookup from record using lookup definition.
277    
278     $self->create_lookup($rec, @lookups);
279    
280    Called internally by C<open_*> methods.
281    
282  =cut  =cut
283    
284  sub create_lookup {  sub create_lookup {
285          my $self = shift;          my $self = shift;
286    
287          my $rec = shift || confess "need record to create lookup";          my $log = $self->_get_logger();
288          confess("need HASH as first argument!") if ($rec !~ /HASH/o);  
289            my $rec = shift || $log->logconfess("need record to create lookup");
290            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
291    
292          foreach my $i (@_) {          foreach my $i (@_) {
293                  if ($i->{'eval'}) {                  if ($i->{'eval'}) {
# Line 211  sub create_lookup { Line 295  sub create_lookup {
295                          my $key = $self->fill_in($rec,$i->{'key'});                          my $key = $self->fill_in($rec,$i->{'key'});
296                          my @val = $self->fill_in($rec,$i->{'val'});                          my @val = $self->fill_in($rec,$i->{'val'});
297                          if ($key && @val && eval $eval) {                          if ($key && @val && eval $eval) {
298                                    $log->debug("stored $key = ",sub { join(" | ",@val) });
299                                  push @{$self->{'lookup'}->{$key}}, @val;                                  push @{$self->{'lookup'}->{$key}}, @val;
300                          }                          }
301                  } else {                  } else {
302                          my $key = $self->fill_in($rec,$i->{'key'});                          my $key = $self->fill_in($rec,$i->{'key'});
303                          my @val = $self->fill_in($rec,$i->{'val'});                          my @val = $self->fill_in($rec,$i->{'val'});
304                          if ($key && @val) {                          if ($key && @val) {
305                                    $log->debug("stored $key = ",sub { join(" | ",@val) });
306                                  push @{$self->{'lookup'}->{$key}}, @val;                                  push @{$self->{'lookup'}->{$key}}, @val;
307                          }                          }
308                  }                  }
# Line 227  sub create_lookup { Line 313  sub create_lookup {
313    
314  Returns value from record.  Returns value from record.
315    
316   $self->get_data(\$rec,$f,$sf,$i,\$found);   my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);
317    
318  Arguments are:  Arguments are:
319  record reference C<$rec>,  record reference C<$rec>,
# Line 235  field C<$f>, Line 321  field C<$f>,
321  optional subfiled C<$sf>,  optional subfiled C<$sf>,
322  index for repeatable values C<$i>.  index for repeatable values C<$i>.
323    
324  Optinal variable C<$found> will be incremeted if thre  Optinal variable C<$found> will be incremeted if there
325  is field.  is field.
326    
327  Returns value or empty string.  Returns value or empty string.
# Line 246  sub get_data { Line 332  sub get_data {
332          my $self = shift;          my $self = shift;
333    
334          my ($rec,$f,$sf,$i,$found) = @_;          my ($rec,$f,$sf,$i,$found) = @_;
335    
336          if ($$rec->{$f}) {          if ($$rec->{$f}) {
337                    return '' if (! $$rec->{$f}->[$i]);
338                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {
339                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
340                          return $$rec->{$f}->[$i]->{$sf};                          return $$rec->{$f}->[$i]->{$sf};
341                  } elsif ($$rec->{$f}->[$i]) {                  } elsif ($$rec->{$f}->[$i]) {
342                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
343                          return $$rec->{$f}->[$i];                          # it still might have subfield, just
344                            # not specified, so we'll dump all
345                            if ($$rec->{$f}->[$i] =~ /HASH/o) {
346                                    my $out;
347                                    foreach my $k (keys %{$$rec->{$f}->[$i]}) {
348                                            $out .= $$rec->{$f}->[$i]->{$k}." ";
349                                    }
350                                    return $out;
351                            } else {
352                                    return $$rec->{$f}->[$i];
353                            }
354                  }                  }
355          } else {          } else {
356                  return '';                  return '';
# Line 265  Workhourse of all: takes record from in- Line 363  Workhourse of all: takes record from in-
363  strings with placeholders and returns string or array of with substituted  strings with placeholders and returns string or array of with substituted
364  values from record.  values from record.
365    
366   $webpac->fill_in($rec,'v250^a');   my $text = $webpac->fill_in($rec,'v250^a');
367    
368  Optional argument is ordinal number for repeatable fields. By default,  Optional argument is ordinal number for repeatable fields. By default,
369  it's assume to be first repeatable field (fields are perl array, so first  it's assume to be first repeatable field (fields are perl array, so first
370  element is 0).  element is 0).
371  Following example will read second value from repeatable field.  Following example will read second value from repeatable field.
372    
373   $webpac->fill_in($rec,'Title: v250^a',1);   my $text = $webpac->fill_in($rec,'Title: v250^a',1);
374    
375  This function B<does not> perform parsing of format to inteligenty skip  This function B<does not> perform parsing of format to inteligenty skip
376  delimiters before fields which aren't used.  delimiters before fields which aren't used.
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          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
395    
396            if (utf8::is_utf8($format)) {
397                    $format = $self->_x($format);
398            }
399    
400          my $found = 0;          my $found = 0;
401    
# Line 297  sub fill_in { Line 404  sub fill_in {
404          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
405    
406          # do actual replacement of placeholders          # do actual replacement of placeholders
407          $format =~ s/v(\d+)(?:\^(\w))*/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;          $format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;
408    
409          if ($found) {          if ($found) {
410                    $log->debug("format: $format");
411                  if ($eval_code) {                  if ($eval_code) {
412                          my $eval = $self->fill_in($rec,$eval_code,$i);                          my $eval = $self->fill_in($rec,$eval_code,$i);
413                          return if (! eval $eval);                          return if (! $self->_eval($eval));
414                  }                  }
415                  # do we have lookups?                  # do we have lookups?
416                  if ($format =~ /\[[^\[\]]+\]/o) {                  if ($format =~ /$LOOKUP_REGEX/o) {
417                            $log->debug("format '$format' has lookup");
418                          return $self->lookup($format);                          return $self->lookup($format);
419                  } else {                  } else {
420                          return $format;                          return $format;
# Line 319  sub fill_in { Line 428  sub fill_in {
428    
429  Perform lookups on format supplied to it.  Perform lookups on format supplied to it.
430    
431   my $txt = $self->lookup('[v900]');   my $text = $self->lookup('[v900]');
432    
433  Lookups can be nested (like C<[d:[a:[v900]]]>).  Lookups can be nested (like C<[d:[a:[v900]]]>).
434    
# Line 328  Lookups can be nested (like C<[d:[a:[v90 Line 437  Lookups can be nested (like C<[d:[a:[v90
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            my $tmp = shift || $log->logconfess("need format");
443    
444          if ($tmp =~ /\[[^\[\]]+\]/o) {          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;
# Line 365  Perform smart parsing of string, skippin Line 476  Perform smart parsing of string, skippin
476  defined. It can also eval code in format starting with C<eval{...}> and  defined. It can also eval code in format starting with C<eval{...}> and
477  return output or nothing depending on eval code.  return output or nothing depending on eval code.
478    
479   $webpac->parse($rec,'eval{"v901^a" eq "Deskriptor"}descriptor: v250^a', $i);   my $text = $webpac->parse($rec,'eval{"v901^a" eq "Deskriptor"}descriptor: v250^a', $i);
480    
481  =cut  =cut
482    
483  sub parse {  sub parse {
484          my $self = shift;          my $self = shift;
485    
486          my ($rec, $format, $i) = @_;          my ($rec, $format_utf8, $i) = @_;
487    
488            return if (! $format_utf8);
489    
490          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          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);          $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;          my @out;
500    
501            $log->debug("format: $format");
502    
503          my $eval_code;          my $eval_code;
504          # remove eval{...} from beginning          # remove eval{...} from beginning
505          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
# Line 387  sub parse { Line 507  sub parse {
507          my $prefix;          my $prefix;
508          my $all_found=0;          my $all_found=0;
509    
510  #print "## $format\n";          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))?//s) {
         while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))*//s) {  
 #print "## [ $1 | $2 | $3 ] $format\n";  
511    
512                  my $del = $1 || '';                  my $del = $1 || '';
513                  $prefix ||= $del if ($all_found == 0);                  $prefix ||= $del if ($all_found == 0);
# Line 406  sub parse { Line 524  sub parse {
524    
525          return if (! $all_found);          return if (! $all_found);
526    
527          my $out = join('',@out) . $format;          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    
         # add prefix if not there  
         $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);  
           
539          if ($eval_code) {          if ($eval_code) {
540                  my $eval = $self->fill_in($rec,$eval_code,$i);                  my $eval = $self->fill_in($rec,$eval_code,$i);
541                  return if (! eval $eval);                  $log->debug("about to eval{",$eval,"} format: $out");
542                    return if (! $self->_eval($eval));
543          }          }
544    
545          return $out;          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.362  
changed lines
  Added in v.376
  ViewVC Help
Powered by ViewVC 1.1.26