/[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 367 by dpavlin, Thu Jun 17 12:05:01 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;
# Line 97  By default, ISIS code page is assumed to Line 100  By default, ISIS code page is assumed to
100  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
101  from database in example above.  from database in example above.
102    
 Returns number of last record read into memory (size of database, really).  
   
103  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
104  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
105  value in index.  value in index.
# Line 110  value in index. Line 111  value in index.
111      'val' => 'v900' },      'val' => 'v900' },
112   ]   ]
113    
114    Returns number of last record read into memory (size of database, really).
115    
116  =cut  =cut
117    
118  sub open_isis {  sub open_isis {
# Line 237  sub open_import_xml { Line 240  sub open_import_xml {
240    
241  Create lookup from record using lookup definition.  Create lookup from record using lookup definition.
242    
243     $self->create_lookup($rec, @lookups);
244    
245    Called internally by C<open_*> methods.
246    
247  =cut  =cut
248    
249  sub create_lookup {  sub create_lookup {
# Line 267  sub create_lookup { Line 274  sub create_lookup {
274    
275  Returns value from record.  Returns value from record.
276    
277   $self->get_data(\$rec,$f,$sf,$i,\$found);   my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);
278    
279  Arguments are:  Arguments are:
280  record reference C<$rec>,  record reference C<$rec>,
# Line 275  field C<$f>, Line 282  field C<$f>,
282  optional subfiled C<$sf>,  optional subfiled C<$sf>,
283  index for repeatable values C<$i>.  index for repeatable values C<$i>.
284    
285  Optinal variable C<$found> will be incremeted if thre  Optinal variable C<$found> will be incremeted if there
286  is field.  is field.
287    
288  Returns value or empty string.  Returns value or empty string.
# Line 286  sub get_data { Line 293  sub get_data {
293          my $self = shift;          my $self = shift;
294    
295          my ($rec,$f,$sf,$i,$found) = @_;          my ($rec,$f,$sf,$i,$found) = @_;
296    
297          if ($$rec->{$f}) {          if ($$rec->{$f}) {
298                    return '' if (! $$rec->{$f}->[$i]);
299                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {
300                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
301                          return $$rec->{$f}->[$i]->{$sf};                          return $$rec->{$f}->[$i]->{$sf};
# Line 315  Workhourse of all: takes record from in- Line 324  Workhourse of all: takes record from in-
324  strings with placeholders and returns string or array of with substituted  strings with placeholders and returns string or array of with substituted
325  values from record.  values from record.
326    
327   $webpac->fill_in($rec,'v250^a');   my $text = $webpac->fill_in($rec,'v250^a');
328    
329  Optional argument is ordinal number for repeatable fields. By default,  Optional argument is ordinal number for repeatable fields. By default,
330  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
331  element is 0).  element is 0).
332  Following example will read second value from repeatable field.  Following example will read second value from repeatable field.
333    
334   $webpac->fill_in($rec,'Title: v250^a',1);   my $text = $webpac->fill_in($rec,'Title: v250^a',1);
335    
336  This function B<does not> perform parsing of format to inteligenty skip  This function B<does not> perform parsing of format to inteligenty skip
337  delimiters before fields which aren't used.  delimiters before fields which aren't used.
# Line 369  sub fill_in { Line 378  sub fill_in {
378    
379  Perform lookups on format supplied to it.  Perform lookups on format supplied to it.
380    
381   my $txt = $self->lookup('[v900]');   my $text = $self->lookup('[v900]');
382    
383  Lookups can be nested (like C<[d:[a:[v900]]]>).  Lookups can be nested (like C<[d:[a:[v900]]]>).
384    
# Line 382  sub lookup { Line 391  sub lookup {
391    
392          if ($tmp =~ /\[[^\[\]]+\]/o) {          if ($tmp =~ /\[[^\[\]]+\]/o) {
393                  my @in = ( $tmp );                  my @in = ( $tmp );
 #print "##lookup $tmp\n";  
394                  my @out;                  my @out;
395                  while (my $f = shift @in) {                  while (my $f = shift @in) {
396                          if ($f =~ /\[([^\[\]]+)\]/) {                          if ($f =~ /\[([^\[\]]+)\]/) {
397                                  my $k = $1;                                  my $k = $1;
398                                  if ($self->{'lookup'}->{$k}) {                                  if ($self->{'lookup'}->{$k}) {
 #print "## lookup key = $k\n";  
399                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {
400                                                  my $tmp2 = $f;                                                  my $tmp2 = $f;
401                                                  $tmp2 =~ s/\[$k\]/$nv/g;                                                  $tmp2 =~ s/\[$k\]/$nv/g;
402                                                  push @in, $tmp2;                                                  push @in, $tmp2;
 #print "## lookup in => $tmp2\n";  
403                                          }                                          }
404                                  } else {                                  } else {
405                                          undef $f;                                          undef $f;
406                                  }                                  }
407                          } elsif ($f) {                          } elsif ($f) {
408                                  push @out, $f;                                  push @out, $f;
 #print "## lookup out => $f\n";  
409                          }                          }
410                  }                  }
411                  return @out;                  return @out;
# Line 415  Perform smart parsing of string, skippin Line 420  Perform smart parsing of string, skippin
420  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
421  return output or nothing depending on eval code.  return output or nothing depending on eval code.
422    
423   $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);
424    
425  =cut  =cut
426    
# Line 442  sub parse { Line 447  sub parse {
447          my $prefix;          my $prefix;
448          my $all_found=0;          my $all_found=0;
449    
 #print "## $format\n";  
450          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))*//s) {          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))*//s) {
 #print "## [ $1 | $2 | $3 ] $format\n";  
451    
452                  my $del = $1 || '';                  my $del = $1 || '';
453                  $prefix ||= $del if ($all_found == 0);                  $prefix ||= $del if ($all_found == 0);
# Line 465  sub parse { Line 468  sub parse {
468    
469          # add prefix if not there          # add prefix if not there
470          $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);          $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);
471            
472          if ($eval_code) {          if ($eval_code) {
473                  my $eval = $self->fill_in($rec,$eval_code,$i);                  my $eval = $self->fill_in($rec,$eval_code,$i);
474                  return if (! eval $eval);                  return if (! eval $eval);
# Line 474  sub parse { Line 477  sub parse {
477          return $out;          return $out;
478  }  }
479    
480    =head2 parse_to_arr
481    
482    Similar to C<parse>, but returns array of all repeatable fields
483    
484     my @arr = $webpac->parse_to_arr($rec,'v250^a');
485    
486    =cut
487    
488    sub parse_to_arr {
489            my $self = shift;
490    
491            my ($rec, $format_utf8) = @_;
492    
493            confess("need HASH as first argument!") if ($rec !~ /HASH/o);
494            return if (! $format_utf8);
495    
496            my $i = 0;
497            my @arr;
498    
499            while (my $v = $self->parse($rec,$format_utf8,$i++)) {
500                    push @arr, $v;
501            }
502    
503            return @arr;
504    }
505    
506  =head2 data_structure  =head2 data_structure
507    
508  Create in-memory data structure which represents layout from C<import_xml>.  Create in-memory data structure which represents layout from C<import_xml>.
# Line 515  sub data_structure { Line 544  sub data_structure {
544          foreach my $field (@sorted_tags) {          foreach my $field (@sorted_tags) {
545    
546                  my $row;                  my $row;
                 my $i = 0;  
547    
548  #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'}});
549    
550                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
551                            my @v = $self->parse_to_arr($rec,$tag->{'content'});
552    
553                          my $v = $self->parse($rec,$tag->{'content'},$i);                          next if (! @v);
 print "## $i:",$tag->{'content'}," = ",($v || 'null'),"\n";  
   
                         next if (!$v || $v && $v eq '');  
554    
555                          # does tag have type?                          # does tag have type?
556                          if ($tag->{'type'}) {                          if ($tag->{'type'}) {
557                                  push @{$row->{$tag->{'type'}}}, $v;                                  push @{$row->{$tag->{'type'}}}, @v;
558                          } else {                          } else {
559                                  push @{$row->{'display'}}, $v;                                  push @{$row->{'display'}}, @v;
560                                  push @{$row->{'swish'}}, $v;                                  push @{$row->{'swish'}}, @v;
561                          }                          }
562                  }                  }
563    
# Line 539  print "## $i:",$tag->{'content'}," = ",( Line 565  print "## $i:",$tag->{'content'}," = ",(
565    
566          }          }
567    
568          print Dumper($ds);          print "data_structure => ",Dumper($ds);
569    
570  }  }
571    

Legend:
Removed from v.366  
changed lines
  Added in v.367

  ViewVC Help
Powered by ViewVC 1.1.26