/[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 366 by dpavlin, Thu Jun 17 01:44:25 2004 UTC revision 371 by dpavlin, Thu Jun 17 20:44:45 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;  use XML::Simple;
10    use Template;
11    
12  use Data::Dumper;  use Data::Dumper;
13    
# Line 57  sub new { Line 61  sub new {
61          # read global.conf          # read global.conf
62          #          #
63    
64          $self->{global_config_file} = new Config::IniFiles( -file => 'global.conf' ) || croak "can't open 'global.conf'";          my $config = new Config::IniFiles( -file => 'global.conf' ) || croak "can't open 'global.conf'";
65    
66          # read global config parametars          # read global config parametars
67          foreach my $var (qw(          foreach my $var (qw(
# Line 67  sub new { Line 71  sub new {
71                          dbi_passwd                          dbi_passwd
72                          show_progress                          show_progress
73                          my_unac_filter                          my_unac_filter
74                            output_template
75                  )) {                  )) {
76                  $self->{global_config}->{$var} = $self->{global_config_file}->val('global', $var);                  $self->{'global_config'}->{$var} = $config->val('global', $var);
77          }          }
78    
79          #          #
# Line 77  sub new { Line 82  sub new {
82    
83          $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} ) || croak "can't open '$self->{config_file}'";
84    
85            # create UTF-8 convertor for import_xml files
86          $self->{'utf2cp'} = Text::Iconv->new('UTF-8' ,$self->{'code_page'});          $self->{'utf2cp'} = Text::Iconv->new('UTF-8' ,$self->{'code_page'});
87    
88            # create Template toolkit instance
89            $self->{'tt'} = Template->new(
90                    INCLUDE_PATH => ($self->{'global_config_file'}->{'output_template'} || './output_template'),
91    #               FILTERS => {
92    #                       'foo' => \&foo_filter,
93    #               },
94                    EVAL_PERL => 1,
95            );
96    
97          return $self;          return $self;
98  }  }
99    
# Line 97  By default, ISIS code page is assumed to Line 113  By default, ISIS code page is assumed to
113  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
114  from database in example above.  from database in example above.
115    
 Returns number of last record read into memory (size of database, really).  
   
116  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
117  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
118  value in index.  value in index.
# Line 110  value in index. Line 124  value in index.
124      'val' => 'v900' },      'val' => 'v900' },
125   ]   ]
126    
127    Returns number of last record read into memory (size of database, really).
128    
129  =cut  =cut
130    
131  sub open_isis {  sub open_isis {
# Line 217  sub open_import_xml { Line 233  sub open_import_xml {
233    
234          $self->{'tag'} = $type2tag{$type_base};          $self->{'tag'} = $type2tag{$type_base};
235    
236          print STDERR "using type ",$self->{'type'}," tag ",$self->{'tag'},"\n" if ($self->{'debug'});          print STDERR "using type '",$self->{'type'},"' tag <",$self->{'tag'},">\n" if ($self->{'debug'});
237    
238          my $f = "./import_xml/".$self->{'type'}.".xml";          my $f = "./import_xml/".$self->{'type'}.".xml";
239          confess "import_xml file '$f' doesn't exist!" if (! -e "$f");          confess "import_xml file '$f' doesn't exist!" if (! -e "$f");
# Line 229  sub open_import_xml { Line 245  sub open_import_xml {
245                  ForceContent => 1                  ForceContent => 1
246          );          );
247    
         print Dumper($self->{'import_xml'});  
   
248  }  }
249    
250  =head2 create_lookup  =head2 create_lookup
251    
252  Create lookup from record using lookup definition.  Create lookup from record using lookup definition.
253    
254     $self->create_lookup($rec, @lookups);
255    
256    Called internally by C<open_*> methods.
257    
258  =cut  =cut
259    
260  sub create_lookup {  sub create_lookup {
# Line 267  sub create_lookup { Line 285  sub create_lookup {
285    
286  Returns value from record.  Returns value from record.
287    
288   $self->get_data(\$rec,$f,$sf,$i,\$found);   my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);
289    
290  Arguments are:  Arguments are:
291  record reference C<$rec>,  record reference C<$rec>,
# Line 275  field C<$f>, Line 293  field C<$f>,
293  optional subfiled C<$sf>,  optional subfiled C<$sf>,
294  index for repeatable values C<$i>.  index for repeatable values C<$i>.
295    
296  Optinal variable C<$found> will be incremeted if thre  Optinal variable C<$found> will be incremeted if there
297  is field.  is field.
298    
299  Returns value or empty string.  Returns value or empty string.
# Line 286  sub get_data { Line 304  sub get_data {
304          my $self = shift;          my $self = shift;
305    
306          my ($rec,$f,$sf,$i,$found) = @_;          my ($rec,$f,$sf,$i,$found) = @_;
307    
308          if ($$rec->{$f}) {          if ($$rec->{$f}) {
309                    return '' if (! $$rec->{$f}->[$i]);
310                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {
311                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
312                          return $$rec->{$f}->[$i]->{$sf};                          return $$rec->{$f}->[$i]->{$sf};
# Line 315  Workhourse of all: takes record from in- Line 335  Workhourse of all: takes record from in-
335  strings with placeholders and returns string or array of with substituted  strings with placeholders and returns string or array of with substituted
336  values from record.  values from record.
337    
338   $webpac->fill_in($rec,'v250^a');   my $text = $webpac->fill_in($rec,'v250^a');
339    
340  Optional argument is ordinal number for repeatable fields. By default,  Optional argument is ordinal number for repeatable fields. By default,
341  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
342  element is 0).  element is 0).
343  Following example will read second value from repeatable field.  Following example will read second value from repeatable field.
344    
345   $webpac->fill_in($rec,'Title: v250^a',1);   my $text = $webpac->fill_in($rec,'Title: v250^a',1);
346    
347  This function B<does not> perform parsing of format to inteligenty skip  This function B<does not> perform parsing of format to inteligenty skip
348  delimiters before fields which aren't used.  delimiters before fields which aren't used.
349    
350  =cut  =cut
351    
352    # internal function to eval code
353    sub _eval {
354            my $self = shift;
355    
356            my $code = shift || return;
357            no strict 'subs';
358            my $ret = eval $code;
359            if ($@) {
360                    print STDERR "problem with eval code [$code]: $@\n";
361            }
362            return $ret;
363    }
364    
365  sub fill_in {  sub fill_in {
366          my $self = shift;          my $self = shift;
367    
# Line 352  sub fill_in { Line 385  sub fill_in {
385          if ($found) {          if ($found) {
386                  if ($eval_code) {                  if ($eval_code) {
387                          my $eval = $self->fill_in($rec,$eval_code,$i);                          my $eval = $self->fill_in($rec,$eval_code,$i);
388                          return if (! eval $eval);                          return if (! $self->_eval($eval));
389                  }                  }
390                  # do we have lookups?                  # do we have lookups?
391                  if ($format =~ /\[[^\[\]]+\]/o) {                  if ($format =~ /\[[^\[\]]+\]/o) {
392    print "## probable lookup: $format\n";
393                          return $self->lookup($format);                          return $self->lookup($format);
394                  } else {                  } else {
395                          return $format;                          return $format;
# Line 369  sub fill_in { Line 403  sub fill_in {
403    
404  Perform lookups on format supplied to it.  Perform lookups on format supplied to it.
405    
406   my $txt = $self->lookup('[v900]');   my $text = $self->lookup('[v900]');
407    
408  Lookups can be nested (like C<[d:[a:[v900]]]>).  Lookups can be nested (like C<[d:[a:[v900]]]>).
409    
# Line 382  sub lookup { Line 416  sub lookup {
416    
417          if ($tmp =~ /\[[^\[\]]+\]/o) {          if ($tmp =~ /\[[^\[\]]+\]/o) {
418                  my @in = ( $tmp );                  my @in = ( $tmp );
419  #print "##lookup $tmp\n";  print "## lookup $tmp\n";
420                  my @out;                  my @out;
421                  while (my $f = shift @in) {                  while (my $f = shift @in) {
422                          if ($f =~ /\[([^\[\]]+)\]/) {                          if ($f =~ /\[([^\[\]]+)\]/) {
423                                  my $k = $1;                                  my $k = $1;
424                                  if ($self->{'lookup'}->{$k}) {                                  if ($self->{'lookup'}->{$k}) {
 #print "## lookup key = $k\n";  
425                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {
426                                                  my $tmp2 = $f;                                                  my $tmp2 = $f;
427                                                  $tmp2 =~ s/\[$k\]/$nv/g;                                                  $tmp2 =~ s/\[$k\]/$nv/g;
428                                                  push @in, $tmp2;                                                  push @in, $tmp2;
 #print "## lookup in => $tmp2\n";  
429                                          }                                          }
430                                  } else {                                  } else {
431                                          undef $f;                                          undef $f;
432                                  }                                  }
433                          } elsif ($f) {                          } elsif ($f) {
434                                  push @out, $f;                                  push @out, $f;
 #print "## lookup out => $f\n";  
435                          }                          }
436                  }                  }
437                  return @out;                  return @out;
# Line 415  Perform smart parsing of string, skippin Line 446  Perform smart parsing of string, skippin
446  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
447  return output or nothing depending on eval code.  return output or nothing depending on eval code.
448    
449   $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);
450    
451  =cut  =cut
452    
# Line 442  sub parse { Line 473  sub parse {
473          my $prefix;          my $prefix;
474          my $all_found=0;          my $all_found=0;
475    
 #print "## $format\n";  
476          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))*//s) {          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))*//s) {
 #print "## [ $1 | $2 | $3 ] $format\n";  
477    
478                  my $del = $1 || '';                  my $del = $1 || '';
479                  $prefix ||= $del if ($all_found == 0);                  $prefix ||= $del if ($all_found == 0);
# Line 465  sub parse { Line 494  sub parse {
494    
495          # add prefix if not there          # add prefix if not there
496          $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);          $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);
497            
498          if ($eval_code) {          if ($eval_code) {
499                  my $eval = $self->fill_in($rec,$eval_code,$i);                  my $eval = $self->fill_in($rec,$eval_code,$i);
500                  return if (! eval $eval);                  return if (! $self->_eval($eval));
501          }          }
502    
503          return $out;          return $out;
504  }  }
505    
506    =head2 parse_to_arr
507    
508    Similar to C<parse>, but returns array of all repeatable fields
509    
510     my @arr = $webpac->parse_to_arr($rec,'v250^a');
511    
512    =cut
513    
514    sub parse_to_arr {
515            my $self = shift;
516    
517            my ($rec, $format_utf8) = @_;
518    
519            confess("need HASH as first argument!") if ($rec !~ /HASH/o);
520            return if (! $format_utf8);
521    
522            my $i = 0;
523            my @arr;
524    
525            while (my $v = $self->parse($rec,$format_utf8,$i++)) {
526                    push @arr, $v;
527            }
528    
529            return @arr;
530    }
531    
532  =head2 data_structure  =head2 data_structure
533    
534  Create in-memory data structure which represents layout from C<import_xml>.  Create in-memory data structure which represents layout from C<import_xml>.
535  It is used later to produce output.  It is used later to produce output.
536    
537   my $ds = $webpac->data_structure($rec);   my @ds = $webpac->data_structure($rec);
538    
539  =cut  =cut
540    
# Line 510  sub data_structure { Line 565  sub data_structure {
565                  $self->{tags_by_order} = \@sorted_tags;                  $self->{tags_by_order} = \@sorted_tags;
566          }          }
567    
568          my $ds;          my @ds;
569    
570          foreach my $field (@sorted_tags) {          foreach my $field (@sorted_tags) {
571    
572                  my $row;                  my $row;
                 my $i = 0;  
573    
574  #print "field $field [",$self->{'tag'},"] = ",Dumper($self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}});  #print "field $field [",$self->{'tag'},"] = ",Dumper($self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}});
575    
576                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
577                            my @v = $self->parse_to_arr($rec,$tag->{'content'});
578    
579                          my $v = $self->parse($rec,$tag->{'content'},$i);                          next if (! @v);
 print "## $i:",$tag->{'content'}," = ",($v || 'null'),"\n";  
   
                         next if (!$v || $v && $v eq '');  
580    
581                          # does tag have type?                          # does tag have type?
582                          if ($tag->{'type'}) {                          if ($tag->{'type'}) {
583                                  push @{$row->{$tag->{'type'}}}, $v;                                  push @{$row->{$tag->{'type'}}}, @v;
584                          } else {                          } else {
585                                  push @{$row->{'display'}}, $v;                                  push @{$row->{'display'}}, @v;
586                                  push @{$row->{'swish'}}, $v;                                  push @{$row->{'swish'}}, @v;
587                          }                          }
588                  }                  }
589    
590                  push @{$ds->{$field}}, $row if ($row);                  if ($row) {
591                            $row->{'tag'} = $field;
592                            push @ds, $row;
593                    }
594    
595          }          }
596    
597          print Dumper($ds);          return @ds;
598    
599    }
600    
601    =head2 output
602    
603    Create output from in-memory data structure using Template Toolkit template.
604    
605    my $text = $webpac->output( template => 'text.tt', data => @ds );
606    
607    =cut
608    
609    sub output {
610            my $self = shift;
611    
612            my $args = {@_};
613    
614            confess("need template name") if (! $args->{'template'});
615            confess("need data array") if (! $args->{'data'});
616    
617            my $out;
618    
619            $self->{'tt'}->process(
620                    $args->{'template'},
621                    $args,
622                    \$out
623            ) || confess $self->{'tt'}->error();
624    
625            return $out;
626  }  }
627    
628  1;  1;
Legend:
Removed from v.366  
changed lines
  Added in v.371
  ViewVC Help
Powered by ViewVC 1.1.26