/[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 353 by dpavlin, Wed Jun 16 11:29:37 2004 UTC revision 707 by dpavlin, Wed Jul 13 23:36:53 2005 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    use Time::HiRes qw(time);
13    
14    use Data::Dumper;
15    
16    my ($have_biblio_isis, $have_openisis) = (0,0);
17    
18    eval "use Biblio::Isis 0.13;";
19    unless ($@) {
20            $have_biblio_isis = 1
21    } else {
22            eval "use OpenIsis;";
23            $have_openisis = 1 unless ($@);
24    }
25    
26    #my $LOOKUP_REGEX = '\[[^\[\]]+\]';
27    #my $LOOKUP_REGEX_SAVE = '\[([^\[\]]+)\]';
28    my $LOOKUP_REGEX = 'lookup{[^\{\}]+}';
29    my $LOOKUP_REGEX_SAVE = 'lookup{([^\{\}]+)}';
30    
31  =head1 NAME  =head1 NAME
32    
33  WebPac - base class for WebPac  WebPAC - base class for WebPAC
34    
35  =head1 DESCRIPTION  =head1 DESCRIPTION
36    
37  This module implements methods used by WebPac.  This module implements methods used by WebPAC.
38    
39  =head1 METHODS  =head1 METHODS
40    
41  =head2 new  =head2 new
42    
43  This will create new instance of WebPac using configuration specified by C<config_file>.  Create new instance of WebPAC using configuration specified by C<config_file>.
44    
45   my $webpac = new WebPac(   my $webpac = new WebPAC(
46          config_file => 'name.conf',          config_file => 'name.conf',
47          [code_page => 'ISO-8859-2',]          code_page => 'ISO-8859-2',
48            low_mem => 1,
49            filter => {
50                    'lower' => sub { lc($_[0]) },
51            },
52   );   );
53    
54  Default C<code_page> is C<ISO-8859-2>.  Default C<code_page> is C<ISO-8859-2>.
55    
56  It will also read configuration files  Default is not to use C<low_mem> options (see L<MEMORY USAGE> below).
57    
58    There is optinal parametar C<filter> which specify different filters which
59    can be applied using C<filter{name}> notation.
60    Same filters can be used in Template Toolkit files.
61    
62    This method will also read configuration files
63  C<global.conf> (used by indexer and Web font-end)  C<global.conf> (used by indexer and Web font-end)
64  and configuration file specified by C<config_file>  and configuration file specified by C<config_file>
65  which describes databases to be indexed.  which describes databases to be indexed.
66    
67  =cut  =cut
68    
69    # mapping between data type and tag which specify
70    # format in XML file
71    my %type2tag = (
72            'isis' => 'isis',
73    #       'excel' => 'column',
74    #       'marc' => 'marc',
75    #       'feed' => 'feed'
76    );
77    
78  sub new {  sub new {
79          my $class = shift;          my $class = shift;
80          my $self = {@_};          my $self = {@_};
81          bless($self, $class);          bless($self, $class);
82    
83            $self->{'start_t'} = time();
84    
85            my $log_file = $self->{'log'} || "log.conf";
86            Log::Log4perl->init($log_file);
87    
88            my $log = $self->_get_logger();
89    
90          # fill in default values          # fill in default values
91          # output codepage          # output codepage
92          $self->{'code_page'} = 'ISO-8859-2' if (! $self->{'code_page'});          $self->{'code_page'} = 'ISO-8859-2' if (! $self->{'code_page'});
# Line 44  sub new { Line 94  sub new {
94          #          #
95          # read global.conf          # read global.conf
96          #          #
97            $log->debug("read 'global.conf'");
98    
99          $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'");
100    
101          # read global config parametars          # read global config parametars
102          foreach my $var (qw(          foreach my $var (qw(
# Line 55  sub new { Line 106  sub new {
106                          dbi_passwd                          dbi_passwd
107                          show_progress                          show_progress
108                          my_unac_filter                          my_unac_filter
109                            output_template
110                  )) {                  )) {
111                  $self->{global_config}->{$var} = $self->{global_config_file}->val('global', $var);                  $self->{'global_config'}->{$var} = $config->val('global', $var);
112          }          }
113    
114          #          #
115          # read indexer config file          # read indexer config file
116          #          #
117    
118          $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},"'");
119    
120          # read global config parametars          # create UTF-8 convertor for import_xml files
121          foreach my $var (qw(          $self->{'utf2cp'} = Text::Iconv->new('UTF-8' ,$self->{'code_page'});
122                          dbi_dbd  
123                          dbi_dsn          # create Template toolkit instance
124                          dbi_user          $self->{'tt'} = Template->new(
125                          dbi_passwd                  INCLUDE_PATH => ($self->{'global_config_file'}->{'output_template'} || './output_template'),
126                          show_progress                  FILTERS => $self->{'filter'},
127                          my_unac_filter                  EVAL_PERL => 1,
128                  )) {          );
129                  $self->{global_config}->{$var} = $self->{global_config_file}->val('global', $var);  
130            # running with low_mem flag? well, use DBM::Deep then.
131            if ($self->{'low_mem'}) {
132                    $log->info("running with low_mem which impacts performance (<32 Mb memory usage)");
133    
134                    my $db_file = "data.db";
135    
136                    if (-e $db_file) {
137                            unlink $db_file or $log->logdie("can't remove '$db_file' from last run");
138                            $log->debug("removed '$db_file' from last run");
139                    }
140    
141                    require DBM::Deep;
142    
143                    my $db = new DBM::Deep $db_file;
144    
145                    $log->logdie("DBM::Deep error: $!") unless ($db);
146    
147                    if ($db->error()) {
148                            $log->logdie("can't open '$db_file' under low_mem: ",$db->error());
149                    } else {
150                            $log->debug("using file '$db_file' for DBM::Deep");
151                    }
152    
153                    $self->{'db'} = $db;
154          }          }
155    
156            $log->debug("filters defined: ",Dumper($self->{'filter'}));
157    
158          return $self;          return $self;
159  }  }
160    
161  =head2 open_isis  =head2 open_isis
162    
163  Open CDS/ISIS database using OpenIsis module and read all records to memory.  Open CDS/ISIS, WinISIS or IsisMarc database using IsisDB or OpenIsis module
164    and read all records to memory.
165    
166   $webpac->open_isis(   $webpac->open_isis(
167          filename => '/data/ISIS/ISIS',          filename => '/data/ISIS/ISIS',
168          code_page => '852',          code_page => '852',
169          limit_mfn => '500',          limit_mfn => 500,
170            start_mfn => 6000,
171          lookup => [ ... ],          lookup => [ ... ],
172   );   );
173    
174  By default, ISIS code page is assumed to be C<852>.  By default, ISIS code page is assumed to be C<852>.
175    
176    If optional parametar C<start_mfn> is set, this will be first MFN to read
177    from database (so you can skip beginning of your database if you need to).
178    
179  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
180  from database in example above.  from database in example above.
181    
 Returns number of last record read into memory (size of database, really).  
   
182  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
183  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
184  value in index.  value in index.
# Line 109  value in index. Line 190  value in index.
190      'val' => 'v900' },      'val' => 'v900' },
191   ]   ]
192    
193    Returns number of last record read into memory (size of database, really).
194    
195  =cut  =cut
196    
197  sub open_isis {  sub open_isis {
198          my $self = shift;          my $self = shift;
199          my $arg = {@_};          my $arg = {@_};
200    
201          croak "need filename" if (! $arg->{'filename'});          my $log = $self->_get_logger();
202    
203            $log->logcroak("need filename") if (! $arg->{'filename'});
204          my $code_page = $arg->{'code_page'} || '852';          my $code_page = $arg->{'code_page'} || '852';
205    
206          use OpenIsis;          $log->logdie("can't find database ",$arg->{'filename'}) unless (glob($arg->{'filename'}.'.*'));
207    
208            # store data in object
209            $self->{'isis_filename'} = $arg->{'filename'};
210            $self->{'isis_code_page'} = $code_page;
211    
212          #$self->{'isis_code_page'} = $code_page;          #$self->{'isis_code_page'} = $code_page;
213    
214          # create Text::Iconv object          # create Text::Iconv object
215          my $cp = Text::Iconv->new($code_page,$self->{'code_page'});          my $cp = Text::Iconv->new($code_page,$self->{'code_page'});
216    
217          my $isis_db = OpenIsis::open($arg->{'filename'});          $log->info("reading ISIS database '",$arg->{'filename'},"'");
218            $log->debug("isis code page: $code_page");
219    
220            my ($isis_db,$maxmfn);
221    
222            if ($have_openisis) {
223                    $log->debug("using OpenIsis perl bindings");
224                    $isis_db = OpenIsis::open($arg->{'filename'});
225                    $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;
226            } elsif ($have_biblio_isis) {
227                    $log->debug("using Biblio::Isis");
228                    use Biblio::Isis;
229                    $isis_db = new Biblio::Isis(
230                            isisdb => $arg->{'filename'},
231                            include_deleted => 1,
232                            hash_filter => sub {
233                                    my $l = shift || return;
234                                    $l = $cp->convert($l);
235                                    return $l;
236                            },
237                    );
238                    $maxmfn = $isis_db->count;
239    
240                    unless ($maxmfn) {
241                            $log->logwarn("no records in database ", $arg->{'filename'}, ", skipping...");
242                            return;
243                    }
244    
245            } else {
246                    $log->logdie("Can't find supported ISIS library for perl. I suggent that you install Bilbio::Isis from CPAN.");
247            }
248    
249    
250            my $startmfn = 1;
251    
252            if (my $s = $self->{'start_mfn'}) {
253                    $log->info("skipping to MFN $s");
254                    $startmfn = $s;
255            } else {
256                    $self->{'start_mfn'} = $startmfn;
257            }
258    
259            $maxmfn = $startmfn + $self->{limit_mfn} if ($self->{limit_mfn});
260    
261            $log->info("processing ",($maxmfn-$startmfn)." records using ",( $have_openisis ? 'OpenIsis' : 'Biblio::Isis'));
262    
         my $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;  
263    
264          # read database          # read database
265          for (my $mfn = 1; $mfn <= $maxmfn; $mfn++) {          for (my $mfn = $startmfn; $mfn <= $maxmfn; $mfn++) {
266    
267                  # read record  
268                  my $row = OpenIsis::read( $isis_db, $mfn );                  $log->debug("mfn: $mfn\n");
269                  foreach my $k (keys %{$row}) {  
270                          if ($k ne "mfn") {                  my $rec;
271                                  foreach my $l (@{$row->{$k}}) {  
272                                          $l = $cp->convert($l);                  if ($have_openisis) {
273                                          # has subfields?  
274                                          my $val;                          # read record using OpenIsis
275                                          if ($l =~ m/\^/) {                          my $row = OpenIsis::read( $isis_db, $mfn );
276                                                  foreach my $t (split(/\^/,$l)) {                          foreach my $k (keys %{$row}) {
277                                                          next if (! $t);                                  if ($k ne "mfn") {
278                                                          $val->{substr($t,0,1)} = substr($t,1);                                          foreach my $l (@{$row->{$k}}) {
279                                                    $l = $cp->convert($l);
280                                                    # has subfields?
281                                                    my $val;
282                                                    if ($l =~ m/\^/) {
283                                                            foreach my $t (split(/\^/,$l)) {
284                                                                    next if (! $t);
285                                                                    $val->{substr($t,0,1)} = substr($t,1);
286                                                            }
287                                                    } else {
288                                                            $val = $l;
289                                                  }                                                  }
                                         } else {  
                                                 $val = $l;  
                                         }  
290    
291                                          push @{$self->{'data'}->{$mfn}->{$k}}, $val;                                                  push @{$rec->{$k}}, $val;
292                                            }
293                                    } else {
294                                            push @{$rec->{'000'}}, $mfn;
295                                  }                                  }
296                          }                          }
297    
298                    } elsif ($have_biblio_isis) {
299                            $rec = $isis_db->to_hash($mfn);
300                    } else {
301                            $log->logdie("hum? implementation missing?");
302                    }
303    
304                    $log->confess("record $mfn empty?") unless ($rec);
305    
306                    # store
307                    if ($self->{'low_mem'}) {
308                            $self->{'db'}->put($mfn, $rec);
309                    } else {
310                            $self->{'data'}->{$mfn} = $rec;
311                  }                  }
312    
313                  # create lookup                  # create lookup
314                    $self->create_lookup($rec, @{$arg->{'lookup'}});
315    
316                    $self->progress_bar($mfn,$maxmfn);
317    
318            }
319    
320            $self->{'current_mfn'} = -1;
321            $self->{'last_pcnt'} = 0;
322    
323            $log->debug("max mfn: $maxmfn");
324    
325            # store max mfn and return it.
326            return $self->{'max_mfn'} = $maxmfn;
327    }
328    
329    =head2 fetch_rec
330    
331    Fetch next record from database. It will also display progress bar (once
332    it's implemented, that is).
333    
334     my $rec = $webpac->fetch_rec;
335    
336    =cut
337    
338    sub fetch_rec {
339            my $self = shift;
340    
341            my $log = $self->_get_logger();
342    
343            $log->logconfess("it seems that you didn't load database!") unless ($self->{'current_mfn'});
344    
345            if ($self->{'current_mfn'} == -1) {
346                    $self->{'current_mfn'} = $self->{'start_mfn'};
347            } else {
348                    $self->{'current_mfn'}++;
349            }
350    
351            my $mfn = $self->{'current_mfn'};
352    
353            if ($mfn > $self->{'max_mfn'}) {
354                    $self->{'current_mfn'} = $self->{'max_mfn'};
355                    $log->debug("at EOF");
356                    return;
357            }
358    
359            $self->progress_bar($mfn,$self->{'max_mfn'});
360    
361            if ($self->{'low_mem'}) {
362                    return $self->{'db'}->get($mfn);
363            } else {
364                    return $self->{'data'}->{$mfn};
365            }
366    }
367    
368    =head2 mfn
369    
370    Returns current record number (MFN).
371    
372     print $webpac->mfn;
373    
374    =cut
375    
376    sub mfn {
377            my $self = shift;
378            return $self->{'current_mfn'};
379    }
380    
381    =head2 progress_bar
382    
383    Draw progress bar on STDERR.
384    
385     $webpac->progress_bar($current, $max);
386    
387    =cut
388    
389    sub progress_bar {
390            my $self = shift;
391    
392            my ($curr,$max) = @_;
393    
394            my $log = $self->_get_logger();
395    
396            $log->logconfess("no current value!") if (! $curr);
397            $log->logconfess("no maximum value!") if (! $max);
398    
399                  foreach my $i (@{$arg->{lookup}}) {          if ($curr > $max) {
400                          my $rec = $self->{'data'}->{$mfn};                  $max = $curr;
401                          if ($i->{'eval'}) {                  $log->debug("overflow to $curr");
402                                  my $eval = $self->fill_in($rec,$i->{'eval'});          }
403                                  my $key = $self->fill_in($rec,$i->{'key'});  
404                                  my @val = $self->fill_in($rec,$i->{'val'});          $self->{'last_pcnt'} ||= 1;
405                                  if ($key && @val && eval $eval) {  
406                                          push @{$self->{'lookup'}->{$key}}, @val;          my $p = int($curr * 100 / $max) || 1;
407    
408            # reset on re-run
409            if ($p < $self->{'last_pcnt'}) {
410                    $self->{'last_pcnt'} = $p;
411                    $self->{'start_t'} = time();
412            }
413    
414            if ($p != $self->{'last_pcnt'}) {
415    
416                    my $t = time();
417                    my $rate = ($curr / ($t - $self->{'start_t'} || 1));
418                    my $eta = ($max-$curr) / ($rate || 1);
419                    printf STDERR ("%5d [%-38s] %-5d %0.1f/s %s\r",$curr,"=" x ($p/3)."$p%>", $max, $rate, $self->fmt_time($eta));
420                    $self->{'last_pcnt'} = $p;
421                    $self->{'last_curr'} = $curr;
422            }
423            print STDERR "\n" if ($p == 100);
424    }
425    
426    =head2 fmt_time
427    
428    Format time (in seconds) for display.
429    
430     print $webpac->fmt_time(time());
431    
432    This method is called by L<progress_bar> to display remaining time.
433    
434    =cut
435    
436    sub fmt_time {
437            my $self = shift;
438    
439            my $t = shift || 0;
440            my $out = "";
441    
442            my ($ss,$mm,$hh) = gmtime($t);
443            $out .= "${hh}h" if ($hh);
444            $out .= sprintf("%02d:%02d", $mm,$ss);
445            $out .= "  " if ($hh == 0);
446            return $out;
447    }
448    
449    =head2 open_import_xml
450    
451    Read file from C<import_xml/> directory and parse it.
452    
453     $webpac->open_import_xml(type => 'isis');
454    
455    =cut
456    
457    sub open_import_xml {
458            my $self = shift;
459    
460            my $log = $self->_get_logger();
461    
462            my $arg = {@_};
463            $log->logconfess("need type to load file from import_xml/") if (! $arg->{'type'});
464    
465            $self->{'type'} = $arg->{'type'};
466    
467            my $type_base = $arg->{'type'};
468            $type_base =~ s/_.*$//g;
469    
470            $self->{'tag'} = $type2tag{$type_base};
471    
472            $log->info("using type '",$self->{'type'},"' tag <",$self->{'tag'},">");
473    
474            my $f = "./import_xml/".$self->{'type'}.".xml";
475            $log->logconfess("import_xml file '$f' doesn't exist!") if (! -e "$f");
476    
477            $log->info("reading '$f'");
478    
479            $self->{'import_xml_file'} = $f;
480    
481            $self->{'import_xml'} = XMLin($f,
482                    ForceArray => [ $self->{'tag'}, 'config', 'format' ],
483            );
484    
485            $log->debug("import xml is ",sub { Dumper($self->{'import_xml'}) });
486    
487    }
488    
489    =head2 create_lookup
490    
491    Create lookup from record using lookup definition.
492    
493     $self->create_lookup($rec, @lookups);
494    
495    Called internally by C<open_*> methods.
496    
497    =cut
498    
499    sub create_lookup {
500            my $self = shift;
501    
502            my $log = $self->_get_logger();
503    
504            my $rec = shift || $log->logconfess("need record to create lookup");
505            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
506    
507            foreach my $i (@_) {
508                    $log->logconfess("need key") unless defined($i->{'key'});
509                    $log->logconfess("need val") unless defined($i->{'val'});
510    
511                    if (defined($i->{'eval'})) {
512                            # eval first, so we can skip fill_in for key and val
513                            my $eval = $self->fill_in($rec,$i->{'eval'}) || next;
514                            if ($self->_eval($eval)) {
515                                    my $key = $self->fill_in($rec,$i->{'key'}) || next;
516                                    my @val = $self->fill_in($rec,$i->{'val'}) || next;
517                                    $log->debug("stored $key = ",sub { join(" | ",@val) });
518                                    push @{$self->{'lookup'}->{$key}}, @val;
519                            }
520                    } else {
521                            my $key = $self->fill_in($rec,$i->{'key'}) || next;
522                            my @val = $self->fill_in($rec,$i->{'val'}) || next;
523                            $log->debug("stored $key = ",sub { join(" | ",@val) });
524                            push @{$self->{'lookup'}->{$key}}, @val;
525                    }
526            }
527    }
528    
529    =head2 get_data
530    
531    Returns value from record.
532    
533     my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);
534    
535    Arguments are:
536    record reference C<$rec>,
537    field C<$f>,
538    optional subfiled C<$sf>,
539    index for repeatable values C<$i>.
540    
541    Optinal variable C<$found> will be incremeted if there
542    is field.
543    
544    Returns value or empty string.
545    
546    =cut
547    
548    sub get_data {
549            my $self = shift;
550    
551            my ($rec,$f,$sf,$i,$found) = @_;
552    
553            if ($$rec->{$f}) {
554                    return '' if (! $$rec->{$f}->[$i]);
555                    no strict 'refs';
556                    if ($sf && $$rec->{$f}->[$i]->{$sf}) {
557                            $$found++ if (defined($$found));
558                            return $$rec->{$f}->[$i]->{$sf};
559                    } elsif ($$rec->{$f}->[$i]) {
560                            $$found++ if (defined($$found));
561                            # it still might have subfield, just
562                            # not specified, so we'll dump all
563                            if ($$rec->{$f}->[$i] =~ /HASH/o) {
564                                    my $out;
565                                    foreach my $k (keys %{$$rec->{$f}->[$i]}) {
566                                            $out .= $$rec->{$f}->[$i]->{$k}." ";
567                                  }                                  }
568                                    return $out;
569                          } else {                          } else {
570                                  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;  
                                 }  
571                          }                          }
572                  }                  }
573            } else {
574                    return '';
575          }          }
   
         # store max mfn and return it.  
         return $self->{'max_mfn'} = $maxmfn;  
576  }  }
577    
578  =head2 fill_in  =head2 fill_in
# Line 186  Workhourse of all: takes record from in- Line 581  Workhourse of all: takes record from in-
581  strings with placeholders and returns string or array of with substituted  strings with placeholders and returns string or array of with substituted
582  values from record.  values from record.
583    
584   $webpac->fill_in($rec,'v250^a');   my $text = $webpac->fill_in($rec,'v250^a');
585    
586  Optional argument is ordinal number for repeatable fields. By default,  Optional argument is ordinal number for repeatable fields. By default,
587  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
588  element is 0).  element is 0).
589  Following example will read second value from repeatable field.  Following example will read second value from repeatable field.
590    
591   $webpac->fill_in($rec,'Title: v250^a',1);   my $text = $webpac->fill_in($rec,'Title: v250^a',1);
592    
593  This function B<does not> perform parsing of format to inteligenty skip  This function B<does not> perform parsing of format to inteligenty skip
594  delimiters before fields which aren't used.  delimiters before fields which aren't used.
595    
596    This method will automatically decode UTF-8 string to local code page
597    if needed.
598    
599  =cut  =cut
600    
601  sub fill_in {  sub fill_in {
602          my $self = shift;          my $self = shift;
603    
604          my $rec = shift || confess "need data record";          my $log = $self->_get_logger();
605          my $format = shift || confess "need format to parse";  
606            my $rec = shift || $log->logconfess("need data record");
607            my $format = shift || $log->logconfess("need format to parse");
608          # iteration (for repeatable fields)          # iteration (for repeatable fields)
609          my $i = shift || 0;          my $i = shift || 0;
610    
611            $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));
612    
613          # FIXME remove for speedup?          # FIXME remove for speedup?
614          if ($rec !~ /HASH/o) {          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
615                  confess("need HASH as first argument!");  
616            if (utf8::is_utf8($format)) {
617                    $format = $self->_x($format);
618          }          }
619    
620          my $found = 0;          my $found = 0;
621    
622          # get field with subfield          my $eval_code;
623          sub get_sf {          # remove eval{...} from beginning
624                  my ($found,$rec,$f,$sf,$i) = @_;          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
625                  if ($$rec->{$f} && $$rec->{$f}->[$i]->{$sf}) {  
626                          $$found++;          my $filter_name;
627                          return $$rec->{$f}->[$i]->{$sf};          # remove filter{...} from beginning
628                  } else {          $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
                         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 '';  
                 }  
         }  
629    
630          # do actual replacement of placeholders          # do actual replacement of placeholders
631          $format =~ s/v(\d+)\^(\w)/get_sf(\$found,\$rec,$1,$2,$i)/ges;          # repeatable fields
632          $format =~ s/v(\d+)/get_nosf(\$found,\$rec,$1,$i)/ges;          $format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;
633            # non-repeatable fields
634            $format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found)/ges;
635    
636          if ($found) {          if ($found) {
637                    $log->debug("format: $format");
638                    if ($eval_code) {
639                            my $eval = $self->fill_in($rec,$eval_code,$i);
640                            return if (! $self->_eval($eval));
641                    }
642                    if ($filter_name && $self->{'filter'}->{$filter_name}) {
643                            $log->debug("filter '$filter_name' for $format");
644                            $format = $self->{'filter'}->{$filter_name}->($format);
645                            return unless(defined($format));
646                            $log->debug("filter result: $format");
647                    }
648                  # do we have lookups?                  # do we have lookups?
649                  if ($format =~ /\[[^\[\]]+\]/o) {                  if ($format =~ /$LOOKUP_REGEX/o) {
650                            $log->debug("format '$format' has lookup");
651                          return $self->lookup($format);                          return $self->lookup($format);
652                  } else {                  } else {
653                          return $format;                          return $format;
# Line 255  sub fill_in { Line 659  sub fill_in {
659    
660  =head2 lookup  =head2 lookup
661    
662  This function will perform lookups on format supplied to it.  Perform lookups on format supplied to it.
663    
664     my $text = $self->lookup('[v900]');
665    
666   my $txt = $self->lookup('[v900]');  Lookups can be nested (like C<[d:[a:[v900]]]>).
667    
668  =cut  =cut
669    
670  sub lookup {  sub lookup {
671          my $self = shift;          my $self = shift;
672    
673          my $tmp = shift || confess "need format";          my $log = $self->_get_logger();
674    
675          if ($tmp =~ /\[[^\[\]]+\]/o) {          my $tmp = shift || $log->logconfess("need format");
676    
677            if ($tmp =~ /$LOOKUP_REGEX/o) {
678                  my @in = ( $tmp );                  my @in = ( $tmp );
679  #print "##lookup $tmp\n";  
680                    $log->debug("lookup for: ",$tmp);
681    
682                  my @out;                  my @out;
683                  while (my $f = shift @in) {                  while (my $f = shift @in) {
684                          if ($f =~ /\[([^\[\]]+)\]/) {                          if ($f =~ /$LOOKUP_REGEX_SAVE/o) {
685                                  my $k = $1;                                  my $k = $1;
686                                  if ($self->{'lookup'}->{$k}) {                                  if ($self->{'lookup'}->{$k}) {
 #print "## lookup key = $k\n";  
687                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {
688                                                  my $tmp2 = $f;                                                  my $tmp2 = $f;
689                                                  $tmp2 =~ s/\[$k\]/$nv/g;                                                  $tmp2 =~ s/lookup{$k}/$nv/g;
690                                                  push @in, $tmp2;                                                  push @in, $tmp2;
 #print "## lookup in => $tmp2\n";  
691                                          }                                          }
692                                  } else {                                  } else {
693                                          undef $f;                                          undef $f;
694                                  }                                  }
695                          } elsif ($f) {                          } elsif ($f) {
696                                  push @out, $f;                                  push @out, $f;
 #print "## lookup out => $f\n";  
697                          }                          }
698                  }                  }
699                    $log->logconfess("return is array and it's not expected!") unless wantarray;
700                  return @out;                  return @out;
701          } else {          } else {
702                  return $tmp;                  return $tmp;
703          }          }
704  }  }
705    
706    =head2 parse
707    
708    Perform smart parsing of string, skipping delimiters for fields which aren't
709    defined. It can also eval code in format starting with C<eval{...}> and
710    return output or nothing depending on eval code.
711    
712     my $text = $webpac->parse($rec,'eval{"v901^a" eq "Deskriptor"}descriptor: v250^a', $i);
713    
714    =cut
715    
716    sub parse {
717            my $self = shift;
718    
719            my ($rec, $format_utf8, $i) = @_;
720    
721            return if (! $format_utf8);
722    
723            my $log = $self->_get_logger();
724    
725            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
726            $log->logconfess("need utf2cp Text::Iconv object!") if (! $self->{'utf2cp'});
727    
728            $i = 0 if (! $i);
729    
730            my $format = $self->_x($format_utf8) || $log->logconfess("can't convert '$format_utf8' from UTF-8 to ",$self->{'code_page'});
731    
732            my @out;
733    
734            $log->debug("format: $format");
735    
736            my $eval_code;
737            # remove eval{...} from beginning
738            $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
739    
740            my $filter_name;
741            # remove filter{...} from beginning
742            $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
743    
744            my $prefix;
745            my $all_found=0;
746    
747            while ($format =~ s/^(.*?)(v|s)(\d+)(?:\^(\w))?//s) {
748    
749                    my $del = $1 || '';
750                    $prefix ||= $del if ($all_found == 0);
751    
752                    # repeatable index
753                    my $r = $i;
754                    $r = 0 if (lc("$2") eq 's');
755    
756                    my $found = 0;
757                    my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found);
758    
759                    if ($found) {
760                            push @out, $del;
761                            push @out, $tmp;
762                            $all_found += $found;
763                    }
764            }
765    
766            return if (! $all_found);
767    
768            my $out = join('',@out);
769    
770            if ($out) {
771                    # add rest of format (suffix)
772                    $out .= $format;
773    
774                    # add prefix if not there
775                    $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);
776    
777                    $log->debug("result: $out");
778            }
779    
780            if ($eval_code) {
781                    my $eval = $self->fill_in($rec,$eval_code,$i) || return;
782                    $log->debug("about to eval{$eval} format: $out");
783                    return if (! $self->_eval($eval));
784            }
785            
786            if ($filter_name && $self->{'filter'}->{$filter_name}) {
787                    $log->debug("about to filter{$filter_name} format: $out");
788                    $out = $self->{'filter'}->{$filter_name}->($out);
789                    return unless(defined($out));
790                    $log->debug("filter result: $out");
791            }
792    
793            return $out;
794    }
795    
796    =head2 parse_to_arr
797    
798    Similar to C<parse>, but returns array of all repeatable fields
799    
800     my @arr = $webpac->parse_to_arr($rec,'v250^a');
801    
802    =cut
803    
804    sub parse_to_arr {
805            my $self = shift;
806    
807            my ($rec, $format_utf8) = @_;
808    
809            my $log = $self->_get_logger();
810    
811            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
812            return if (! $format_utf8);
813    
814            my $i = 0;
815            my @arr;
816    
817            while (my $v = $self->parse($rec,$format_utf8,$i++)) {
818                    push @arr, $v;
819            }
820    
821            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
822    
823            return @arr;
824    }
825    
826    =head2 fill_in_to_arr
827    
828    Similar to C<fill_in>, but returns array of all repeatable fields. Usable
829    for fields which have lookups, so they shouldn't be parsed but rather
830    C<fill_id>ed.
831    
832     my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]');
833    
834    =cut
835    
836    sub fill_in_to_arr {
837            my $self = shift;
838    
839            my ($rec, $format_utf8) = @_;
840    
841            my $log = $self->_get_logger();
842    
843            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
844            return if (! $format_utf8);
845    
846            my $i = 0;
847            my @arr;
848    
849            while (my @v = $self->fill_in($rec,$format_utf8,$i++)) {
850                    push @arr, @v;
851            }
852    
853            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
854    
855            return @arr;
856    }
857    
858    =head2 sort_arr
859    
860    Sort array ignoring case and html in data
861    
862     my @sorted = $webpac->sort_arr(@unsorted);
863    
864    =cut
865    
866    sub sort_arr {
867            my $self = shift;
868    
869            my $log = $self->_get_logger();
870    
871            # FIXME add Schwartzian Transformation?
872    
873            my @sorted = sort {
874                    $a =~ s#<[^>]+/*>##;
875                    $b =~ s#<[^>]+/*>##;
876                    lc($b) cmp lc($a)
877            } @_;
878            $log->debug("sorted values: ",sub { join(", ",@sorted) });
879    
880            return @sorted;
881    }
882    
883    
884    =head2 data_structure
885    
886    Create in-memory data structure which represents layout from C<import_xml>.
887    It is used later to produce output.
888    
889     my @ds = $webpac->data_structure($rec);
890    
891    This method will also set C<$webpac->{'currnet_filename'}> if there is
892    <filename> tag in C<import_xml> and C<$webpac->{'headline'}> if there is
893    <headline> tag.
894    
895    =cut
896    
897    sub data_structure {
898            my $self = shift;
899    
900            my $log = $self->_get_logger();
901    
902            my $rec = shift;
903            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
904    
905            undef $self->{'currnet_filename'};
906            undef $self->{'headline'};
907    
908            my @sorted_tags;
909            if ($self->{tags_by_order}) {
910                    @sorted_tags = @{$self->{tags_by_order}};
911            } else {
912                    @sorted_tags = sort { $self->_sort_by_order } keys %{$self->{'import_xml'}->{'indexer'}};
913                    $self->{tags_by_order} = \@sorted_tags;
914            }
915    
916            my @ds;
917    
918            $log->debug("tags: ",sub { join(", ",@sorted_tags) });
919    
920            foreach my $field (@sorted_tags) {
921    
922                    my $row;
923    
924    #print "field $field [",$self->{'tag'},"] = ",Dumper($self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}});
925    
926                    foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
927                            my $format = $tag->{'value'} || $tag->{'content'};
928    
929                            $log->debug("format: $format");
930    
931                            my @v;
932                            if ($format =~ /$LOOKUP_REGEX/o) {
933                                    @v = $self->fill_in_to_arr($rec,$format);
934                            } else {
935                                    @v = $self->parse_to_arr($rec,$format);
936                            }
937                            next if (! @v);
938    
939                            if ($tag->{'sort'}) {
940                                    @v = $self->sort_arr(@v);
941                            }
942    
943                            # use format?
944                            if ($tag->{'format_name'}) {
945                                    @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
946                            }
947    
948                            if ($field eq 'filename') {
949                                    $self->{'current_filename'} = join('',@v);
950                                    $log->debug("filename: ",$self->{'current_filename'});
951                            } elsif ($field eq 'headline') {
952                                    $self->{'headline'} .= join('',@v);
953                                    $log->debug("headline: ",$self->{'headline'});
954                                    next; # don't return headline in data_structure!
955                            }
956    
957                            # delimiter will join repeatable fields
958                            if ($tag->{'delimiter'}) {
959                                    @v = ( join($tag->{'delimiter'}, @v) );
960                            }
961    
962                            # default types
963                            my @types = qw(display swish);
964                            # override by type attribute
965                            @types = ( $tag->{'type'} ) if ($tag->{'type'});
966    
967                            foreach my $type (@types) {
968                                    # append to previous line?
969                                    $log->debug("type: $type ",sub { join(" ",@v) }, $row->{'append'} || 'no append');
970                                    if ($tag->{'append'}) {
971    
972                                            # I will delimit appended part with
973                                            # delimiter (or ,)
974                                            my $d = $tag->{'delimiter'};
975                                            # default delimiter
976                                            $d ||= " ";
977    
978                                            my $last = pop @{$row->{$type}};
979                                            $d = "" if (! $last);
980                                            $last .= $d . join($d, @v);
981                                            push @{$row->{$type}}, $last;
982    
983                                    } else {
984                                            push @{$row->{$type}}, @v;
985                                    }
986                            }
987    
988    
989                    }
990    
991                    if ($row) {
992                            $row->{'tag'} = $field;
993    
994                            # TODO: name_sigular, name_plural
995                            my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
996                            $row->{'name'} = $name ? $self->_x($name) : $field;
997    
998                            # post-sort all values in field
999                            if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {
1000                                    $log->warn("sort at field tag not implemented");
1001                            }
1002    
1003                            push @ds, $row;
1004    
1005                            $log->debug("row $field: ",sub { Dumper($row) });
1006                    }
1007    
1008            }
1009    
1010            return @ds;
1011    
1012    }
1013    
1014    =head2 output
1015    
1016    Create output from in-memory data structure using Template Toolkit template.
1017    
1018    my $text = $webpac->output( template => 'text.tt', data => @ds );
1019    
1020    =cut
1021    
1022    sub output {
1023            my $self = shift;
1024    
1025            my $args = {@_};
1026    
1027            my $log = $self->_get_logger();
1028    
1029            $log->logconfess("need template name") if (! $args->{'template'});
1030            $log->logconfess("need data array") if (! $args->{'data'});
1031    
1032            my $out;
1033    
1034            $self->{'tt'}->process(
1035                    $args->{'template'},
1036                    $args,
1037                    \$out
1038            ) || confess $self->{'tt'}->error();
1039    
1040            return $out;
1041    }
1042    
1043    =head2 output_file
1044    
1045    Create output from in-memory data structure using Template Toolkit template
1046    to a file.
1047    
1048     $webpac->output_file(
1049            file => 'out.txt',
1050            template => 'text.tt',
1051            data => @ds
1052     );
1053    
1054    =cut
1055    
1056    sub output_file {
1057            my $self = shift;
1058    
1059            my $args = {@_};
1060    
1061            my $log = $self->_get_logger();
1062    
1063            my $file = $args->{'file'} || $log->logconfess("need file name");
1064    
1065            $log->debug("creating file ",$file);
1066    
1067            open(my $fh, ">", $file) || $log->logdie("can't open output file '$file': $!");
1068            print $fh $self->output(
1069                    template => $args->{'template'},
1070                    data => $args->{'data'},
1071            ) || $log->logdie("print: $!");
1072            close($fh) || $log->logdie("close: $!");
1073    }
1074    
1075    =head2 apply_format
1076    
1077    Apply format specified in tag with C<format_name="name"> and
1078    C<format_delimiter=";;">.
1079    
1080     my $text = $webpac->apply_format($format_name,$format_delimiter,$data);
1081    
1082    Formats can contain C<lookup{...}> if you need them.
1083    
1084    =cut
1085    
1086    sub apply_format {
1087            my $self = shift;
1088    
1089            my ($name,$delimiter,$data) = @_;
1090    
1091            my $log = $self->_get_logger();
1092    
1093            if (! $self->{'import_xml'}->{'format'}->{$name}) {
1094                    $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});
1095                    return $data;
1096            }
1097    
1098            $log->warn("no delimiter for format $name") if (! $delimiter);
1099    
1100            my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");
1101    
1102            my @data = split(/\Q$delimiter\E/, $data);
1103    
1104            my $out = sprintf($format, @data);
1105            $log->debug("using format $name [$format] on $data to produce: $out");
1106    
1107            if ($out =~ m/$LOOKUP_REGEX/o) {
1108                    return $self->lookup($out);
1109            } else {
1110                    return $out;
1111            }
1112    
1113    }
1114    
1115    
1116    #
1117    #
1118    #
1119    
1120    =head1 INTERNAL METHODS
1121    
1122    Here is a quick list of internal methods, mostly useful to turn debugging
1123    on them (see L<LOGGING> below for explanation).
1124    
1125    =cut
1126    
1127    =head2 _eval
1128    
1129    Internal function to eval code without C<strict 'subs'>.
1130    
1131    =cut
1132    
1133    sub _eval {
1134            my $self = shift;
1135    
1136            my $code = shift || return;
1137    
1138            my $log = $self->_get_logger();
1139    
1140            no strict 'subs';
1141            my $ret = eval $code;
1142            if ($@) {
1143                    $log->error("problem with eval code [$code]: $@");
1144            }
1145    
1146            $log->debug("eval: ",$code," [",$ret,"]");
1147    
1148            return $ret || undef;
1149    }
1150    
1151    =head2 _sort_by_order
1152    
1153    Sort xml tags data structure accoding to C<order=""> attribute.
1154    
1155    =cut
1156    
1157    sub _sort_by_order {
1158            my $self = shift;
1159    
1160            my $va = $self->{'import_xml'}->{'indexer'}->{$a}->{'order'} ||
1161                    $self->{'import_xml'}->{'indexer'}->{$a};
1162            my $vb = $self->{'import_xml'}->{'indexer'}->{$b}->{'order'} ||
1163                    $self->{'import_xml'}->{'indexer'}->{$b};
1164    
1165            return $va <=> $vb;
1166    }
1167    
1168    =head2 _get_logger
1169    
1170    Get C<Log::Log4perl> object with a twist: domains are defined for each
1171    method
1172    
1173     my $log = $webpac->_get_logger();
1174    
1175    =cut
1176    
1177    sub _get_logger {
1178            my $self = shift;
1179    
1180            my $name = (caller(1))[3] || caller;
1181            return get_logger($name);
1182    }
1183    
1184    =head2 _x
1185    
1186    Convert string from UTF-8 to code page defined in C<import_xml>.
1187    
1188     my $text = $webpac->_x('utf8 text');
1189    
1190    =cut
1191    
1192    sub _x {
1193            my $self = shift;
1194            my $utf8 = shift || return;
1195    
1196            return $self->{'utf2cp'}->convert($utf8) ||
1197                    $self->_get_logger()->logwarn("can't convert '$utf8'");
1198    }
1199    
1200    #
1201    #
1202    #
1203    
1204    =head1 LOGGING
1205    
1206    Logging in WebPAC is performed by L<Log::Log4perl> with config file
1207    C<log.conf>.
1208    
1209    Methods defined above have different levels of logging, so
1210    it's descriptions will be useful to turn (mostry B<debug> logging) on
1211    or off to see why WabPAC isn't perforing as you expect it (it might even
1212    be a bug!).
1213    
1214    B<This is different from normal Log4perl behaviour>. To repeat, you can
1215    also use method names, and not only classes (which are just few)
1216    to filter logging.
1217    
1218    
1219    =head1 MEMORY USAGE
1220    
1221    C<low_mem> options is double-edged sword. If enabled, WebPAC
1222    will run on memory constraint machines (which doesn't have enough
1223    physical RAM to create memory structure for whole source database).
1224    
1225    If your machine has 512Mb or more of RAM and database is around 10000 records,
1226    memory shouldn't be an issue. If you don't have enough physical RAM, you
1227    might consider using virtual memory (if your operating system is handling it
1228    well, like on FreeBSD or Linux) instead of dropping to L<DBD::Deep> to handle
1229    parsed structure of ISIS database (this is what C<low_mem> option does).
1230    
1231    Hitting swap at end of reading source database is probably o.k. However,
1232    hitting swap before 90% will dramatically decrease performance and you will
1233    be better off with C<low_mem> and using rest of availble memory for
1234    operating system disk cache (Linux is particuallary good about this).
1235    However, every access to database record will require disk access, so
1236    generation phase will be slower 10-100 times.
1237    
1238    Parsed structures are essential - you just have option to trade RAM memory
1239    (which is fast) for disk space (which is slow). Be sure to have planty of
1240    disk space if you are using C<low_mem> and thus L<DBD::Deep>.
1241    
1242    However, when WebPAC is running on desktop machines (or laptops :-), it's
1243    highly undesireable for system to start swapping. Using C<low_mem> option can
1244    reduce WecPAC memory usage to around 64Mb for same database with lookup
1245    fields and sorted indexes which stay in RAM. Performance will suffer, but
1246    memory usage will really be minimal. It might be also more confortable to
1247    run WebPAC reniced on those machines.
1248    
1249    =cut
1250    
1251  1;  1;
Legend:
Removed from v.353  
changed lines
  Added in v.707
  ViewVC Help
Powered by ViewVC 1.1.26