/[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 363 by dpavlin, Wed Jun 16 20:05:19 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;  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;  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
# Line 19  This module implements methods used by W Line 40  This module implements methods used by W
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.
# Line 49  sub new { Line 80  sub new {
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 56  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 67  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            # create UTF-8 convertor for import_xml files
121            $self->{'utf2cp'} = Text::Iconv->new('UTF-8' ,$self->{'code_page'});
122    
123            # create Template toolkit instance
124            $self->{'tt'} = Template->new(
125                    INCLUDE_PATH => ($self->{'global_config_file'}->{'output_template'} || './output_template'),
126                    FILTERS => $self->{'filter'},
127                    EVAL_PERL => 1,
128            );
129    
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          print STDERR "reading ISIS database '",$arg->{'filename'},"'\n" if ($self->{'debug'});          $log->info("reading ISIS database '",$arg->{'filename'},"'");
218            $log->debug("isis code page: $code_page");
219    
220          my $isis_db = OpenIsis::open($arg->{'filename'});          my ($isis_db,$maxmfn);
221    
222          my $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;          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          $maxmfn = $self->{limit_mfn} if ($self->{limit_mfn});          } 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    
         print STDERR "processing $maxmfn records...\n" if ($self->{'debug'});  
263    
264          # read database          # read database
265          for (my $mfn = 1; $mfn <= $maxmfn; $mfn++) {          for (my $mfn = $startmfn; $mfn <= $maxmfn; $mfn++) {
266    
267    
268                  # read record                  $log->debug("mfn: $mfn\n");
269                  my $row = OpenIsis::read( $isis_db, $mfn );  
270                  foreach my $k (keys %{$row}) {                  my $rec;
271                          if ($k ne "mfn") {  
272                                  foreach my $l (@{$row->{$k}}) {                  if ($have_openisis) {
273                                          $l = $cp->convert($l);  
274                                          # has subfields?                          # read record using OpenIsis
275                                          my $val;                          my $row = OpenIsis::read( $isis_db, $mfn );
276                                          if ($l =~ m/\^/) {                          foreach my $k (keys %{$row}) {
277                                                  foreach my $t (split(/\^/,$l)) {                                  if ($k ne "mfn") {
278                                                          next if (! $t);                                          foreach my $l (@{$row->{$k}}) {
279                                                          $val->{substr($t,0,1)} = substr($t,1);                                                  $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
                 my $rec = $self->{'data'}->{$mfn};  
314                  $self->create_lookup($rec, @{$arg->{'lookup'}});                  $self->create_lookup($rec, @{$arg->{'lookup'}});
315    
316                    $self->progress_bar($mfn,$maxmfn);
317    
318          }          }
319    
320          $self->{'current_mfn'} = 1;          $self->{'current_mfn'} = -1;
321            $self->{'last_pcnt'} = 0;
322    
323            $log->debug("max mfn: $maxmfn");
324    
325          # store max mfn and return it.          # store max mfn and return it.
326          return $self->{'max_mfn'} = $maxmfn;          return $self->{'max_mfn'} = $maxmfn;
# Line 185  it's implemented, that is). Line 338  it's implemented, that is).
338  sub fetch_rec {  sub fetch_rec {
339          my $self = shift;          my $self = shift;
340    
341          my $mfn = $self->{'current_mfn'}++ || confess "it seems that you didn't load database!";          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'}) {          if ($mfn > $self->{'max_mfn'}) {
354                  $self->{'current_mfn'} = $self->{'max_mfn'};                  $self->{'current_mfn'} = $self->{'max_mfn'};
355                    $log->debug("at EOF");
356                  return;                  return;
357          }          }
358    
359          return $self->{'data'}->{$mfn};          $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            if ($curr > $max) {
400                    $max = $curr;
401                    $log->debug("overflow to $curr");
402            }
403    
404            $self->{'last_pcnt'} ||= 1;
405    
406            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  =head2 open_import_xml
# Line 206  Read file from C<import_xml/> directory Line 457  Read file from C<import_xml/> directory
457  sub open_import_xml {  sub open_import_xml {
458          my $self = shift;          my $self = shift;
459    
460            my $log = $self->_get_logger();
461    
462          my $arg = {@_};          my $arg = {@_};
463          confess "need type to load file from import_xml/" if (! $arg->{'type'});          $log->logconfess("need type to load file from import_xml/") if (! $arg->{'type'});
464    
465          my $type = $arg->{'type'};          $self->{'type'} = $arg->{'type'};
466    
467          my $type_base = $type;          my $type_base = $arg->{'type'};
468          $type_base =~ s/_.*$//g;          $type_base =~ s/_.*$//g;
469    
470          my $f = "./import_xml/$type.xml";          $self->{'tag'} = $type2tag{$type_base};
471          confess "import_xml file '$f' doesn't exist!" if (! -e "$f");  
472            $log->info("using type '",$self->{'type'},"' tag <",$self->{'tag'},">");
473    
474          print STDERR "reading '$f'\n" if ($self->{'debug'});          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,          $self->{'import_xml'} = XMLin($f,
482                  ForceArray => [ $type2tag{$type_base}, 'config', 'format' ],                  ForceArray => [ $self->{'tag'}, 'config', 'format' ],
                 ForceContent => 1  
483          );          );
484    
485          print Dumper($self->{'import_xml'});          $log->debug("import xml is ",sub { Dumper($self->{'import_xml'}) });
486    
487  }  }
488    
# Line 232  sub open_import_xml { Line 490  sub open_import_xml {
490    
491  Create lookup from record using lookup definition.  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  =cut
498    
499  sub create_lookup {  sub create_lookup {
500          my $self = shift;          my $self = shift;
501    
502          my $rec = shift || confess "need record to create lookup";          my $log = $self->_get_logger();
503          confess("need HASH as first argument!") if ($rec !~ /HASH/o);  
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 (@_) {          foreach my $i (@_) {
508                  if ($i->{'eval'}) {                  $log->logconfess("need key") unless defined($i->{'key'});
509                          my $eval = $self->fill_in($rec,$i->{'eval'});                  $log->logconfess("need val") unless defined($i->{'val'});
510                          my $key = $self->fill_in($rec,$i->{'key'});  
511                          my @val = $self->fill_in($rec,$i->{'val'});                  if (defined($i->{'eval'})) {
512                          if ($key && @val && eval $eval) {                          # 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;                                  push @{$self->{'lookup'}->{$key}}, @val;
519                          }                          }
520                  } else {                  } else {
521                          my $key = $self->fill_in($rec,$i->{'key'});                          my $key = $self->fill_in($rec,$i->{'key'}) || next;
522                          my @val = $self->fill_in($rec,$i->{'val'});                          my @val = $self->fill_in($rec,$i->{'val'}) || next;
523                          if ($key && @val) {                          $log->debug("stored $key = ",sub { join(" | ",@val) });
524                                  push @{$self->{'lookup'}->{$key}}, @val;                          push @{$self->{'lookup'}->{$key}}, @val;
                         }  
525                  }                  }
526          }          }
527  }  }
# Line 262  sub create_lookup { Line 530  sub create_lookup {
530    
531  Returns value from record.  Returns value from record.
532    
533   $self->get_data(\$rec,$f,$sf,$i,\$found);   my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);
534    
535  Arguments are:  Arguments are:
536  record reference C<$rec>,  record reference C<$rec>,
# Line 270  field C<$f>, Line 538  field C<$f>,
538  optional subfiled C<$sf>,  optional subfiled C<$sf>,
539  index for repeatable values C<$i>.  index for repeatable values C<$i>.
540    
541  Optinal variable C<$found> will be incremeted if thre  Optinal variable C<$found> will be incremeted if there
542  is field.  is field.
543    
544  Returns value or empty string.  Returns value or empty string.
# Line 281  sub get_data { Line 549  sub get_data {
549          my $self = shift;          my $self = shift;
550    
551          my ($rec,$f,$sf,$i,$found) = @_;          my ($rec,$f,$sf,$i,$found) = @_;
552    
553          if ($$rec->{$f}) {          if ($$rec->{$f}) {
554                    return '' if (! $$rec->{$f}->[$i]);
555                    no strict 'refs';
556                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {
557                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
558                          return $$rec->{$f}->[$i]->{$sf};                          return $$rec->{$f}->[$i]->{$sf};
559                  } elsif ($$rec->{$f}->[$i]) {                  } elsif ($$rec->{$f}->[$i]) {
560                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
561                          return $$rec->{$f}->[$i];                          # 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 {
570                                    return $$rec->{$f}->[$i];
571                            }
572                  }                  }
573          } else {          } else {
574                  return '';                  return '';
# Line 300  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          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
615    
616            if (utf8::is_utf8($format)) {
617                    $format = $self->_x($format);
618            }
619    
620          my $found = 0;          my $found = 0;
621    
# Line 331  sub fill_in { Line 623  sub fill_in {
623          # remove eval{...} from beginning          # remove eval{...} from beginning
624          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
625    
626            my $filter_name;
627            # remove filter{...} from beginning
628            $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
629    
630          # do actual replacement of placeholders          # do actual replacement of placeholders
631          $format =~ s/v(\d+)(?:\^(\w))*/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;          # repeatable fields
632            $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) {                  if ($eval_code) {
639                          my $eval = $self->fill_in($rec,$eval_code,$i);                          my $eval = $self->fill_in($rec,$eval_code,$i);
640                          return if (! eval $eval);                          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 354  sub fill_in { Line 661  sub fill_in {
661    
662  Perform lookups on format supplied to it.  Perform lookups on format supplied to it.
663    
664   my $txt = $self->lookup('[v900]');   my $text = $self->lookup('[v900]');
665    
666  Lookups can be nested (like C<[d:[a:[v900]]]>).  Lookups can be nested (like C<[d:[a:[v900]]]>).
667    
# Line 363  Lookups can be nested (like C<[d:[a:[v90 Line 670  Lookups can be nested (like C<[d:[a:[v90
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            my $tmp = shift || $log->logconfess("need format");
676    
677          if ($tmp =~ /\[[^\[\]]+\]/o) {          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;
# Line 400  Perform smart parsing of string, skippin Line 709  Perform smart parsing of string, skippin
709  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
710  return output or nothing depending on eval code.  return output or nothing depending on eval code.
711    
712   $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);
713    
714  =cut  =cut
715    
716  sub parse {  sub parse {
717          my $self = shift;          my $self = shift;
718    
719          my ($rec, $format, $i) = @_;          my ($rec, $format_utf8, $i) = @_;
720    
721          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          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);          $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;          my @out;
733    
734            $log->debug("format: $format");
735    
736          my $eval_code;          my $eval_code;
737          # remove eval{...} from beginning          # remove eval{...} from beginning
738          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $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;          my $prefix;
745          my $all_found=0;          my $all_found=0;
746    
747  #print "## $format\n";          while ($format =~ s/^(.*?)(v|s)(\d+)(?:\^(\w))?//s) {
         while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))*//s) {  
 #print "## [ $1 | $2 | $3 ] $format\n";  
748    
749                  my $del = $1 || '';                  my $del = $1 || '';
750                  $prefix ||= $del if ($all_found == 0);                  $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;                  my $found = 0;
757                  my $tmp = $self->get_data(\$rec,$2,$3,$i,\$found);                  my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found);
758    
759                  if ($found) {                  if ($found) {
760                          push @out, $del;                          push @out, $del;
# Line 441  sub parse { Line 765  sub parse {
765    
766          return if (! $all_found);          return if (! $all_found);
767    
768          my $out = join('',@out) . $format;          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    
         # add prefix if not there  
         $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);  
           
780          if ($eval_code) {          if ($eval_code) {
781                  my $eval = $self->fill_in($rec,$eval_code,$i);                  my $eval = $self->fill_in($rec,$eval_code,$i) || return;
782                  return if (! eval $eval);                  $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;          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.363  
changed lines
  Added in v.707
  ViewVC Help
Powered by ViewVC 1.1.26