/[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 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;
8    use Config::IniFiles;
9    use XML::Simple;
10    
11    use Data::Dumper;
12    
13  =head1 NAME  =head1 NAME
14    
15  WebPac - base class for WebPac  WebPAC - base class for WebPAC
16    
17  =head1 DESCRIPTION  =head1 DESCRIPTION
18    
19  This class does basic thing for WebPac.  This module implements methods used by WebPAC.
20    
21  =head1 METHODS  =head1 METHODS
22    
23  =head2 new  =head2 new
24    
25  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>.
26    
27   my $webpac = new WebPac(   my $webpac = new WebPAC(
28          config_file => 'name.conf',          config_file => 'name.conf',
29          [code_page => 'ISO-8859-2',]          [code_page => 'ISO-8859-2',]
30   );   );
31    
32  Default C<code_page> is C<ISO-8859-2>.  Default C<code_page> is C<ISO-8859-2>.
33    
34    It will also read configuration files
35    C<global.conf> (used by indexer and Web font-end)
36    and configuration file specified by C<config_file>
37    which describes databases to be indexed.
38    
39  =cut  =cut
40    
41    # mapping between data type and tag which specify
42    # format in XML file
43    my %type2tag = (
44            'isis' => 'isis',
45    #       'excel' => 'column',
46    #       'marc' => 'marc',
47    #       'feed' => 'feed'
48    );
49    
50  sub new {  sub new {
51          my $class = shift;          my $class = shift;
52          my $self = {@_};          my $self = {@_};
# Line 34  sub new { Line 56  sub new {
56          # output codepage          # output codepage
57          $self->{'code_page'} = 'ISO-8859-2' if (! $self->{'code_page'});          $self->{'code_page'} = 'ISO-8859-2' if (! $self->{'code_page'});
58    
59          return $self;          #
60  }          # read global.conf
61            #
 =head2 read_global_config  
   
 Read global configuration (used by indexer and Web font-end)  
   
 =cut  
   
 sub read_global_config {  
         my $self = shift;  
62    
63          $self->{global_config_file} = new Config::IniFiles( -file => 'global.conf' ) || croak "can't open 'global.conf'";          $self->{global_config_file} = new Config::IniFiles( -file => 'global.conf' ) || croak "can't open 'global.conf'";
64    
# Line 60  sub read_global_config { Line 74  sub read_global_config {
74                  $self->{global_config}->{$var} = $self->{global_config_file}->val('global', $var);                  $self->{global_config}->{$var} = $self->{global_config_file}->val('global', $var);
75          }          }
76    
77          return $self;          #
78  }          # read indexer config file
79            #
 =head2 read_indexer_config  
   
 Read indexer configuration (specify databases, types etc.)  
   
 =cut  
   
 sub read_indexer_config {  
         my $self = shift;  
80    
81          $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}'";
82    
83          # read global config parametars          $self->{'utf2cp'} = Text::Iconv->new('UTF-8' ,$self->{'code_page'});
         foreach my $var (qw(  
                         dbi_dbd  
                         dbi_dsn  
                         dbi_user  
                         dbi_passwd  
                         show_progress  
                         my_unac_filter  
                 )) {  
                 $self->{global_config}->{$var} = $self->{global_config_file}->val('global', $var);  
         }  
   
84          return $self;          return $self;
85  }  }
86    
# Line 102  Open CDS/ISIS database using OpenIsis mo Line 97  Open CDS/ISIS database using OpenIsis mo
97    
98  By default, ISIS code page is assumed to be C<852>.  By default, ISIS code page is assumed to be C<852>.
99    
100  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
101  database in example above.  from database in example above.
   
 Returns number of last record read into memory (size of database, really).  
102    
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
# Line 118  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 127  sub open_isis { Line 122  sub open_isis {
122          croak "need filename" if (! $arg->{'filename'});          croak "need filename" if (! $arg->{'filename'});
123          my $code_page = $arg->{'code_page'} || '852';          my $code_page = $arg->{'code_page'} || '852';
124    
125            use OpenIsis;
126    
127          #$self->{'isis_code_page'} = $code_page;          #$self->{'isis_code_page'} = $code_page;
128    
129          # create Text::Iconv object          # create Text::Iconv object
130          my $cp = Text::Iconv->new($code_page,$self->{'code_page'});          my $cp = Text::Iconv->new($code_page,$self->{'code_page'});
131    
132            print STDERR "reading ISIS database '",$arg->{'filename'},"'\n" if ($self->{'debug'});
133    
134          my $isis_db = OpenIsis::open($arg->{'filename'});          my $isis_db = OpenIsis::open($arg->{'filename'});
135    
136          my $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;          my $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;
137    
138            $maxmfn = $self->{limit_mfn} if ($self->{limit_mfn});
139    
140            print STDERR "processing $maxmfn records...\n" if ($self->{'debug'});
141    
142          # read database          # read database
143          for (my $mfn = 1; $mfn <= $maxmfn; $mfn++) {          for (my $mfn = 1; $mfn <= $maxmfn; $mfn++) {
144    
# Line 163  sub open_isis { Line 166  sub open_isis {
166                  }                  }
167    
168                  # create lookup                  # create lookup
169                    my $rec = $self->{'data'}->{$mfn};
170                    $self->create_lookup($rec, @{$arg->{'lookup'}});
171    
172            }
173    
174            $self->{'current_mfn'} = 1;
175    
176            # store max mfn and return it.
177            return $self->{'max_mfn'} = $maxmfn;
178    }
179    
180    =head2 fetch_rec
181    
182    Fetch next record from database. It will also display progress bar (once
183    it's implemented, that is).
184    
185     my $rec = $webpac->fetch_rec;
186    
187    =cut
188    
189    sub fetch_rec {
190            my $self = shift;
191    
192            my $mfn = $self->{'current_mfn'}++ || confess "it seems that you didn't load database!";
193    
194            if ($mfn > $self->{'max_mfn'}) {
195                    $self->{'current_mfn'} = $self->{'max_mfn'};
196                    return;
197            }
198    
199            return $self->{'data'}->{$mfn};
200    }
201    
202    =head2 open_import_xml
203    
204    Read file from C<import_xml/> directory and parse it.
205    
206     $webpac->open_import_xml(type => 'isis');
207    
208    =cut
209    
210    sub open_import_xml {
211            my $self = shift;
212    
213            my $arg = {@_};
214            confess "need type to load file from import_xml/" if (! $arg->{'type'});
215    
216            $self->{'type'} = $arg->{'type'};
217    
218            my $type_base = $arg->{'type'};
219            $type_base =~ s/_.*$//g;
220    
221            $self->{'tag'} = $type2tag{$type_base};
222    
223            print STDERR "using type ",$self->{'type'}," tag ",$self->{'tag'},"\n" if ($self->{'debug'});
224    
225            my $f = "./import_xml/".$self->{'type'}.".xml";
226            confess "import_xml file '$f' doesn't exist!" if (! -e "$f");
227    
228            print STDERR "reading '$f'\n" if ($self->{'debug'});
229    
230            $self->{'import_xml'} = XMLin($f,
231                    ForceArray => [ $self->{'tag'}, 'config', 'format' ],
232                    ForceContent => 1
233            );
234    
235            print Dumper($self->{'import_xml'});
236    
237    }
238    
239    =head2 create_lookup
240    
241    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
248    
249    sub create_lookup {
250            my $self = shift;
251    
252            my $rec = shift || confess "need record to create lookup";
253            confess("need HASH as first argument!") if ($rec !~ /HASH/o);
254    
255            foreach my $i (@_) {
256                    if ($i->{'eval'}) {
257                            my $eval = $self->fill_in($rec,$i->{'eval'});
258                            my $key = $self->fill_in($rec,$i->{'key'});
259                            my @val = $self->fill_in($rec,$i->{'val'});
260                            if ($key && @val && eval $eval) {
261                                    push @{$self->{'lookup'}->{$key}}, @val;
262                            }
263                    } else {
264                            my $key = $self->fill_in($rec,$i->{'key'});
265                            my @val = $self->fill_in($rec,$i->{'val'});
266                            if ($key && @val) {
267                                    push @{$self->{'lookup'}->{$key}}, @val;
268                            }
269                    }
270            }
271    }
272    
273    =head2 get_data
274    
275    Returns value from record.
276    
277     my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);
278    
279    Arguments are:
280    record reference C<$rec>,
281    field C<$f>,
282    optional subfiled C<$sf>,
283    index for repeatable values C<$i>.
284    
285    Optinal variable C<$found> will be incremeted if there
286    is field.
287    
288    Returns value or empty string.
289    
290                  foreach my $i (@{$arg->{lookup}}) {  =cut
291                          my $rec = $self->{'data'}->{$mfn};  
292                          if ($i->{'eval'}) {  sub get_data {
293                                  my $eval = $self->fill_in($rec,$i->{'eval'});          my $self = shift;
294                                  my $key = $self->fill_in($rec,$i->{'key'});  
295                                  my @val = $self->fill_in($rec,$i->{'val'});          my ($rec,$f,$sf,$i,$found) = @_;
296                                  if ($key && @val && eval $eval) {  
297                                          push @{$self->{'lookup'}->{$key}}, @val;          if ($$rec->{$f}) {
298                    return '' if (! $$rec->{$f}->[$i]);
299                    if ($sf && $$rec->{$f}->[$i]->{$sf}) {
300                            $$found++ if (defined($$found));
301                            return $$rec->{$f}->[$i]->{$sf};
302                    } elsif ($$rec->{$f}->[$i]) {
303                            $$found++ if (defined($$found));
304                            # it still might have subfield, just
305                            # not specified, so we'll dump all
306                            if ($$rec->{$f}->[$i] =~ /HASH/o) {
307                                    my $out;
308                                    foreach my $k (keys %{$$rec->{$f}->[$i]}) {
309                                            $out .= $$rec->{$f}->[$i]->{$k}." ";
310                                  }                                  }
311                                    return $out;
312                          } else {                          } else {
313                                  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;  
                                 }  
314                          }                          }
315                  }                  }
316            } else {
317                    return '';
318          }          }
   
         # store max mfn and return it.  
         return $self->{'max_mfn'} = $maxmfn;  
319  }  }
320    
321  =head2 fill_in  =head2 fill_in
# Line 193  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.  it's assume to be first repeatable field (fields are perl array, so first
331    element is 0).
332    Following example will read second value from repeatable field.
333    
334     my $text = $webpac->fill_in($rec,'Title: v250^a',1);
335    
336    This function B<does not> perform parsing of format to inteligenty skip
337    delimiters before fields which aren't used.
338    
339  =cut  =cut
340    
# Line 209  sub fill_in { Line 347  sub fill_in {
347          my $i = shift || 0;          my $i = shift || 0;
348    
349          # FIXME remove for speedup?          # FIXME remove for speedup?
350          if ($rec !~ /HASH/) {          confess("need HASH as first argument!") if ($rec !~ /HASH/o);
                 confess("need HASH as first argument!");  
         }  
351    
352          my $found = 0;          my $found = 0;
353    
354          # get field with subfield          my $eval_code;
355          sub get_sf {          # remove eval{...} from beginning
356                  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 '';  
                 }  
         }  
357    
358          # do actual replacement of placeholders          # do actual replacement of placeholders
359          $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;  
360    
361          if ($found) {            if ($found) {
362                  return $format;                  if ($eval_code) {
363                            my $eval = $self->fill_in($rec,$eval_code,$i);
364                            return if (! eval $eval);
365                    }
366                    # do we have lookups?
367                    if ($format =~ /\[[^\[\]]+\]/o) {
368                            return $self->lookup($format);
369                    } else {
370                            return $format;
371                    }
372          } else {          } else {
373                  return;                  return;
374          }          }
# Line 250  sub fill_in { Line 376  sub fill_in {
376    
377  =head2 lookup  =head2 lookup
378    
379  This function will 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]]]>).
384    
385  =cut  =cut
386    
# Line 261  sub lookup { Line 389  sub lookup {
389    
390          my $tmp = shift || confess "need format";          my $tmp = shift || confess "need format";
391    
392          if ($tmp =~ /\[[^\[\]]+\]/) {          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 290  print "## lookup out => $f\n"; Line 414  print "## lookup out => $f\n";
414          }          }
415  }  }
416    
417    =head2 parse
418    
419    Perform smart parsing of string, skipping delimiters for fields which aren't
420    defined. It can also eval code in format starting with C<eval{...}> and
421    return output or nothing depending on eval code.
422    
423     my $text = $webpac->parse($rec,'eval{"v901^a" eq "Deskriptor"}descriptor: v250^a', $i);
424    
425    =cut
426    
427    sub parse {
428            my $self = shift;
429    
430            my ($rec, $format_utf8, $i) = @_;
431    
432            return if (! $format_utf8);
433    
434            confess("need HASH as first argument!") if ($rec !~ /HASH/o);
435            confess("need utf2cp Text::Iconv object!") if (! $self->{'utf2cp'});
436    
437            $i = 0 if (! $i);
438    
439            my $format = $self->{'utf2cp'}->convert($format_utf8) || confess("can't convert '$format_utf8' from UTF-8 to ",$self->{'code_page'});
440    
441            my @out;
442    
443            my $eval_code;
444            # remove eval{...} from beginning
445            $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
446    
447            my $prefix;
448            my $all_found=0;
449    
450            while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))*//s) {
451    
452                    my $del = $1 || '';
453                    $prefix ||= $del if ($all_found == 0);
454    
455                    my $found = 0;
456                    my $tmp = $self->get_data(\$rec,$2,$3,$i,\$found);
457    
458                    if ($found) {
459                            push @out, $del;
460                            push @out, $tmp;
461                            $all_found += $found;
462                    }
463            }
464    
465            return if (! $all_found);
466    
467            my $out = join('',@out) . $format;
468    
469            # add prefix if not there
470            $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);
471    
472            if ($eval_code) {
473                    my $eval = $self->fill_in($rec,$eval_code,$i);
474                    return if (! eval $eval);
475            }
476    
477            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
507    
508    Create in-memory data structure which represents layout from C<import_xml>.
509    It is used later to produce output.
510    
511     my $ds = $webpac->data_structure($rec);
512    
513    =cut
514    
515    # private method _sort_by_order
516    # sort subrouting using order="" attribute
517    sub _sort_by_order {
518            my $self = shift;
519    
520            my $va = $self->{'import_xml'}->{'indexer'}->{$a}->{'order'} ||
521                    $self->{'import_xml'}->{'indexer'}->{$a};
522            my $vb = $self->{'import_xml'}->{'indexer'}->{$b}->{'order'} ||
523                    $self->{'import_xml'}->{'indexer'}->{$b};
524    
525            return $va <=> $vb;
526    }
527    
528    sub data_structure {
529            my $self = shift;
530    
531            my $rec = shift;
532            confess("need HASH as first argument!") if ($rec !~ /HASH/o);
533    
534            my @sorted_tags;
535            if ($self->{tags_by_order}) {
536                    @sorted_tags = @{$self->{tags_by_order}};
537            } else {
538                    @sorted_tags = sort { $self->_sort_by_order } keys %{$self->{'import_xml'}->{'indexer'}};
539                    $self->{tags_by_order} = \@sorted_tags;
540            }
541    
542            my $ds;
543    
544            foreach my $field (@sorted_tags) {
545    
546                    my $row;
547    
548    #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'}}}) {
551                            my @v = $self->parse_to_arr($rec,$tag->{'content'});
552    
553                            next if (! @v);
554    
555                            # does tag have type?
556                            if ($tag->{'type'}) {
557                                    push @{$row->{$tag->{'type'}}}, @v;
558                            } else {
559                                    push @{$row->{'display'}}, @v;
560                                    push @{$row->{'swish'}}, @v;
561                            }
562                    }
563    
564                    push @{$ds->{$field}}, $row if ($row);
565    
566            }
567    
568            print "data_structure => ",Dumper($ds);
569    
570    }
571    
572  1;  1;
Legend:
Removed from v.352  
changed lines
  Added in v.367
  ViewVC Help
Powered by ViewVC 1.1.26