/[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 616 by dpavlin, Fri Dec 31 03:34:33 2004 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 $LOOKUP_REGEX = '\[[^\[\]]+\]';
17    #my $LOOKUP_REGEX_SAVE = '\[([^\[\]]+)\]';
18    my $LOOKUP_REGEX = 'lookup{[^\{\}]+}';
19    my $LOOKUP_REGEX_SAVE = 'lookup{([^\{\}]+)}';
20    
21  =head1 NAME  =head1 NAME
22    
23  WebPAC - base class for WebPAC  WebPAC - base class for WebPAC
# Line 24  This module implements methods used by W Line 30  This module implements methods used by W
30    
31  =head2 new  =head2 new
32    
33  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>.
34    
35   my $webpac = new WebPAC(   my $webpac = new WebPAC(
36          config_file => 'name.conf',          config_file => 'name.conf',
37          [code_page => 'ISO-8859-2',]          code_page => 'ISO-8859-2',
38            low_mem => 1,
39            filter => {
40                    'lower' => sub { lc($_[0]) },
41            },
42   );   );
43    
44  Default C<code_page> is C<ISO-8859-2>.  Default C<code_page> is C<ISO-8859-2>.
45    
46  It will also read configuration files  Default is not to use C<low_mem> options (see L<MEMORY USAGE> below).
47    
48    There is optinal parametar C<filter> which specify different filters which
49    can be applied using C<filter{name}> notation.
50    Same filters can be used in Template Toolkit files.
51    
52    This method will also read configuration files
53  C<global.conf> (used by indexer and Web font-end)  C<global.conf> (used by indexer and Web font-end)
54  and configuration file specified by C<config_file>  and configuration file specified by C<config_file>
55  which describes databases to be indexed.  which describes databases to be indexed.
# Line 54  sub new { Line 70  sub new {
70          my $self = {@_};          my $self = {@_};
71          bless($self, $class);          bless($self, $class);
72    
73            $self->{'start_t'} = time();
74    
75          my $log_file = $self->{'log'} || "log.conf";          my $log_file = $self->{'log'} || "log.conf";
76          Log::Log4perl->init($log_file);          Log::Log4perl->init($log_file);
77    
# Line 95  sub new { Line 113  sub new {
113          # create Template toolkit instance          # create Template toolkit instance
114          $self->{'tt'} = Template->new(          $self->{'tt'} = Template->new(
115                  INCLUDE_PATH => ($self->{'global_config_file'}->{'output_template'} || './output_template'),                  INCLUDE_PATH => ($self->{'global_config_file'}->{'output_template'} || './output_template'),
116  #               FILTERS => {                  FILTERS => $self->{'filter'},
 #                       'foo' => \&foo_filter,  
 #               },  
117                  EVAL_PERL => 1,                  EVAL_PERL => 1,
118          );          );
119    
120            # running with low_mem flag? well, use DBM::Deep then.
121            if ($self->{'low_mem'}) {
122                    $log->info("running with low_mem which impacts performance (<32 Mb memory usage)");
123    
124                    my $db_file = "data.db";
125    
126                    if (-e $db_file) {
127                            unlink $db_file or $log->logdie("can't remove '$db_file' from last run");
128                            $log->debug("removed '$db_file' from last run");
129                    }
130    
131                    require DBM::Deep;
132    
133                    my $db = new DBM::Deep $db_file;
134    
135                    $log->logdie("DBM::Deep error: $!") unless ($db);
136    
137                    if ($db->error()) {
138                            $log->logdie("can't open '$db_file' under low_mem: ",$db->error());
139                    } else {
140                            $log->debug("using file '$db_file' for DBM::Deep");
141                    }
142    
143                    $self->{'db'} = $db;
144            }
145    
146            $log->debug("filters defined: ",Dumper($self->{'filter'}));
147    
148          return $self;          return $self;
149  }  }
150    
151  =head2 open_isis  =head2 open_isis
152    
153  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
154    and read all records to memory.
155    
156   $webpac->open_isis(   $webpac->open_isis(
157          filename => '/data/ISIS/ISIS',          filename => '/data/ISIS/ISIS',
158          code_page => '852',          code_page => '852',
159          limit_mfn => '500',          limit_mfn => 500,
160            start_mfn => 6000,
161          lookup => [ ... ],          lookup => [ ... ],
162   );   );
163    
164  By default, ISIS code page is assumed to be C<852>.  By default, ISIS code page is assumed to be C<852>.
165    
166    If optional parametar C<start_mfn> is set, this will be first MFN to read
167    from database (so you can skip beginning of your database if you need to).
168    
169  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
170  from database in example above.  from database in example above.
171    
# Line 144  sub open_isis { Line 193  sub open_isis {
193          $log->logcroak("need filename") if (! $arg->{'filename'});          $log->logcroak("need filename") if (! $arg->{'filename'});
194          my $code_page = $arg->{'code_page'} || '852';          my $code_page = $arg->{'code_page'} || '852';
195    
196          use OpenIsis;          $log->logdie("can't find database ",$arg->{'filename'}) unless (glob($arg->{'filename'}.'.*'));
197    
198            # store data in object
199            $self->{'isis_filename'} = $arg->{'filename'};
200            $self->{'isis_code_page'} = $code_page;
201    
202          #$self->{'isis_code_page'} = $code_page;          #$self->{'isis_code_page'} = $code_page;
203    
# Line 152  sub open_isis { Line 205  sub open_isis {
205          my $cp = Text::Iconv->new($code_page,$self->{'code_page'});          my $cp = Text::Iconv->new($code_page,$self->{'code_page'});
206    
207          $log->info("reading ISIS database '",$arg->{'filename'},"'");          $log->info("reading ISIS database '",$arg->{'filename'},"'");
208            $log->debug("isis code page: $code_page");
209    
210            my $use_openisis = 1;
211    
212            eval { use IsisDB 0.06; };
213            $use_openisis = 0 unless ($@);
214    
215            my ($isis_db,$maxmfn);
216    
217            if ($use_openisis) {
218                    use OpenIsis;
219                    $isis_db = OpenIsis::open($arg->{'filename'});
220                    $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;
221            } else {
222                    $isis_db = new IsisDB(
223                            isisdb => $arg->{'filename'},
224                            include_deleted => 1,
225                            hash_filter => sub {
226                                    my $l = shift || return;
227                                    $l = $cp->convert($l);
228                                    return $l;
229                            },
230                    );
231                    $maxmfn = $isis_db->{'maxmfn'};
232            }
233    
234    
235          my $isis_db = OpenIsis::open($arg->{'filename'});          my $startmfn = 1;
236    
237          my $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;          if (my $s = $self->{'start_mfn'}) {
238                    $log->info("skipping to MFN $s");
239                    $startmfn = $s;
240            } else {
241                    $self->{'start_mfn'} = $startmfn;
242            }
243    
244          $maxmfn = $self->{limit_mfn} if ($self->{limit_mfn});          $maxmfn = $startmfn + $self->{limit_mfn} if ($self->{limit_mfn});
245    
246            $log->info("processing ",($maxmfn-$startmfn)." records using ",( $use_openisis ? 'OpenIsis' : 'IsisDB'));
247    
         $log->info("processing $maxmfn records...");  
248    
249          # read database          # read database
250          for (my $mfn = 1; $mfn <= $maxmfn; $mfn++) {          for (my $mfn = $startmfn; $mfn <= $maxmfn; $mfn++) {
251    
252    
253                    $log->debug("mfn: $mfn\n");
254    
255                  # read record                  my $rec;
256                  my $row = OpenIsis::read( $isis_db, $mfn );  
257                  foreach my $k (keys %{$row}) {                  if ($use_openisis) {
258                          if ($k ne "mfn") {  
259                                  foreach my $l (@{$row->{$k}}) {                          # read record using OpenIsis
260                                          $l = $cp->convert($l);                          my $row = OpenIsis::read( $isis_db, $mfn );
261                                          # has subfields?                          foreach my $k (keys %{$row}) {
262                                          my $val;                                  if ($k ne "mfn") {
263                                          if ($l =~ m/\^/) {                                          foreach my $l (@{$row->{$k}}) {
264                                                  foreach my $t (split(/\^/,$l)) {                                                  $l = $cp->convert($l);
265                                                          next if (! $t);                                                  # has subfields?
266                                                          $val->{substr($t,0,1)} = substr($t,1);                                                  my $val;
267                                                    if ($l =~ m/\^/) {
268                                                            foreach my $t (split(/\^/,$l)) {
269                                                                    next if (! $t);
270                                                                    $val->{substr($t,0,1)} = substr($t,1);
271                                                            }
272                                                    } else {
273                                                            $val = $l;
274                                                  }                                                  }
                                         } else {  
                                                 $val = $l;  
                                         }  
275    
276                                          push @{$self->{'data'}->{$mfn}->{$k}}, $val;                                                  push @{$rec->{$k}}, $val;
277                                            }
278                                    } else {
279                                            push @{$rec->{'000'}}, $mfn;
280                                  }                                  }
281                          }                          }
282    
283                    } else {
284                            $rec = $isis_db->to_hash($mfn);
285                    }
286    
287                    $log->confess("record $mfn empty?") unless ($rec);
288    
289                    # store
290                    if ($self->{'low_mem'}) {
291                            $self->{'db'}->put($mfn, $rec);
292                    } else {
293                            $self->{'data'}->{$mfn} = $rec;
294                  }                  }
295    
296                  # create lookup                  # create lookup
                 my $rec = $self->{'data'}->{$mfn};  
297                  $self->create_lookup($rec, @{$arg->{'lookup'}});                  $self->create_lookup($rec, @{$arg->{'lookup'}});
298    
299                    $self->progress_bar($mfn,$maxmfn);
300    
301          }          }
302    
303          $self->{'current_mfn'} = 1;          $self->{'current_mfn'} = -1;
304            $self->{'last_pcnt'} = 0;
305    
306            $log->debug("max mfn: $maxmfn");
307    
308          # store max mfn and return it.          # store max mfn and return it.
309          return $self->{'max_mfn'} = $maxmfn;          return $self->{'max_mfn'} = $maxmfn;
# Line 213  sub fetch_rec { Line 323  sub fetch_rec {
323    
324          my $log = $self->_get_logger();          my $log = $self->_get_logger();
325    
326          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'});
327    
328            if ($self->{'current_mfn'} == -1) {
329                    $self->{'current_mfn'} = $self->{'start_mfn'};
330            } else {
331                    $self->{'current_mfn'}++;
332            }
333    
334            my $mfn = $self->{'current_mfn'};
335    
336          if ($mfn > $self->{'max_mfn'}) {          if ($mfn > $self->{'max_mfn'}) {
337                  $self->{'current_mfn'} = $self->{'max_mfn'};                  $self->{'current_mfn'} = $self->{'max_mfn'};
338                    $log->debug("at EOF");
339                  return;                  return;
340          }          }
341    
342          return $self->{'data'}->{$mfn};          $self->progress_bar($mfn,$self->{'max_mfn'});
343    
344            if ($self->{'low_mem'}) {
345                    return $self->{'db'}->get($mfn);
346            } else {
347                    return $self->{'data'}->{$mfn};
348            }
349    }
350    
351    =head2 mfn
352    
353    Returns current record number (MFN).
354    
355     print $webpac->mfn;
356    
357    =cut
358    
359    sub mfn {
360            my $self = shift;
361            return $self->{'current_mfn'};
362    }
363    
364    =head2 progress_bar
365    
366    Draw progress bar on STDERR.
367    
368     $webpac->progress_bar($current, $max);
369    
370    =cut
371    
372    sub progress_bar {
373            my $self = shift;
374    
375            my ($curr,$max) = @_;
376    
377            my $log = $self->_get_logger();
378    
379            $log->logconfess("no current value!") if (! $curr);
380            $log->logconfess("no maximum value!") if (! $max);
381    
382            if ($curr > $max) {
383                    $max = $curr;
384                    $log->debug("overflow to $curr");
385            }
386    
387            $self->{'last_pcnt'} ||= 1;
388    
389            my $p = int($curr * 100 / $max) || 1;
390    
391            # reset on re-run
392            if ($p < $self->{'last_pcnt'}) {
393                    $self->{'last_pcnt'} = $p;
394                    $self->{'start_t'} = time();
395            }
396    
397            if ($p != $self->{'last_pcnt'}) {
398    
399                    my $t = time();
400                    my $rate = ($curr / ($t - $self->{'start_t'} || 1));
401                    my $eta = ($max-$curr) / ($rate || 1);
402                    printf STDERR ("%5d [%-38s] %-5d %0.1f/s %s\r",$curr,"=" x ($p/3)."$p%>", $max, $rate, $self->fmt_time($eta));
403                    $self->{'last_pcnt'} = $p;
404                    $self->{'last_curr'} = $curr;
405            }
406            print STDERR "\n" if ($p == 100);
407    }
408    
409    =head2 fmt_time
410    
411    Format time (in seconds) for display.
412    
413     print $webpac->fmt_time(time());
414    
415    This method is called by L<progress_bar> to display remaining time.
416    
417    =cut
418    
419    sub fmt_time {
420            my $self = shift;
421    
422            my $t = shift || 0;
423            my $out = "";
424    
425            my ($ss,$mm,$hh) = gmtime($t);
426            $out .= "${hh}h" if ($hh);
427            $out .= sprintf("%02d:%02d", $mm,$ss);
428            $out .= "  " if ($hh == 0);
429            return $out;
430  }  }
431    
432  =head2 open_import_xml  =head2 open_import_xml
# Line 246  sub open_import_xml { Line 452  sub open_import_xml {
452    
453          $self->{'tag'} = $type2tag{$type_base};          $self->{'tag'} = $type2tag{$type_base};
454    
455          $log->debug("using type '",$self->{'type'},"' tag <",$self->{'tag'},">") if ($self->{'debug'});          $log->info("using type '",$self->{'type'},"' tag <",$self->{'tag'},">");
456    
457          my $f = "./import_xml/".$self->{'type'}.".xml";          my $f = "./import_xml/".$self->{'type'}.".xml";
458          $log->logconfess("import_xml file '$f' doesn't exist!") if (! -e "$f");          $log->logconfess("import_xml file '$f' doesn't exist!") if (! -e "$f");
459    
460          $log->debug("reading '$f'") if ($self->{'debug'});          $log->info("reading '$f'");
461    
462            $self->{'import_xml_file'} = $f;
463    
464          $self->{'import_xml'} = XMLin($f,          $self->{'import_xml'} = XMLin($f,
465                  ForceArray => [ $self->{'tag'}, 'config', 'format' ],                  ForceArray => [ $self->{'tag'}, 'config', 'format' ],
                 ForceContent => 1  
466          );          );
467    
468            $log->debug("import xml is ",sub { Dumper($self->{'import_xml'}) });
469    
470  }  }
471    
472  =head2 create_lookup  =head2 create_lookup
# Line 279  sub create_lookup { Line 488  sub create_lookup {
488          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
489    
490          foreach my $i (@_) {          foreach my $i (@_) {
491                  if ($i->{'eval'}) {                  $log->logconfess("need key") unless defined($i->{'key'});
492                          my $eval = $self->fill_in($rec,$i->{'eval'});                  $log->logconfess("need val") unless defined($i->{'val'});
493                          my $key = $self->fill_in($rec,$i->{'key'});  
494                          my @val = $self->fill_in($rec,$i->{'val'});                  if (defined($i->{'eval'})) {
495                          if ($key && @val && eval $eval) {                          # eval first, so we can skip fill_in for key and val
496                            my $eval = $self->fill_in($rec,$i->{'eval'}) || next;
497                            if ($self->_eval($eval)) {
498                                    my $key = $self->fill_in($rec,$i->{'key'}) || next;
499                                    my @val = $self->fill_in($rec,$i->{'val'}) || next;
500                                    $log->debug("stored $key = ",sub { join(" | ",@val) });
501                                  push @{$self->{'lookup'}->{$key}}, @val;                                  push @{$self->{'lookup'}->{$key}}, @val;
502                          }                          }
503                  } else {                  } else {
504                          my $key = $self->fill_in($rec,$i->{'key'});                          my $key = $self->fill_in($rec,$i->{'key'}) || next;
505                          my @val = $self->fill_in($rec,$i->{'val'});                          my @val = $self->fill_in($rec,$i->{'val'}) || next;
506                          if ($key && @val) {                          $log->debug("stored $key = ",sub { join(" | ",@val) });
507                                  push @{$self->{'lookup'}->{$key}}, @val;                          push @{$self->{'lookup'}->{$key}}, @val;
                         }  
508                  }                  }
509          }          }
510  }  }
# Line 322  sub get_data { Line 535  sub get_data {
535    
536          if ($$rec->{$f}) {          if ($$rec->{$f}) {
537                  return '' if (! $$rec->{$f}->[$i]);                  return '' if (! $$rec->{$f}->[$i]);
538                    no strict 'refs';
539                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {
540                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
541                          return $$rec->{$f}->[$i]->{$sf};                          return $$rec->{$f}->[$i]->{$sf};
# Line 362  Following example will read second value Line 576  Following example will read second value
576  This function B<does not> perform parsing of format to inteligenty skip  This function B<does not> perform parsing of format to inteligenty skip
577  delimiters before fields which aren't used.  delimiters before fields which aren't used.
578    
579    This method will automatically decode UTF-8 string to local code page
580    if needed.
581    
582  =cut  =cut
583    
584  sub fill_in {  sub fill_in {
# Line 374  sub fill_in { Line 591  sub fill_in {
591          # iteration (for repeatable fields)          # iteration (for repeatable fields)
592          my $i = shift || 0;          my $i = shift || 0;
593    
594            $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));
595    
596          # FIXME remove for speedup?          # FIXME remove for speedup?
597          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
598    
599            if (utf8::is_utf8($format)) {
600                    $format = $self->_x($format);
601            }
602    
603          my $found = 0;          my $found = 0;
604    
605          my $eval_code;          my $eval_code;
606          # remove eval{...} from beginning          # remove eval{...} from beginning
607          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
608    
609            my $filter_name;
610            # remove filter{...} from beginning
611            $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
612    
613          # do actual replacement of placeholders          # do actual replacement of placeholders
614          $format =~ s/v(\d+)(?:\^(\w))*/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;          # repeatable fields
615            $format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;
616            # non-repeatable fields
617            $format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found)/ges;
618    
619          if ($found) {          if ($found) {
620                    $log->debug("format: $format");
621                  if ($eval_code) {                  if ($eval_code) {
622                          my $eval = $self->fill_in($rec,$eval_code,$i);                          my $eval = $self->fill_in($rec,$eval_code,$i);
623                          return if (! $self->_eval($eval));                          return if (! $self->_eval($eval));
624                  }                  }
625                    if ($filter_name && $self->{'filter'}->{$filter_name}) {
626                            $log->debug("filter '$filter_name' for $format");
627                            $format = $self->{'filter'}->{$filter_name}->($format);
628                            return unless(defined($format));
629                            $log->debug("filter result: $format");
630                    }
631                  # do we have lookups?                  # do we have lookups?
632                  $log->debug("test format '$format' for lookups");                  if ($format =~ /$LOOKUP_REGEX/o) {
633                  if ($format =~ /\[[^\[\]]+\]/o) {                          $log->debug("format '$format' has lookup");
634                          return $self->lookup($format);                          return $self->lookup($format);
635                  } else {                  } else {
636                          return $format;                          return $format;
# Line 420  sub lookup { Line 657  sub lookup {
657    
658          my $tmp = shift || $log->logconfess("need format");          my $tmp = shift || $log->logconfess("need format");
659    
660          if ($tmp =~ /\[[^\[\]]+\]/o) {          if ($tmp =~ /$LOOKUP_REGEX/o) {
661                  my @in = ( $tmp );                  my @in = ( $tmp );
662    
663                  $log->debug("lookup for: ",$tmp);                  $log->debug("lookup for: ",$tmp);
664    
665                  my @out;                  my @out;
666                  while (my $f = shift @in) {                  while (my $f = shift @in) {
667                          if ($f =~ /\[([^\[\]]+)\]/) {                          if ($f =~ /$LOOKUP_REGEX_SAVE/o) {
668                                  my $k = $1;                                  my $k = $1;
669                                  if ($self->{'lookup'}->{$k}) {                                  if ($self->{'lookup'}->{$k}) {
670                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {
671                                                  my $tmp2 = $f;                                                  my $tmp2 = $f;
672                                                  $tmp2 =~ s/\[$k\]/$nv/g;                                                  $tmp2 =~ s/lookup{$k}/$nv/g;
673                                                  push @in, $tmp2;                                                  push @in, $tmp2;
674                                          }                                          }
675                                  } else {                                  } else {
# Line 442  sub lookup { Line 679  sub lookup {
679                                  push @out, $f;                                  push @out, $f;
680                          }                          }
681                  }                  }
682                    $log->logconfess("return is array and it's not expected!") unless wantarray;
683                  return @out;                  return @out;
684          } else {          } else {
685                  return $tmp;                  return $tmp;
# Line 472  sub parse { Line 710  sub parse {
710    
711          $i = 0 if (! $i);          $i = 0 if (! $i);
712    
713          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'});
714    
715          my @out;          my @out;
716    
717            $log->debug("format: $format");
718    
719          my $eval_code;          my $eval_code;
720          # remove eval{...} from beginning          # remove eval{...} from beginning
721          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
722    
723            my $filter_name;
724            # remove filter{...} from beginning
725            $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
726    
727          my $prefix;          my $prefix;
728          my $all_found=0;          my $all_found=0;
729    
730          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))*//s) {          while ($format =~ s/^(.*?)(v|s)(\d+)(?:\^(\w))?//s) {
731    
732                  my $del = $1 || '';                  my $del = $1 || '';
733                  $prefix ||= $del if ($all_found == 0);                  $prefix ||= $del if ($all_found == 0);
734    
735                    # repeatable index
736                    my $r = $i;
737                    $r = 0 if (lc("$2") eq 's');
738    
739                  my $found = 0;                  my $found = 0;
740                  my $tmp = $self->get_data(\$rec,$2,$3,$i,\$found);                  my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found);
741    
742                  if ($found) {                  if ($found) {
743                          push @out, $del;                          push @out, $del;
# Line 500  sub parse { Line 748  sub parse {
748    
749          return if (! $all_found);          return if (! $all_found);
750    
751          my $out = join('',@out) . $format;          my $out = join('',@out);
752    
753          # add prefix if not there          if ($out) {
754          $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);                  # add rest of format (suffix)
755                    $out .= $format;
756    
757                    # add prefix if not there
758                    $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);
759    
760                    $log->debug("result: $out");
761            }
762    
763          if ($eval_code) {          if ($eval_code) {
764                  my $eval = $self->fill_in($rec,$eval_code,$i);                  my $eval = $self->fill_in($rec,$eval_code,$i) || return;
765                  $log->debug("about to eval ",$eval," [$out]");                  $log->debug("about to eval{$eval} format: $out");
766                  return if (! $self->_eval($eval));                  return if (! $self->_eval($eval));
767          }          }
768            
769            if ($filter_name && $self->{'filter'}->{$filter_name}) {
770                    $log->debug("about to filter{$filter_name} format: $out");
771                    $out = $self->{'filter'}->{$filter_name}->($out);
772                    return unless(defined($out));
773                    $log->debug("filter result: $out");
774            }
775    
776          return $out;          return $out;
777  }  }
# Line 539  sub parse_to_arr { Line 801  sub parse_to_arr {
801                  push @arr, $v;                  push @arr, $v;
802          }          }
803    
804            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
805    
806          return @arr;          return @arr;
807  }  }
808    
809    =head2 fill_in_to_arr
810    
811    Similar to C<fill_in>, but returns array of all repeatable fields. Usable
812    for fields which have lookups, so they shouldn't be parsed but rather
813    C<fill_id>ed.
814    
815     my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]');
816    
817    =cut
818    
819    sub fill_in_to_arr {
820            my $self = shift;
821    
822            my ($rec, $format_utf8) = @_;
823    
824            my $log = $self->_get_logger();
825    
826            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
827            return if (! $format_utf8);
828    
829            my $i = 0;
830            my @arr;
831    
832            while (my @v = $self->fill_in($rec,$format_utf8,$i++)) {
833                    push @arr, @v;
834            }
835    
836            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
837    
838            return @arr;
839    }
840    
841    =head2 sort_arr
842    
843    Sort array ignoring case and html in data
844    
845     my @sorted = $webpac->sort_arr(@unsorted);
846    
847    =cut
848    
849    sub sort_arr {
850            my $self = shift;
851    
852            my $log = $self->_get_logger();
853    
854            # FIXME add Schwartzian Transformation?
855    
856            my @sorted = sort {
857                    $a =~ s#<[^>]+/*>##;
858                    $b =~ s#<[^>]+/*>##;
859                    lc($b) cmp lc($a)
860            } @_;
861            $log->debug("sorted values: ",sub { join(", ",@sorted) });
862    
863            return @sorted;
864    }
865    
866    
867  =head2 data_structure  =head2 data_structure
868    
869  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 871  It is used later to produce output.
871    
872   my @ds = $webpac->data_structure($rec);   my @ds = $webpac->data_structure($rec);
873    
874    This method will also set C<$webpac->{'currnet_filename'}> if there is
875    <filename> tag in C<import_xml> and C<$webpac->{'headline'}> if there is
876    <headline> tag.
877    
878  =cut  =cut
879    
880  sub data_structure {  sub data_structure {
# Line 559  sub data_structure { Line 885  sub data_structure {
885          my $rec = shift;          my $rec = shift;
886          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
887    
888            undef $self->{'currnet_filename'};
889            undef $self->{'headline'};
890    
891          my @sorted_tags;          my @sorted_tags;
892          if ($self->{tags_by_order}) {          if ($self->{tags_by_order}) {
893                  @sorted_tags = @{$self->{tags_by_order}};                  @sorted_tags = @{$self->{tags_by_order}};
# Line 569  sub data_structure { Line 898  sub data_structure {
898    
899          my @ds;          my @ds;
900    
901            $log->debug("tags: ",sub { join(", ",@sorted_tags) });
902    
903          foreach my $field (@sorted_tags) {          foreach my $field (@sorted_tags) {
904    
905                  my $row;                  my $row;
# Line 576  sub data_structure { Line 907  sub data_structure {
907  #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'}});
908    
909                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
910                          my @v = $self->parse_to_arr($rec,$tag->{'content'});                          my $format = $tag->{'value'} || $tag->{'content'};
911    
912                          next if (! @v);                          $log->debug("format: $format");
913    
914                          # does tag have type?                          my @v;
915                          if ($tag->{'type'}) {                          if ($format =~ /$LOOKUP_REGEX/o) {
916                                  push @{$row->{$tag->{'type'}}}, @v;                                  @v = $self->fill_in_to_arr($rec,$format);
917                          } else {                          } else {
918                                  push @{$row->{'display'}}, @v;                                  @v = $self->parse_to_arr($rec,$format);
919                                  push @{$row->{'swish'}}, @v;                          }
920                            next if (! @v);
921    
922                            if ($tag->{'sort'}) {
923                                    @v = $self->sort_arr(@v);
924                            }
925    
926                            # use format?
927                            if ($tag->{'format_name'}) {
928                                    @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
929                            }
930    
931                            if ($field eq 'filename') {
932                                    $self->{'current_filename'} = join('',@v);
933                                    $log->debug("filename: ",$self->{'current_filename'});
934                            } elsif ($field eq 'headline') {
935                                    $self->{'headline'} .= join('',@v);
936                                    $log->debug("headline: ",$self->{'headline'});
937                                    next; # don't return headline in data_structure!
938                            }
939    
940                            # delimiter will join repeatable fields
941                            if ($tag->{'delimiter'}) {
942                                    @v = ( join($tag->{'delimiter'}, @v) );
943                            }
944    
945                            # default types
946                            my @types = qw(display swish);
947                            # override by type attribute
948                            @types = ( $tag->{'type'} ) if ($tag->{'type'});
949    
950                            foreach my $type (@types) {
951                                    # append to previous line?
952                                    $log->debug("type: $type ",sub { join(" ",@v) }, $row->{'append'} || 'no append');
953                                    if ($tag->{'append'}) {
954    
955                                            # I will delimit appended part with
956                                            # delimiter (or ,)
957                                            my $d = $tag->{'delimiter'};
958                                            # default delimiter
959                                            $d ||= " ";
960    
961                                            my $last = pop @{$row->{$type}};
962                                            $d = "" if (! $last);
963                                            $last .= $d . join($d, @v);
964                                            push @{$row->{$type}}, $last;
965    
966                                    } else {
967                                            push @{$row->{$type}}, @v;
968                                    }
969                          }                          }
970    
971    
972                  }                  }
973    
974                  if ($row) {                  if ($row) {
975                          $row->{'tag'} = $field;                          $row->{'tag'} = $field;
976    
977                            # TODO: name_sigular, name_plural
978                            my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
979                            $row->{'name'} = $name ? $self->_x($name) : $field;
980    
981                            # post-sort all values in field
982                            if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {
983                                    $log->warn("sort at field tag not implemented");
984                            }
985    
986                          push @ds, $row;                          push @ds, $row;
987    
988                            $log->debug("row $field: ",sub { Dumper($row) });
989                  }                  }
990    
991          }          }
# Line 629  sub output { Line 1023  sub output {
1023          return $out;          return $out;
1024  }  }
1025    
1026    =head2 output_file
1027    
1028    Create output from in-memory data structure using Template Toolkit template
1029    to a file.
1030    
1031     $webpac->output_file(
1032            file => 'out.txt',
1033            template => 'text.tt',
1034            data => @ds
1035     );
1036    
1037    =cut
1038    
1039    sub output_file {
1040            my $self = shift;
1041    
1042            my $args = {@_};
1043    
1044            my $log = $self->_get_logger();
1045    
1046            my $file = $args->{'file'} || $log->logconfess("need file name");
1047    
1048            $log->debug("creating file ",$file);
1049    
1050            open(my $fh, ">", $file) || $log->logdie("can't open output file '$file': $!");
1051            print $fh $self->output(
1052                    template => $args->{'template'},
1053                    data => $args->{'data'},
1054            ) || $log->logdie("print: $!");
1055            close($fh) || $log->logdie("close: $!");
1056    }
1057    
1058    =head2 apply_format
1059    
1060    Apply format specified in tag with C<format_name="name"> and
1061    C<format_delimiter=";;">.
1062    
1063     my $text = $webpac->apply_format($format_name,$format_delimiter,$data);
1064    
1065    Formats can contain C<lookup{...}> if you need them.
1066    
1067    =cut
1068    
1069    sub apply_format {
1070            my $self = shift;
1071    
1072            my ($name,$delimiter,$data) = @_;
1073    
1074            my $log = $self->_get_logger();
1075    
1076            if (! $self->{'import_xml'}->{'format'}->{$name}) {
1077                    $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});
1078                    return $data;
1079            }
1080    
1081            $log->warn("no delimiter for format $name") if (! $delimiter);
1082    
1083            my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");
1084    
1085            my @data = split(/\Q$delimiter\E/, $data);
1086    
1087            my $out = sprintf($format, @data);
1088            $log->debug("using format $name [$format] on $data to produce: $out");
1089    
1090            if ($out =~ m/$LOOKUP_REGEX/o) {
1091                    return $self->lookup($out);
1092            } else {
1093                    return $out;
1094            }
1095    
1096    }
1097    
1098    
1099  #  #
1100  #  #
1101  #  #
# Line 661  sub _eval { Line 1128  sub _eval {
1128    
1129          $log->debug("eval: ",$code," [",$ret,"]");          $log->debug("eval: ",$code," [",$ret,"]");
1130    
1131          return $ret || 0;          return $ret || undef;
1132  }  }
1133    
1134  =head2 _sort_by_order  =head2 _sort_by_order
# Line 681  sub _sort_by_order { Line 1148  sub _sort_by_order {
1148          return $va <=> $vb;          return $va <=> $vb;
1149  }  }
1150    
1151    =head2 _get_logger
1152    
1153    Get C<Log::Log4perl> object with a twist: domains are defined for each
1154    method
1155    
1156     my $log = $webpac->_get_logger();
1157    
1158    =cut
1159    
1160  sub _get_logger {  sub _get_logger {
1161          my $self = shift;          my $self = shift;
1162    
1163          my @c = caller(1);          my $name = (caller(1))[3] || caller;
1164          return get_logger($c[3]);          return get_logger($name);
1165    }
1166    
1167    =head2 _x
1168    
1169    Convert string from UTF-8 to code page defined in C<import_xml>.
1170    
1171     my $text = $webpac->_x('utf8 text');
1172    
1173    =cut
1174    
1175    sub _x {
1176            my $self = shift;
1177            my $utf8 = shift || return;
1178    
1179            return $self->{'utf2cp'}->convert($utf8) ||
1180                    $self->_get_logger()->logwarn("can't convert '$utf8'");
1181  }  }
1182    
1183  #  #
# Line 706  B<This is different from normal Log4perl Line 1198  B<This is different from normal Log4perl
1198  also use method names, and not only classes (which are just few)  also use method names, and not only classes (which are just few)
1199  to filter logging.  to filter logging.
1200    
1201    
1202    =head1 MEMORY USAGE
1203    
1204    C<low_mem> options is double-edged sword. If enabled, WebPAC
1205    will run on memory constraint machines (which doesn't have enough
1206    physical RAM to create memory structure for whole source database).
1207    
1208    If your machine has 512Mb or more of RAM and database is around 10000 records,
1209    memory shouldn't be an issue. If you don't have enough physical RAM, you
1210    might consider using virtual memory (if your operating system is handling it
1211    well, like on FreeBSD or Linux) instead of dropping to L<DBD::Deep> to handle
1212    parsed structure of ISIS database (this is what C<low_mem> option does).
1213    
1214    Hitting swap at end of reading source database is probably o.k. However,
1215    hitting swap before 90% will dramatically decrease performance and you will
1216    be better off with C<low_mem> and using rest of availble memory for
1217    operating system disk cache (Linux is particuallary good about this).
1218    However, every access to database record will require disk access, so
1219    generation phase will be slower 10-100 times.
1220    
1221    Parsed structures are essential - you just have option to trade RAM memory
1222    (which is fast) for disk space (which is slow). Be sure to have planty of
1223    disk space if you are using C<low_mem> and thus L<DBD::Deep>.
1224    
1225    However, when WebPAC is running on desktop machines (or laptops :-), it's
1226    highly undesireable for system to start swapping. Using C<low_mem> option can
1227    reduce WecPAC memory usage to around 64Mb for same database with lookup
1228    fields and sorted indexes which stay in RAM. Performance will suffer, but
1229    memory usage will really be minimal. It might be also more confortable to
1230    run WebPAC reniced on those machines.
1231    
1232  =cut  =cut
1233    
1234  1;  1;
Legend:
Removed from v.372  
changed lines
  Added in v.616
  ViewVC Help
Powered by ViewVC 1.1.26