/[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 374 by dpavlin, Sun Jun 20 16:57:52 2004 UTC revision 705 by dpavlin, Wed Jul 13 22:34:52 2005 UTC
# Line 9  use Config::IniFiles; Line 9  use Config::IniFiles;
9  use XML::Simple;  use XML::Simple;
10  use Template;  use Template;
11  use Log::Log4perl qw(get_logger :levels);  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 = '\[[^\[\]]+\]';  #my $LOOKUP_REGEX = '\[[^\[\]]+\]';
27  #my $LOOKUP_REGEX_SAVE = '\[([^\[\]]+)\]';  #my $LOOKUP_REGEX_SAVE = '\[([^\[\]]+)\]';
28  my $LOOKUP_REGEX = 'lookup{[^\{\}]+}';  my $LOOKUP_REGEX = 'lookup{[^\{\}]+}';
# Line 29  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 59  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";          my $log_file = $self->{'log'} || "log.conf";
86          Log::Log4perl->init($log_file);          Log::Log4perl->init($log_file);
87    
# Line 100  sub new { Line 123  sub new {
123          # create Template toolkit instance          # create Template toolkit instance
124          $self->{'tt'} = Template->new(          $self->{'tt'} = Template->new(
125                  INCLUDE_PATH => ($self->{'global_config_file'}->{'output_template'} || './output_template'),                  INCLUDE_PATH => ($self->{'global_config_file'}->{'output_template'} || './output_template'),
126  #               FILTERS => {                  FILTERS => $self->{'filter'},
 #                       'foo' => \&foo_filter,  
 #               },  
127                  EVAL_PERL => 1,                  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    
# Line 149  sub open_isis { Line 203  sub open_isis {
203          $log->logcroak("need filename") if (! $arg->{'filename'});          $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    
# Line 157  sub open_isis { Line 215  sub open_isis {
215          my $cp = Text::Iconv->new($code_page,$self->{'code_page'});          my $cp = Text::Iconv->new($code_page,$self->{'code_page'});
216    
217          $log->info("reading ISIS database '",$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          my $isis_db = OpenIsis::open($arg->{'filename'});          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->{'maxmfn'};
239            } else {
240                    $log->logdie("Can't find supported ISIS library for perl. I suggent that you install Bilbio::Isis from CPAN.");
241            }
242    
         my $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;  
243    
244          $maxmfn = $self->{limit_mfn} if ($self->{limit_mfn});          my $startmfn = 1;
245    
246            if (my $s = $self->{'start_mfn'}) {
247                    $log->info("skipping to MFN $s");
248                    $startmfn = $s;
249            } else {
250                    $self->{'start_mfn'} = $startmfn;
251            }
252    
253            $maxmfn = $startmfn + $self->{limit_mfn} if ($self->{limit_mfn});
254    
255            $log->info("processing ",($maxmfn-$startmfn)." records using ",( $have_openisis ? 'OpenIsis' : 'Biblio::Isis'));
256    
         $log->info("processing $maxmfn records...");  
257    
258          # read database          # read database
259          for (my $mfn = 1; $mfn <= $maxmfn; $mfn++) {          for (my $mfn = $startmfn; $mfn <= $maxmfn; $mfn++) {
260    
261    
262                    $log->debug("mfn: $mfn\n");
263    
264                    my $rec;
265    
266                  # read record                  if ($have_openisis) {
267                  my $row = OpenIsis::read( $isis_db, $mfn );  
268                  foreach my $k (keys %{$row}) {                          # read record using OpenIsis
269                          if ($k ne "mfn") {                          my $row = OpenIsis::read( $isis_db, $mfn );
270                                  foreach my $l (@{$row->{$k}}) {                          foreach my $k (keys %{$row}) {
271                                          $l = $cp->convert($l);                                  if ($k ne "mfn") {
272                                          # has subfields?                                          foreach my $l (@{$row->{$k}}) {
273                                          my $val;                                                  $l = $cp->convert($l);
274                                          if ($l =~ m/\^/) {                                                  # has subfields?
275                                                  foreach my $t (split(/\^/,$l)) {                                                  my $val;
276                                                          next if (! $t);                                                  if ($l =~ m/\^/) {
277                                                          $val->{substr($t,0,1)} = substr($t,1);                                                          foreach my $t (split(/\^/,$l)) {
278                                                                    next if (! $t);
279                                                                    $val->{substr($t,0,1)} = substr($t,1);
280                                                            }
281                                                    } else {
282                                                            $val = $l;
283                                                  }                                                  }
                                         } else {  
                                                 $val = $l;  
                                         }  
284    
285                                          push @{$self->{'data'}->{$mfn}->{$k}}, $val;                                                  push @{$rec->{$k}}, $val;
286                                            }
287                                    } else {
288                                            push @{$rec->{'000'}}, $mfn;
289                                  }                                  }
                         } else {  
                                 push @{$self->{'data'}->{$mfn}->{'000'}}, $mfn;  
290                          }                          }
291    
292                    } elsif ($have_biblio_isis) {
293                            $rec = $isis_db->to_hash($mfn);
294                    } else {
295                            $log->logdie("hum? implementation missing?");
296                    }
297    
298                    $log->confess("record $mfn empty?") unless ($rec);
299    
300                    # store
301                    if ($self->{'low_mem'}) {
302                            $self->{'db'}->put($mfn, $rec);
303                    } else {
304                            $self->{'data'}->{$mfn} = $rec;
305                  }                  }
306    
307                  # create lookup                  # create lookup
                 my $rec = $self->{'data'}->{$mfn};  
308                  $self->create_lookup($rec, @{$arg->{'lookup'}});                  $self->create_lookup($rec, @{$arg->{'lookup'}});
309    
310                    $self->progress_bar($mfn,$maxmfn);
311    
312          }          }
313    
314          $self->{'current_mfn'} = 1;          $self->{'current_mfn'} = -1;
315            $self->{'last_pcnt'} = 0;
316    
317            $log->debug("max mfn: $maxmfn");
318    
319          # store max mfn and return it.          # store max mfn and return it.
320          return $self->{'max_mfn'} = $maxmfn;          return $self->{'max_mfn'} = $maxmfn;
# Line 220  sub fetch_rec { Line 334  sub fetch_rec {
334    
335          my $log = $self->_get_logger();          my $log = $self->_get_logger();
336    
337          my $mfn = $self->{'current_mfn'}++ || $log->logconfess("it seems that you didn't load database!");          $log->logconfess("it seems that you didn't load database!") unless ($self->{'current_mfn'});
338    
339            if ($self->{'current_mfn'} == -1) {
340                    $self->{'current_mfn'} = $self->{'start_mfn'};
341            } else {
342                    $self->{'current_mfn'}++;
343            }
344    
345            my $mfn = $self->{'current_mfn'};
346    
347          if ($mfn > $self->{'max_mfn'}) {          if ($mfn > $self->{'max_mfn'}) {
348                  $self->{'current_mfn'} = $self->{'max_mfn'};                  $self->{'current_mfn'} = $self->{'max_mfn'};
# Line 228  sub fetch_rec { Line 350  sub fetch_rec {
350                  return;                  return;
351          }          }
352    
353          return $self->{'data'}->{$mfn};          $self->progress_bar($mfn,$self->{'max_mfn'});
354    
355            if ($self->{'low_mem'}) {
356                    return $self->{'db'}->get($mfn);
357            } else {
358                    return $self->{'data'}->{$mfn};
359            }
360    }
361    
362    =head2 mfn
363    
364    Returns current record number (MFN).
365    
366     print $webpac->mfn;
367    
368    =cut
369    
370    sub mfn {
371            my $self = shift;
372            return $self->{'current_mfn'};
373    }
374    
375    =head2 progress_bar
376    
377    Draw progress bar on STDERR.
378    
379     $webpac->progress_bar($current, $max);
380    
381    =cut
382    
383    sub progress_bar {
384            my $self = shift;
385    
386            my ($curr,$max) = @_;
387    
388            my $log = $self->_get_logger();
389    
390            $log->logconfess("no current value!") if (! $curr);
391            $log->logconfess("no maximum value!") if (! $max);
392    
393            if ($curr > $max) {
394                    $max = $curr;
395                    $log->debug("overflow to $curr");
396            }
397    
398            $self->{'last_pcnt'} ||= 1;
399    
400            my $p = int($curr * 100 / $max) || 1;
401    
402            # reset on re-run
403            if ($p < $self->{'last_pcnt'}) {
404                    $self->{'last_pcnt'} = $p;
405                    $self->{'start_t'} = time();
406            }
407    
408            if ($p != $self->{'last_pcnt'}) {
409    
410                    my $t = time();
411                    my $rate = ($curr / ($t - $self->{'start_t'} || 1));
412                    my $eta = ($max-$curr) / ($rate || 1);
413                    printf STDERR ("%5d [%-38s] %-5d %0.1f/s %s\r",$curr,"=" x ($p/3)."$p%>", $max, $rate, $self->fmt_time($eta));
414                    $self->{'last_pcnt'} = $p;
415                    $self->{'last_curr'} = $curr;
416            }
417            print STDERR "\n" if ($p == 100);
418    }
419    
420    =head2 fmt_time
421    
422    Format time (in seconds) for display.
423    
424     print $webpac->fmt_time(time());
425    
426    This method is called by L<progress_bar> to display remaining time.
427    
428    =cut
429    
430    sub fmt_time {
431            my $self = shift;
432    
433            my $t = shift || 0;
434            my $out = "";
435    
436            my ($ss,$mm,$hh) = gmtime($t);
437            $out .= "${hh}h" if ($hh);
438            $out .= sprintf("%02d:%02d", $mm,$ss);
439            $out .= "  " if ($hh == 0);
440            return $out;
441  }  }
442    
443  =head2 open_import_xml  =head2 open_import_xml
# Line 254  sub open_import_xml { Line 463  sub open_import_xml {
463    
464          $self->{'tag'} = $type2tag{$type_base};          $self->{'tag'} = $type2tag{$type_base};
465    
466          $log->debug("using type '",$self->{'type'},"' tag <",$self->{'tag'},">") if ($self->{'debug'});          $log->info("using type '",$self->{'type'},"' tag <",$self->{'tag'},">");
467    
468          my $f = "./import_xml/".$self->{'type'}.".xml";          my $f = "./import_xml/".$self->{'type'}.".xml";
469          $log->logconfess("import_xml file '$f' doesn't exist!") if (! -e "$f");          $log->logconfess("import_xml file '$f' doesn't exist!") if (! -e "$f");
470    
471          $log->debug("reading '$f'") if ($self->{'debug'});          $log->info("reading '$f'");
472    
473            $self->{'import_xml_file'} = $f;
474    
475          $self->{'import_xml'} = XMLin($f,          $self->{'import_xml'} = XMLin($f,
476                  ForceArray => [ $self->{'tag'}, 'config', 'format' ],                  ForceArray => [ $self->{'tag'}, 'config', 'format' ],
477          );          );
478    
479            $log->debug("import xml is ",sub { Dumper($self->{'import_xml'}) });
480    
481  }  }
482    
483  =head2 create_lookup  =head2 create_lookup
# Line 286  sub create_lookup { Line 499  sub create_lookup {
499          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
500    
501          foreach my $i (@_) {          foreach my $i (@_) {
502                  if ($i->{'eval'}) {                  $log->logconfess("need key") unless defined($i->{'key'});
503                          my $eval = $self->fill_in($rec,$i->{'eval'});                  $log->logconfess("need val") unless defined($i->{'val'});
504                          my $key = $self->fill_in($rec,$i->{'key'});  
505                          my @val = $self->fill_in($rec,$i->{'val'});                  if (defined($i->{'eval'})) {
506                          if ($key && @val && eval $eval) {                          # eval first, so we can skip fill_in for key and val
507                            my $eval = $self->fill_in($rec,$i->{'eval'}) || next;
508                            if ($self->_eval($eval)) {
509                                    my $key = $self->fill_in($rec,$i->{'key'}) || next;
510                                    my @val = $self->fill_in($rec,$i->{'val'}) || next;
511                                  $log->debug("stored $key = ",sub { join(" | ",@val) });                                  $log->debug("stored $key = ",sub { join(" | ",@val) });
512                                  push @{$self->{'lookup'}->{$key}}, @val;                                  push @{$self->{'lookup'}->{$key}}, @val;
513                          }                          }
514                  } else {                  } else {
515                          my $key = $self->fill_in($rec,$i->{'key'});                          my $key = $self->fill_in($rec,$i->{'key'}) || next;
516                          my @val = $self->fill_in($rec,$i->{'val'});                          my @val = $self->fill_in($rec,$i->{'val'}) || next;
517                          if ($key && @val) {                          $log->debug("stored $key = ",sub { join(" | ",@val) });
518                                  $log->debug("stored $key = ",sub { join(" | ",@val) });                          push @{$self->{'lookup'}->{$key}}, @val;
                                 push @{$self->{'lookup'}->{$key}}, @val;  
                         }  
519                  }                  }
520          }          }
521  }  }
# Line 331  sub get_data { Line 546  sub get_data {
546    
547          if ($$rec->{$f}) {          if ($$rec->{$f}) {
548                  return '' if (! $$rec->{$f}->[$i]);                  return '' if (! $$rec->{$f}->[$i]);
549                    no strict 'refs';
550                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {
551                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
552                          return $$rec->{$f}->[$i]->{$sf};                          return $$rec->{$f}->[$i]->{$sf};
# Line 371  Following example will read second value Line 587  Following example will read second value
587  This function B<does not> perform parsing of format to inteligenty skip  This function B<does not> perform parsing of format to inteligenty skip
588  delimiters before fields which aren't used.  delimiters before fields which aren't used.
589    
590    This method will automatically decode UTF-8 string to local code page
591    if needed.
592    
593  =cut  =cut
594    
595  sub fill_in {  sub fill_in {
# Line 383  sub fill_in { Line 602  sub fill_in {
602          # iteration (for repeatable fields)          # iteration (for repeatable fields)
603          my $i = shift || 0;          my $i = shift || 0;
604    
605            $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));
606    
607          # FIXME remove for speedup?          # FIXME remove for speedup?
608          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
609    
610            if (utf8::is_utf8($format)) {
611                    $format = $self->_x($format);
612            }
613    
614          my $found = 0;          my $found = 0;
615    
616          my $eval_code;          my $eval_code;
617          # remove eval{...} from beginning          # remove eval{...} from beginning
618          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
619    
620            my $filter_name;
621            # remove filter{...} from beginning
622            $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
623    
624          # do actual replacement of placeholders          # do actual replacement of placeholders
625            # repeatable fields
626          $format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;          $format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;
627            # non-repeatable fields
628            $format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found)/ges;
629    
630          if ($found) {          if ($found) {
631                  $log->debug("format: $format");                  $log->debug("format: $format");
# Line 401  sub fill_in { Line 633  sub fill_in {
633                          my $eval = $self->fill_in($rec,$eval_code,$i);                          my $eval = $self->fill_in($rec,$eval_code,$i);
634                          return if (! $self->_eval($eval));                          return if (! $self->_eval($eval));
635                  }                  }
636                    if ($filter_name && $self->{'filter'}->{$filter_name}) {
637                            $log->debug("filter '$filter_name' for $format");
638                            $format = $self->{'filter'}->{$filter_name}->($format);
639                            return unless(defined($format));
640                            $log->debug("filter result: $format");
641                    }
642                  # do we have lookups?                  # do we have lookups?
643                  if ($format =~ /$LOOKUP_REGEX/o) {                  if ($format =~ /$LOOKUP_REGEX/o) {
644                          $log->debug("format '$format' has lookup");                          $log->debug("format '$format' has lookup");
# Line 483  sub parse { Line 721  sub parse {
721    
722          $i = 0 if (! $i);          $i = 0 if (! $i);
723    
724          my $format = $self->{'utf2cp'}->convert($format_utf8) || $log->logconfess("can't convert '$format_utf8' from UTF-8 to ",$self->{'code_page'});          my $format = $self->_x($format_utf8) || $log->logconfess("can't convert '$format_utf8' from UTF-8 to ",$self->{'code_page'});
725    
726          my @out;          my @out;
727    
# Line 493  sub parse { Line 731  sub parse {
731          # remove eval{...} from beginning          # remove eval{...} from beginning
732          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
733    
734            my $filter_name;
735            # remove filter{...} from beginning
736            $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
737    
738          my $prefix;          my $prefix;
739          my $all_found=0;          my $all_found=0;
740    
741          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))?//s) {          while ($format =~ s/^(.*?)(v|s)(\d+)(?:\^(\w))?//s) {
742    
743                  my $del = $1 || '';                  my $del = $1 || '';
744                  $prefix ||= $del if ($all_found == 0);                  $prefix ||= $del if ($all_found == 0);
745    
746                    # repeatable index
747                    my $r = $i;
748                    $r = 0 if (lc("$2") eq 's');
749    
750                  my $found = 0;                  my $found = 0;
751                  my $tmp = $self->get_data(\$rec,$2,$3,$i,\$found);                  my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found);
752    
753                  if ($found) {                  if ($found) {
754                          push @out, $del;                          push @out, $del;
# Line 526  sub parse { Line 772  sub parse {
772          }          }
773    
774          if ($eval_code) {          if ($eval_code) {
775                  my $eval = $self->fill_in($rec,$eval_code,$i);                  my $eval = $self->fill_in($rec,$eval_code,$i) || return;
776                  $log->debug("about to eval{",$eval,"} format: $out");                  $log->debug("about to eval{$eval} format: $out");
777                  return if (! $self->_eval($eval));                  return if (! $self->_eval($eval));
778          }          }
779            
780            if ($filter_name && $self->{'filter'}->{$filter_name}) {
781                    $log->debug("about to filter{$filter_name} format: $out");
782                    $out = $self->{'filter'}->{$filter_name}->($out);
783                    return unless(defined($out));
784                    $log->debug("filter result: $out");
785            }
786    
787          return $out;          return $out;
788  }  }
# Line 596  sub fill_in_to_arr { Line 849  sub fill_in_to_arr {
849          return @arr;          return @arr;
850  }  }
851    
852    =head2 sort_arr
853    
854    Sort array ignoring case and html in data
855    
856     my @sorted = $webpac->sort_arr(@unsorted);
857    
858    =cut
859    
860    sub sort_arr {
861            my $self = shift;
862    
863            my $log = $self->_get_logger();
864    
865            # FIXME add Schwartzian Transformation?
866    
867            my @sorted = sort {
868                    $a =~ s#<[^>]+/*>##;
869                    $b =~ s#<[^>]+/*>##;
870                    lc($b) cmp lc($a)
871            } @_;
872            $log->debug("sorted values: ",sub { join(", ",@sorted) });
873    
874            return @sorted;
875    }
876    
877    
878  =head2 data_structure  =head2 data_structure
879    
# Line 605  It is used later to produce output. Line 883  It is used later to produce output.
883   my @ds = $webpac->data_structure($rec);   my @ds = $webpac->data_structure($rec);
884    
885  This method will also set C<$webpac->{'currnet_filename'}> if there is  This method will also set C<$webpac->{'currnet_filename'}> if there is
886  <filename> tag in C<import_xml>.  <filename> tag in C<import_xml> and C<$webpac->{'headline'}> if there is
887    <headline> tag.
888    
889  =cut  =cut
890    
# Line 618  sub data_structure { Line 897  sub data_structure {
897          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
898    
899          undef $self->{'currnet_filename'};          undef $self->{'currnet_filename'};
900            undef $self->{'headline'};
901    
902          my @sorted_tags;          my @sorted_tags;
903          if ($self->{tags_by_order}) {          if ($self->{tags_by_order}) {
# Line 650  sub data_structure { Line 930  sub data_structure {
930                          }                          }
931                          next if (! @v);                          next if (! @v);
932    
933                          # does tag have type?                          if ($tag->{'sort'}) {
934                          if ($tag->{'type'}) {                                  @v = $self->sort_arr(@v);
935                                  push @{$row->{$tag->{'type'}}}, @v;                          }
936                          } else {  
937                                  push @{$row->{'display'}}, @v;                          # use format?
938                                  push @{$row->{'swish'}}, @v;                          if ($tag->{'format_name'}) {
939                                    @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
940                          }                          }
941    
942                          if ($field eq 'filename') {                          if ($field eq 'filename') {
943                                  $self->{'current_filename'} = join('',@v);                                  $self->{'current_filename'} = join('',@v);
944                                  $log->debug("filename: ",$self->{'current_filename'});                                  $log->debug("filename: ",$self->{'current_filename'});
945                            } elsif ($field eq 'headline') {
946                                    $self->{'headline'} .= join('',@v);
947                                    $log->debug("headline: ",$self->{'headline'});
948                                    next; # don't return headline in data_structure!
949                            }
950    
951                            # delimiter will join repeatable fields
952                            if ($tag->{'delimiter'}) {
953                                    @v = ( join($tag->{'delimiter'}, @v) );
954                            }
955    
956                            # default types
957                            my @types = qw(display swish);
958                            # override by type attribute
959                            @types = ( $tag->{'type'} ) if ($tag->{'type'});
960    
961                            foreach my $type (@types) {
962                                    # append to previous line?
963                                    $log->debug("type: $type ",sub { join(" ",@v) }, $row->{'append'} || 'no append');
964                                    if ($tag->{'append'}) {
965    
966                                            # I will delimit appended part with
967                                            # delimiter (or ,)
968                                            my $d = $tag->{'delimiter'};
969                                            # default delimiter
970                                            $d ||= " ";
971    
972                                            my $last = pop @{$row->{$type}};
973                                            $d = "" if (! $last);
974                                            $last .= $d . join($d, @v);
975                                            push @{$row->{$type}}, $last;
976    
977                                    } else {
978                                            push @{$row->{$type}}, @v;
979                                    }
980                          }                          }
981    
982    
983                  }                  }
984    
985                  if ($row) {                  if ($row) {
986                          $row->{'tag'} = $field;                          $row->{'tag'} = $field;
987    
988                            # TODO: name_sigular, name_plural
989                            my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
990                            $row->{'name'} = $name ? $self->_x($name) : $field;
991    
992                            # post-sort all values in field
993                            if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {
994                                    $log->warn("sort at field tag not implemented");
995                            }
996    
997                          push @ds, $row;                          push @ds, $row;
998    
999                          $log->debug("row $field: ",sub { Dumper($row) });                          $log->debug("row $field: ",sub { Dumper($row) });
# Line 707  sub output { Line 1034  sub output {
1034          return $out;          return $out;
1035  }  }
1036    
1037    =head2 output_file
1038    
1039    Create output from in-memory data structure using Template Toolkit template
1040    to a file.
1041    
1042     $webpac->output_file(
1043            file => 'out.txt',
1044            template => 'text.tt',
1045            data => @ds
1046     );
1047    
1048    =cut
1049    
1050    sub output_file {
1051            my $self = shift;
1052    
1053            my $args = {@_};
1054    
1055            my $log = $self->_get_logger();
1056    
1057            my $file = $args->{'file'} || $log->logconfess("need file name");
1058    
1059            $log->debug("creating file ",$file);
1060    
1061            open(my $fh, ">", $file) || $log->logdie("can't open output file '$file': $!");
1062            print $fh $self->output(
1063                    template => $args->{'template'},
1064                    data => $args->{'data'},
1065            ) || $log->logdie("print: $!");
1066            close($fh) || $log->logdie("close: $!");
1067    }
1068    
1069    =head2 apply_format
1070    
1071    Apply format specified in tag with C<format_name="name"> and
1072    C<format_delimiter=";;">.
1073    
1074     my $text = $webpac->apply_format($format_name,$format_delimiter,$data);
1075    
1076    Formats can contain C<lookup{...}> if you need them.
1077    
1078    =cut
1079    
1080    sub apply_format {
1081            my $self = shift;
1082    
1083            my ($name,$delimiter,$data) = @_;
1084    
1085            my $log = $self->_get_logger();
1086    
1087            if (! $self->{'import_xml'}->{'format'}->{$name}) {
1088                    $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});
1089                    return $data;
1090            }
1091    
1092            $log->warn("no delimiter for format $name") if (! $delimiter);
1093    
1094            my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");
1095    
1096            my @data = split(/\Q$delimiter\E/, $data);
1097    
1098            my $out = sprintf($format, @data);
1099            $log->debug("using format $name [$format] on $data to produce: $out");
1100    
1101            if ($out =~ m/$LOOKUP_REGEX/o) {
1102                    return $self->lookup($out);
1103            } else {
1104                    return $out;
1105            }
1106    
1107    }
1108    
1109    
1110  #  #
1111  #  #
1112  #  #
# Line 739  sub _eval { Line 1139  sub _eval {
1139    
1140          $log->debug("eval: ",$code," [",$ret,"]");          $log->debug("eval: ",$code," [",$ret,"]");
1141    
1142          return $ret || 0;          return $ret || undef;
1143  }  }
1144    
1145  =head2 _sort_by_order  =head2 _sort_by_order
# Line 759  sub _sort_by_order { Line 1159  sub _sort_by_order {
1159          return $va <=> $vb;          return $va <=> $vb;
1160  }  }
1161    
1162    =head2 _get_logger
1163    
1164    Get C<Log::Log4perl> object with a twist: domains are defined for each
1165    method
1166    
1167     my $log = $webpac->_get_logger();
1168    
1169    =cut
1170    
1171  sub _get_logger {  sub _get_logger {
1172          my $self = shift;          my $self = shift;
1173    
# Line 766  sub _get_logger { Line 1175  sub _get_logger {
1175          return get_logger($name);          return get_logger($name);
1176  }  }
1177    
1178    =head2 _x
1179    
1180    Convert string from UTF-8 to code page defined in C<import_xml>.
1181    
1182     my $text = $webpac->_x('utf8 text');
1183    
1184    =cut
1185    
1186    sub _x {
1187            my $self = shift;
1188            my $utf8 = shift || return;
1189    
1190            return $self->{'utf2cp'}->convert($utf8) ||
1191                    $self->_get_logger()->logwarn("can't convert '$utf8'");
1192    }
1193    
1194  #  #
1195  #  #
1196  #  #
# Line 784  B<This is different from normal Log4perl Line 1209  B<This is different from normal Log4perl
1209  also use method names, and not only classes (which are just few)  also use method names, and not only classes (which are just few)
1210  to filter logging.  to filter logging.
1211    
1212    
1213    =head1 MEMORY USAGE
1214    
1215    C<low_mem> options is double-edged sword. If enabled, WebPAC
1216    will run on memory constraint machines (which doesn't have enough
1217    physical RAM to create memory structure for whole source database).
1218    
1219    If your machine has 512Mb or more of RAM and database is around 10000 records,
1220    memory shouldn't be an issue. If you don't have enough physical RAM, you
1221    might consider using virtual memory (if your operating system is handling it
1222    well, like on FreeBSD or Linux) instead of dropping to L<DBD::Deep> to handle
1223    parsed structure of ISIS database (this is what C<low_mem> option does).
1224    
1225    Hitting swap at end of reading source database is probably o.k. However,
1226    hitting swap before 90% will dramatically decrease performance and you will
1227    be better off with C<low_mem> and using rest of availble memory for
1228    operating system disk cache (Linux is particuallary good about this).
1229    However, every access to database record will require disk access, so
1230    generation phase will be slower 10-100 times.
1231    
1232    Parsed structures are essential - you just have option to trade RAM memory
1233    (which is fast) for disk space (which is slow). Be sure to have planty of
1234    disk space if you are using C<low_mem> and thus L<DBD::Deep>.
1235    
1236    However, when WebPAC is running on desktop machines (or laptops :-), it's
1237    highly undesireable for system to start swapping. Using C<low_mem> option can
1238    reduce WecPAC memory usage to around 64Mb for same database with lookup
1239    fields and sorted indexes which stay in RAM. Performance will suffer, but
1240    memory usage will really be minimal. It might be also more confortable to
1241    run WebPAC reniced on those machines.
1242    
1243  =cut  =cut
1244    
1245  1;  1;
Legend:
Removed from v.374  
changed lines
  Added in v.705
  ViewVC Help
Powered by ViewVC 1.1.26