/[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 372 by dpavlin, Sat Jun 19 18:16:20 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 = '\[[^\[\]]+\]';
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 24  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 54  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 95  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 144  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 152  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            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 $isis_db = OpenIsis::open($arg->{'filename'});  
243    
244          my $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;          my $startmfn = 1;
245    
246          $maxmfn = $self->{limit_mfn} if ($self->{limit_mfn});          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                  # read record                  $log->debug("mfn: $mfn\n");
263                  my $row = OpenIsis::read( $isis_db, $mfn );  
264                  foreach my $k (keys %{$row}) {                  my $rec;
265                          if ($k ne "mfn") {  
266                                  foreach my $l (@{$row->{$k}}) {                  if ($have_openisis) {
267                                          $l = $cp->convert($l);  
268                                          # has subfields?                          # read record using OpenIsis
269                                          my $val;                          my $row = OpenIsis::read( $isis_db, $mfn );
270                                          if ($l =~ m/\^/) {                          foreach my $k (keys %{$row}) {
271                                                  foreach my $t (split(/\^/,$l)) {                                  if ($k ne "mfn") {
272                                                          next if (! $t);                                          foreach my $l (@{$row->{$k}}) {
273                                                          $val->{substr($t,0,1)} = substr($t,1);                                                  $l = $cp->convert($l);
274                                                    # has subfields?
275                                                    my $val;
276                                                    if ($l =~ m/\^/) {
277                                                            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                                  }                                  }
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 213  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'};
349                    $log->debug("at EOF");
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 246  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' ],
                 ForceContent => 1  
477          );          );
478    
479            $log->debug("import xml is ",sub { Dumper($self->{'import_xml'}) });
480    
481  }  }
482    
483  =head2 create_lookup  =head2 create_lookup
# Line 279  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) });
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                                  push @{$self->{'lookup'}->{$key}}, @val;                          push @{$self->{'lookup'}->{$key}}, @val;
                         }  
519                  }                  }
520          }          }
521  }  }
# Line 322  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 362  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 374  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          $format =~ s/v(\d+)(?:\^(\w))*/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;          # repeatable fields
626            $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");
632                  if ($eval_code) {                  if ($eval_code) {
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                  $log->debug("test format '$format' for lookups");                  if ($format =~ /$LOOKUP_REGEX/o) {
644                  if ($format =~ /\[[^\[\]]+\]/o) {                          $log->debug("format '$format' has lookup");
645                          return $self->lookup($format);                          return $self->lookup($format);
646                  } else {                  } else {
647                          return $format;                          return $format;
# Line 420  sub lookup { Line 668  sub lookup {
668    
669          my $tmp = shift || $log->logconfess("need format");          my $tmp = shift || $log->logconfess("need format");
670    
671          if ($tmp =~ /\[[^\[\]]+\]/o) {          if ($tmp =~ /$LOOKUP_REGEX/o) {
672                  my @in = ( $tmp );                  my @in = ( $tmp );
673    
674                  $log->debug("lookup for: ",$tmp);                  $log->debug("lookup for: ",$tmp);
675    
676                  my @out;                  my @out;
677                  while (my $f = shift @in) {                  while (my $f = shift @in) {
678                          if ($f =~ /\[([^\[\]]+)\]/) {                          if ($f =~ /$LOOKUP_REGEX_SAVE/o) {
679                                  my $k = $1;                                  my $k = $1;
680                                  if ($self->{'lookup'}->{$k}) {                                  if ($self->{'lookup'}->{$k}) {
681                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {
682                                                  my $tmp2 = $f;                                                  my $tmp2 = $f;
683                                                  $tmp2 =~ s/\[$k\]/$nv/g;                                                  $tmp2 =~ s/lookup{$k}/$nv/g;
684                                                  push @in, $tmp2;                                                  push @in, $tmp2;
685                                          }                                          }
686                                  } else {                                  } else {
# Line 442  sub lookup { Line 690  sub lookup {
690                                  push @out, $f;                                  push @out, $f;
691                          }                          }
692                  }                  }
693                    $log->logconfess("return is array and it's not expected!") unless wantarray;
694                  return @out;                  return @out;
695          } else {          } else {
696                  return $tmp;                  return $tmp;
# Line 472  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    
728            $log->debug("format: $format");
729    
730          my $eval_code;          my $eval_code;
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 500  sub parse { Line 759  sub parse {
759    
760          return if (! $all_found);          return if (! $all_found);
761    
762          my $out = join('',@out) . $format;          my $out = join('',@out);
763    
764            if ($out) {
765                    # add rest of format (suffix)
766                    $out .= $format;
767    
768                    # add prefix if not there
769                    $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);
770    
771          # add prefix if not there                  $log->debug("result: $out");
772          $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);          }
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," [$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 539  sub parse_to_arr { Line 812  sub parse_to_arr {
812                  push @arr, $v;                  push @arr, $v;
813          }          }
814    
815            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
816    
817            return @arr;
818    }
819    
820    =head2 fill_in_to_arr
821    
822    Similar to C<fill_in>, but returns array of all repeatable fields. Usable
823    for fields which have lookups, so they shouldn't be parsed but rather
824    C<fill_id>ed.
825    
826     my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]');
827    
828    =cut
829    
830    sub fill_in_to_arr {
831            my $self = shift;
832    
833            my ($rec, $format_utf8) = @_;
834    
835            my $log = $self->_get_logger();
836    
837            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
838            return if (! $format_utf8);
839    
840            my $i = 0;
841            my @arr;
842    
843            while (my @v = $self->fill_in($rec,$format_utf8,$i++)) {
844                    push @arr, @v;
845            }
846    
847            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
848    
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    
880  Create in-memory data structure which represents layout from C<import_xml>.  Create in-memory data structure which represents layout from C<import_xml>.
# Line 549  It is used later to produce output. Line 882  It is used later to produce output.
882    
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
886    <filename> tag in C<import_xml> and C<$webpac->{'headline'}> if there is
887    <headline> tag.
888    
889  =cut  =cut
890    
891  sub data_structure {  sub data_structure {
# Line 559  sub data_structure { Line 896  sub data_structure {
896          my $rec = shift;          my $rec = shift;
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'};
900            undef $self->{'headline'};
901    
902          my @sorted_tags;          my @sorted_tags;
903          if ($self->{tags_by_order}) {          if ($self->{tags_by_order}) {
904                  @sorted_tags = @{$self->{tags_by_order}};                  @sorted_tags = @{$self->{tags_by_order}};
# Line 569  sub data_structure { Line 909  sub data_structure {
909    
910          my @ds;          my @ds;
911    
912            $log->debug("tags: ",sub { join(", ",@sorted_tags) });
913    
914          foreach my $field (@sorted_tags) {          foreach my $field (@sorted_tags) {
915    
916                  my $row;                  my $row;
# Line 576  sub data_structure { Line 918  sub data_structure {
918  #print "field $field [",$self->{'tag'},"] = ",Dumper($self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}});  #print "field $field [",$self->{'tag'},"] = ",Dumper($self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}});
919    
920                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
921                          my @v = $self->parse_to_arr($rec,$tag->{'content'});                          my $format = $tag->{'value'} || $tag->{'content'};
922    
923                          next if (! @v);                          $log->debug("format: $format");
924    
925                          # does tag have type?                          my @v;
926                          if ($tag->{'type'}) {                          if ($format =~ /$LOOKUP_REGEX/o) {
927                                  push @{$row->{$tag->{'type'}}}, @v;                                  @v = $self->fill_in_to_arr($rec,$format);
928                          } else {                          } else {
929                                  push @{$row->{'display'}}, @v;                                  @v = $self->parse_to_arr($rec,$format);
930                                  push @{$row->{'swish'}}, @v;                          }
931                            next if (! @v);
932    
933                            if ($tag->{'sort'}) {
934                                    @v = $self->sort_arr(@v);
935                            }
936    
937                            # use format?
938                            if ($tag->{'format_name'}) {
939                                    @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
940                            }
941    
942                            if ($field eq 'filename') {
943                                    $self->{'current_filename'} = join('',@v);
944                                    $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) });
1000                  }                  }
1001    
1002          }          }
# Line 629  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 661  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 681  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    
1174          my @c = caller(1);          my $name = (caller(1))[3] || caller;
1175          return get_logger($c[3]);          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  #  #
# Line 706  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.372  
changed lines
  Added in v.705
  ViewVC Help
Powered by ViewVC 1.1.26