/[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 563 by dpavlin, Sat Oct 30 23:58:36 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    
# Line 111  Open CDS/ISIS database using OpenIsis mo Line 155  Open CDS/ISIS database using OpenIsis mo
155   $webpac->open_isis(   $webpac->open_isis(
156          filename => '/data/ISIS/ISIS',          filename => '/data/ISIS/ISIS',
157          code_page => '852',          code_page => '852',
158          limit_mfn => '500',          limit_mfn => 500,
159            start_mfn => 6000,
160          lookup => [ ... ],          lookup => [ ... ],
161   );   );
162    
163  By default, ISIS code page is assumed to be C<852>.  By default, ISIS code page is assumed to be C<852>.
164    
165    If optional parametar C<start_mfn> is set, this will be first MFN to read
166    from database (so you can skip beginning of your database if you need to).
167    
168  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
169  from database in example above.  from database in example above.
170    
# Line 144  sub open_isis { Line 192  sub open_isis {
192          $log->logcroak("need filename") if (! $arg->{'filename'});          $log->logcroak("need filename") if (! $arg->{'filename'});
193          my $code_page = $arg->{'code_page'} || '852';          my $code_page = $arg->{'code_page'} || '852';
194    
195            $log->logdie("can't find database ",$arg->{'filename'}) unless (glob($arg->{'filename'}.'.*'));
196    
197            # store data in object
198            $self->{'isis_filename'} = $arg->{'filename'};
199            $self->{'isis_code_page'} = $code_page;
200    
201          use OpenIsis;          use OpenIsis;
202    
203          #$self->{'isis_code_page'} = $code_page;          #$self->{'isis_code_page'} = $code_page;
# Line 152  sub open_isis { Line 206  sub open_isis {
206          my $cp = Text::Iconv->new($code_page,$self->{'code_page'});          my $cp = Text::Iconv->new($code_page,$self->{'code_page'});
207    
208          $log->info("reading ISIS database '",$arg->{'filename'},"'");          $log->info("reading ISIS database '",$arg->{'filename'},"'");
209            $log->debug("isis code page: $code_page");
210    
211          my $isis_db = OpenIsis::open($arg->{'filename'});          my $isis_db = OpenIsis::open($arg->{'filename'});
212    
213          my $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;          my $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;
214            my $startmfn = 1;
215    
216            if (my $s = $self->{'start_mfn'}) {
217                    $log->info("skipping to MFN $s");
218                    $startmfn = $s;
219            } else {
220                    $self->{'start_mfn'} = $startmfn;
221            }
222    
223          $maxmfn = $self->{limit_mfn} if ($self->{limit_mfn});          $maxmfn = $startmfn + $self->{limit_mfn} if ($self->{limit_mfn});
224    
225          $log->info("processing $maxmfn records...");          $log->info("processing ",($maxmfn-$startmfn)." records...");
226    
227          # read database          # read database
228          for (my $mfn = 1; $mfn <= $maxmfn; $mfn++) {          for (my $mfn = $startmfn; $mfn <= $maxmfn; $mfn++) {
229    
230    
231                    $log->debug("mfn: $mfn\n");
232    
233                    my $rec;
234    
235                  # read record                  # read record
236                  my $row = OpenIsis::read( $isis_db, $mfn );                  my $row = OpenIsis::read( $isis_db, $mfn );
# Line 181  sub open_isis { Line 249  sub open_isis {
249                                                  $val = $l;                                                  $val = $l;
250                                          }                                          }
251    
252                                          push @{$self->{'data'}->{$mfn}->{$k}}, $val;                                          push @{$rec->{$k}}, $val;
253                                  }                                  }
254                            } else {
255                                    push @{$rec->{'000'}}, $mfn;
256                          }                          }
257    
258                  }                  }
259    
260                    $log->confess("record $mfn empty?") unless ($rec);
261    
262                    # store
263                    if ($self->{'low_mem'}) {
264                            $self->{'db'}->put($mfn, $rec);
265                    } else {
266                            $self->{'data'}->{$mfn} = $rec;
267                    }
268    
269                  # create lookup                  # create lookup
                 my $rec = $self->{'data'}->{$mfn};  
270                  $self->create_lookup($rec, @{$arg->{'lookup'}});                  $self->create_lookup($rec, @{$arg->{'lookup'}});
271    
272                    $self->progress_bar($mfn,$maxmfn);
273    
274          }          }
275    
276          $self->{'current_mfn'} = 1;          $self->{'current_mfn'} = -1;
277            $self->{'last_pcnt'} = 0;
278    
279            $log->debug("max mfn: $maxmfn");
280    
281          # store max mfn and return it.          # store max mfn and return it.
282          return $self->{'max_mfn'} = $maxmfn;          return $self->{'max_mfn'} = $maxmfn;
# Line 213  sub fetch_rec { Line 296  sub fetch_rec {
296    
297          my $log = $self->_get_logger();          my $log = $self->_get_logger();
298    
299          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'});
300    
301            if ($self->{'current_mfn'} == -1) {
302                    $self->{'current_mfn'} = $self->{'start_mfn'};
303            } else {
304                    $self->{'current_mfn'}++;
305            }
306    
307            my $mfn = $self->{'current_mfn'};
308    
309          if ($mfn > $self->{'max_mfn'}) {          if ($mfn > $self->{'max_mfn'}) {
310                  $self->{'current_mfn'} = $self->{'max_mfn'};                  $self->{'current_mfn'} = $self->{'max_mfn'};
311                    $log->debug("at EOF");
312                  return;                  return;
313          }          }
314    
315          return $self->{'data'}->{$mfn};          $self->progress_bar($mfn,$self->{'max_mfn'});
316    
317            if ($self->{'low_mem'}) {
318                    return $self->{'db'}->get($mfn);
319            } else {
320                    return $self->{'data'}->{$mfn};
321            }
322    }
323    
324    =head2 mfn
325    
326    Returns current record number (MFN).
327    
328     print $webpac->mfn;
329    
330    =cut
331    
332    sub mfn {
333            my $self = shift;
334            return $self->{'current_mfn'};
335    }
336    
337    =head2 progress_bar
338    
339    Draw progress bar on STDERR.
340    
341     $webpac->progress_bar($current, $max);
342    
343    =cut
344    
345    sub progress_bar {
346            my $self = shift;
347    
348            my ($curr,$max) = @_;
349    
350            my $log = $self->_get_logger();
351    
352            $log->logconfess("no current value!") if (! $curr);
353            $log->logconfess("no maximum value!") if (! $max);
354    
355            if ($curr > $max) {
356                    $max = $curr;
357                    $log->debug("overflow to $curr");
358            }
359    
360            $self->{'last_pcnt'} ||= 1;
361    
362            my $p = int($curr * 100 / $max) || 1;
363    
364            # reset on re-run
365            if ($p < $self->{'last_pcnt'}) {
366                    $self->{'last_pcnt'} = $p;
367                    $self->{'last_t'} = time();
368                    $self->{'last_curr'} = undef;
369            }
370    
371            $self->{'last_t'} ||= time();
372    
373            if ($p != $self->{'last_pcnt'}) {
374    
375                    my $last_curr = $self->{'last_curr'} || $curr;
376                    my $t = time();
377                    my $rate = ($curr - $last_curr) / (($t - $self->{'last_t'} || 1));
378                    my $eta = ($max-$curr) / ($rate || 1);
379                    printf STDERR ("%5d [%-38s] %-5d %0.1f/s %s\r",$curr,"=" x ($p/3)."$p%>", $max, $rate, $self->fmt_time($eta));
380                    $self->{'last_pcnt'} = $p;
381                    $self->{'last_t'} = time();
382                    $self->{'last_curr'} = $curr;
383            }
384            print STDERR "\n" if ($p == 100);
385    }
386    
387    =head2 fmt_time
388    
389    Format time (in seconds) for display.
390    
391     print $webpac->fmt_time(time());
392    
393    This method is called by L<progress_bar> to display remaining time.
394    
395    =cut
396    
397    sub fmt_time {
398            my $self = shift;
399    
400            my $t = shift || 0;
401            my $out = "";
402    
403            my ($ss,$mm,$hh) = gmtime($t);
404            $out .= "${hh}h" if ($hh);
405            $out .= sprintf("%02d:%02d", $mm,$ss);
406            $out .= "  " if ($hh == 0);
407            return $out;
408  }  }
409    
410  =head2 open_import_xml  =head2 open_import_xml
# Line 246  sub open_import_xml { Line 430  sub open_import_xml {
430    
431          $self->{'tag'} = $type2tag{$type_base};          $self->{'tag'} = $type2tag{$type_base};
432    
433          $log->debug("using type '",$self->{'type'},"' tag <",$self->{'tag'},">") if ($self->{'debug'});          $log->info("using type '",$self->{'type'},"' tag <",$self->{'tag'},">");
434    
435          my $f = "./import_xml/".$self->{'type'}.".xml";          my $f = "./import_xml/".$self->{'type'}.".xml";
436          $log->logconfess("import_xml file '$f' doesn't exist!") if (! -e "$f");          $log->logconfess("import_xml file '$f' doesn't exist!") if (! -e "$f");
437    
438          $log->debug("reading '$f'") if ($self->{'debug'});          $log->info("reading '$f'");
439    
440            $self->{'import_xml_file'} = $f;
441    
442          $self->{'import_xml'} = XMLin($f,          $self->{'import_xml'} = XMLin($f,
443                  ForceArray => [ $self->{'tag'}, 'config', 'format' ],                  ForceArray => [ $self->{'tag'}, 'config', 'format' ],
                 ForceContent => 1  
444          );          );
445    
446            $log->debug("import xml is ",sub { Dumper($self->{'import_xml'}) });
447    
448  }  }
449    
450  =head2 create_lookup  =head2 create_lookup
# Line 279  sub create_lookup { Line 466  sub create_lookup {
466          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
467    
468          foreach my $i (@_) {          foreach my $i (@_) {
469                  if ($i->{'eval'}) {                  $log->logconfess("need key") unless defined($i->{'key'});
470                          my $eval = $self->fill_in($rec,$i->{'eval'});                  $log->logconfess("need val") unless defined($i->{'val'});
471                          my $key = $self->fill_in($rec,$i->{'key'});  
472                          my @val = $self->fill_in($rec,$i->{'val'});                  if (defined($i->{'eval'})) {
473                          if ($key && @val && eval $eval) {                          # eval first, so we can skip fill_in for key and val
474                            my $eval = $self->fill_in($rec,$i->{'eval'}) || next;
475                            if ($self->_eval($eval)) {
476                                    my $key = $self->fill_in($rec,$i->{'key'}) || next;
477                                    my @val = $self->fill_in($rec,$i->{'val'}) || next;
478                                    $log->debug("stored $key = ",sub { join(" | ",@val) });
479                                  push @{$self->{'lookup'}->{$key}}, @val;                                  push @{$self->{'lookup'}->{$key}}, @val;
480                          }                          }
481                  } else {                  } else {
482                          my $key = $self->fill_in($rec,$i->{'key'});                          my $key = $self->fill_in($rec,$i->{'key'}) || next;
483                          my @val = $self->fill_in($rec,$i->{'val'});                          my @val = $self->fill_in($rec,$i->{'val'}) || next;
484                          if ($key && @val) {                          $log->debug("stored $key = ",sub { join(" | ",@val) });
485                                  push @{$self->{'lookup'}->{$key}}, @val;                          push @{$self->{'lookup'}->{$key}}, @val;
                         }  
486                  }                  }
487          }          }
488  }  }
# Line 322  sub get_data { Line 513  sub get_data {
513    
514          if ($$rec->{$f}) {          if ($$rec->{$f}) {
515                  return '' if (! $$rec->{$f}->[$i]);                  return '' if (! $$rec->{$f}->[$i]);
516                    no strict 'refs';
517                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {
518                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
519                          return $$rec->{$f}->[$i]->{$sf};                          return $$rec->{$f}->[$i]->{$sf};
# Line 362  Following example will read second value Line 554  Following example will read second value
554  This function B<does not> perform parsing of format to inteligenty skip  This function B<does not> perform parsing of format to inteligenty skip
555  delimiters before fields which aren't used.  delimiters before fields which aren't used.
556    
557    This method will automatically decode UTF-8 string to local code page
558    if needed.
559    
560  =cut  =cut
561    
562  sub fill_in {  sub fill_in {
# Line 374  sub fill_in { Line 569  sub fill_in {
569          # iteration (for repeatable fields)          # iteration (for repeatable fields)
570          my $i = shift || 0;          my $i = shift || 0;
571    
572            $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));
573    
574          # FIXME remove for speedup?          # FIXME remove for speedup?
575          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
576    
577            if (utf8::is_utf8($format)) {
578                    $format = $self->_x($format);
579            }
580    
581          my $found = 0;          my $found = 0;
582    
583          my $eval_code;          my $eval_code;
584          # remove eval{...} from beginning          # remove eval{...} from beginning
585          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
586    
587            my $filter_name;
588            # remove filter{...} from beginning
589            $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
590    
591          # do actual replacement of placeholders          # do actual replacement of placeholders
592          $format =~ s/v(\d+)(?:\^(\w))*/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;          # repeatable fields
593            $format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;
594            # non-repeatable fields
595            $format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found)/ges;
596    
597          if ($found) {          if ($found) {
598                    $log->debug("format: $format");
599                  if ($eval_code) {                  if ($eval_code) {
600                          my $eval = $self->fill_in($rec,$eval_code,$i);                          my $eval = $self->fill_in($rec,$eval_code,$i);
601                          return if (! $self->_eval($eval));                          return if (! $self->_eval($eval));
602                  }                  }
603                    if ($filter_name && $self->{'filter'}->{$filter_name}) {
604                            $log->debug("filter '$filter_name' for $format");
605                            $format = $self->{'filter'}->{$filter_name}->($format);
606                            return unless(defined($format));
607                            $log->debug("filter result: $format");
608                    }
609                  # do we have lookups?                  # do we have lookups?
610                  $log->debug("test format '$format' for lookups");                  if ($format =~ /$LOOKUP_REGEX/o) {
611                  if ($format =~ /\[[^\[\]]+\]/o) {                          $log->debug("format '$format' has lookup");
612                          return $self->lookup($format);                          return $self->lookup($format);
613                  } else {                  } else {
614                          return $format;                          return $format;
# Line 420  sub lookup { Line 635  sub lookup {
635    
636          my $tmp = shift || $log->logconfess("need format");          my $tmp = shift || $log->logconfess("need format");
637    
638          if ($tmp =~ /\[[^\[\]]+\]/o) {          if ($tmp =~ /$LOOKUP_REGEX/o) {
639                  my @in = ( $tmp );                  my @in = ( $tmp );
640    
641                  $log->debug("lookup for: ",$tmp);                  $log->debug("lookup for: ",$tmp);
642    
643                  my @out;                  my @out;
644                  while (my $f = shift @in) {                  while (my $f = shift @in) {
645                          if ($f =~ /\[([^\[\]]+)\]/) {                          if ($f =~ /$LOOKUP_REGEX_SAVE/o) {
646                                  my $k = $1;                                  my $k = $1;
647                                  if ($self->{'lookup'}->{$k}) {                                  if ($self->{'lookup'}->{$k}) {
648                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {
649                                                  my $tmp2 = $f;                                                  my $tmp2 = $f;
650                                                  $tmp2 =~ s/\[$k\]/$nv/g;                                                  $tmp2 =~ s/lookup{$k}/$nv/g;
651                                                  push @in, $tmp2;                                                  push @in, $tmp2;
652                                          }                                          }
653                                  } else {                                  } else {
# Line 442  sub lookup { Line 657  sub lookup {
657                                  push @out, $f;                                  push @out, $f;
658                          }                          }
659                  }                  }
660                    $log->logconfess("return is array and it's not expected!") unless wantarray;
661                  return @out;                  return @out;
662          } else {          } else {
663                  return $tmp;                  return $tmp;
# Line 472  sub parse { Line 688  sub parse {
688    
689          $i = 0 if (! $i);          $i = 0 if (! $i);
690    
691          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'});
692    
693          my @out;          my @out;
694    
695            $log->debug("format: $format");
696    
697          my $eval_code;          my $eval_code;
698          # remove eval{...} from beginning          # remove eval{...} from beginning
699          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
700    
701            my $filter_name;
702            # remove filter{...} from beginning
703            $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
704    
705          my $prefix;          my $prefix;
706          my $all_found=0;          my $all_found=0;
707    
708          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))*//s) {          while ($format =~ s/^(.*?)(v|s)(\d+)(?:\^(\w))?//s) {
709    
710                  my $del = $1 || '';                  my $del = $1 || '';
711                  $prefix ||= $del if ($all_found == 0);                  $prefix ||= $del if ($all_found == 0);
712    
713                    # repeatable index
714                    my $r = $i;
715                    $r = 0 if (lc("$2") eq 's');
716    
717                  my $found = 0;                  my $found = 0;
718                  my $tmp = $self->get_data(\$rec,$2,$3,$i,\$found);                  my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found);
719    
720                  if ($found) {                  if ($found) {
721                          push @out, $del;                          push @out, $del;
# Line 500  sub parse { Line 726  sub parse {
726    
727          return if (! $all_found);          return if (! $all_found);
728    
729          my $out = join('',@out) . $format;          my $out = join('',@out);
730    
731            if ($out) {
732                    # add rest of format (suffix)
733                    $out .= $format;
734    
735          # add prefix if not there                  # add prefix if not there
736          $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);                  $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);
737    
738                    $log->debug("result: $out");
739            }
740    
741          if ($eval_code) {          if ($eval_code) {
742                  my $eval = $self->fill_in($rec,$eval_code,$i);                  my $eval = $self->fill_in($rec,$eval_code,$i) || return;
743                  $log->debug("about to eval ",$eval," [$out]");                  $log->debug("about to eval{$eval} format: $out");
744                  return if (! $self->_eval($eval));                  return if (! $self->_eval($eval));
745          }          }
746            
747            if ($filter_name && $self->{'filter'}->{$filter_name}) {
748                    $log->debug("about to filter{$filter_name} format: $out");
749                    $out = $self->{'filter'}->{$filter_name}->($out);
750                    return unless(defined($out));
751                    $log->debug("filter result: $out");
752            }
753    
754          return $out;          return $out;
755  }  }
# Line 539  sub parse_to_arr { Line 779  sub parse_to_arr {
779                  push @arr, $v;                  push @arr, $v;
780          }          }
781    
782            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
783    
784            return @arr;
785    }
786    
787    =head2 fill_in_to_arr
788    
789    Similar to C<fill_in>, but returns array of all repeatable fields. Usable
790    for fields which have lookups, so they shouldn't be parsed but rather
791    C<fill_id>ed.
792    
793     my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]');
794    
795    =cut
796    
797    sub fill_in_to_arr {
798            my $self = shift;
799    
800            my ($rec, $format_utf8) = @_;
801    
802            my $log = $self->_get_logger();
803    
804            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
805            return if (! $format_utf8);
806    
807            my $i = 0;
808            my @arr;
809    
810            while (my @v = $self->fill_in($rec,$format_utf8,$i++)) {
811                    push @arr, @v;
812            }
813    
814            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
815    
816          return @arr;          return @arr;
817  }  }
818    
819    =head2 sort_arr
820    
821    Sort array ignoring case and html in data
822    
823     my @sorted = $webpac->sort_arr(@unsorted);
824    
825    =cut
826    
827    sub sort_arr {
828            my $self = shift;
829    
830            my $log = $self->_get_logger();
831    
832            # FIXME add Schwartzian Transformation?
833    
834            my @sorted = sort {
835                    $a =~ s#<[^>]+/*>##;
836                    $b =~ s#<[^>]+/*>##;
837                    lc($b) cmp lc($a)
838            } @_;
839            $log->debug("sorted values: ",sub { join(", ",@sorted) });
840    
841            return @sorted;
842    }
843    
844    
845  =head2 data_structure  =head2 data_structure
846    
847  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 849  It is used later to produce output.
849    
850   my @ds = $webpac->data_structure($rec);   my @ds = $webpac->data_structure($rec);
851    
852    This method will also set C<$webpac->{'currnet_filename'}> if there is
853    <filename> tag in C<import_xml> and C<$webpac->{'headline'}> if there is
854    <headline> tag.
855    
856  =cut  =cut
857    
858  sub data_structure {  sub data_structure {
# Line 559  sub data_structure { Line 863  sub data_structure {
863          my $rec = shift;          my $rec = shift;
864          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
865    
866            undef $self->{'currnet_filename'};
867            undef $self->{'headline'};
868    
869          my @sorted_tags;          my @sorted_tags;
870          if ($self->{tags_by_order}) {          if ($self->{tags_by_order}) {
871                  @sorted_tags = @{$self->{tags_by_order}};                  @sorted_tags = @{$self->{tags_by_order}};
# Line 569  sub data_structure { Line 876  sub data_structure {
876    
877          my @ds;          my @ds;
878    
879            $log->debug("tags: ",sub { join(", ",@sorted_tags) });
880    
881          foreach my $field (@sorted_tags) {          foreach my $field (@sorted_tags) {
882    
883                  my $row;                  my $row;
# Line 576  sub data_structure { Line 885  sub data_structure {
885  #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'}});
886    
887                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
888                          my @v = $self->parse_to_arr($rec,$tag->{'content'});                          my $format = $tag->{'value'} || $tag->{'content'};
889    
890                          next if (! @v);                          $log->debug("format: $format");
891    
892                          # does tag have type?                          my @v;
893                          if ($tag->{'type'}) {                          if ($format =~ /$LOOKUP_REGEX/o) {
894                                  push @{$row->{$tag->{'type'}}}, @v;                                  @v = $self->fill_in_to_arr($rec,$format);
895                          } else {                          } else {
896                                  push @{$row->{'display'}}, @v;                                  @v = $self->parse_to_arr($rec,$format);
897                                  push @{$row->{'swish'}}, @v;                          }
898                            next if (! @v);
899    
900                            if ($tag->{'sort'}) {
901                                    @v = $self->sort_arr(@v);
902                            }
903    
904                            # use format?
905                            if ($tag->{'format_name'}) {
906                                    @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
907                            }
908    
909                            if ($field eq 'filename') {
910                                    $self->{'current_filename'} = join('',@v);
911                                    $log->debug("filename: ",$self->{'current_filename'});
912                            } elsif ($field eq 'headline') {
913                                    $self->{'headline'} .= join('',@v);
914                                    $log->debug("headline: ",$self->{'headline'});
915                                    next; # don't return headline in data_structure!
916                            }
917    
918                            # delimiter will join repeatable fields
919                            if ($tag->{'delimiter'}) {
920                                    @v = ( join($tag->{'delimiter'}, @v) );
921                          }                          }
922    
923                            # default types
924                            my @types = qw(display swish);
925                            # override by type attribute
926                            @types = ( $tag->{'type'} ) if ($tag->{'type'});
927    
928                            foreach my $type (@types) {
929                                    # append to previous line?
930                                    $log->debug("type: $type ",sub { join(" ",@v) }, $row->{'append'} || 'no append');
931                                    if ($tag->{'append'}) {
932    
933                                            # I will delimit appended part with
934                                            # delimiter (or ,)
935                                            my $d = $tag->{'delimiter'};
936                                            # default delimiter
937                                            $d ||= " ";
938    
939                                            my $last = pop @{$row->{$type}};
940                                            $d = "" if (! $last);
941                                            $last .= $d . join($d, @v);
942                                            push @{$row->{$type}}, $last;
943    
944                                    } else {
945                                            push @{$row->{$type}}, @v;
946                                    }
947                            }
948    
949    
950                  }                  }
951    
952                  if ($row) {                  if ($row) {
953                          $row->{'tag'} = $field;                          $row->{'tag'} = $field;
954    
955                            # TODO: name_sigular, name_plural
956                            my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
957                            $row->{'name'} = $name ? $self->_x($name) : $field;
958    
959                            # post-sort all values in field
960                            if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {
961                                    $log->warn("sort at field tag not implemented");
962                            }
963    
964                          push @ds, $row;                          push @ds, $row;
965    
966                            $log->debug("row $field: ",sub { Dumper($row) });
967                  }                  }
968    
969          }          }
# Line 629  sub output { Line 1001  sub output {
1001          return $out;          return $out;
1002  }  }
1003    
1004    =head2 output_file
1005    
1006    Create output from in-memory data structure using Template Toolkit template
1007    to a file.
1008    
1009     $webpac->output_file(
1010            file => 'out.txt',
1011            template => 'text.tt',
1012            data => @ds
1013     );
1014    
1015    =cut
1016    
1017    sub output_file {
1018            my $self = shift;
1019    
1020            my $args = {@_};
1021    
1022            my $log = $self->_get_logger();
1023    
1024            my $file = $args->{'file'} || $log->logconfess("need file name");
1025    
1026            $log->debug("creating file ",$file);
1027    
1028            open(my $fh, ">", $file) || $log->logdie("can't open output file '$file': $!");
1029            print $fh $self->output(
1030                    template => $args->{'template'},
1031                    data => $args->{'data'},
1032            ) || $log->logdie("print: $!");
1033            close($fh) || $log->logdie("close: $!");
1034    }
1035    
1036    =head2 apply_format
1037    
1038    Apply format specified in tag with C<format_name="name"> and
1039    C<format_delimiter=";;">.
1040    
1041     my $text = $webpac->apply_format($format_name,$format_delimiter,$data);
1042    
1043    Formats can contain C<lookup{...}> if you need them.
1044    
1045    =cut
1046    
1047    sub apply_format {
1048            my $self = shift;
1049    
1050            my ($name,$delimiter,$data) = @_;
1051    
1052            my $log = $self->_get_logger();
1053    
1054            if (! $self->{'import_xml'}->{'format'}->{$name}) {
1055                    $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});
1056                    return $data;
1057            }
1058    
1059            $log->warn("no delimiter for format $name") if (! $delimiter);
1060    
1061            my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");
1062    
1063            my @data = split(/\Q$delimiter\E/, $data);
1064    
1065            my $out = sprintf($format, @data);
1066            $log->debug("using format $name [$format] on $data to produce: $out");
1067    
1068            if ($out =~ m/$LOOKUP_REGEX/o) {
1069                    return $self->lookup($out);
1070            } else {
1071                    return $out;
1072            }
1073    
1074    }
1075    
1076    
1077  #  #
1078  #  #
1079  #  #
# Line 661  sub _eval { Line 1106  sub _eval {
1106    
1107          $log->debug("eval: ",$code," [",$ret,"]");          $log->debug("eval: ",$code," [",$ret,"]");
1108    
1109          return $ret || 0;          return $ret || undef;
1110  }  }
1111    
1112  =head2 _sort_by_order  =head2 _sort_by_order
# Line 681  sub _sort_by_order { Line 1126  sub _sort_by_order {
1126          return $va <=> $vb;          return $va <=> $vb;
1127  }  }
1128    
1129    =head2 _get_logger
1130    
1131    Get C<Log::Log4perl> object with a twist: domains are defined for each
1132    method
1133    
1134     my $log = $webpac->_get_logger();
1135    
1136    =cut
1137    
1138  sub _get_logger {  sub _get_logger {
1139          my $self = shift;          my $self = shift;
1140    
1141          my @c = caller(1);          my $name = (caller(1))[3] || caller;
1142          return get_logger($c[3]);          return get_logger($name);
1143    }
1144    
1145    =head2 _x
1146    
1147    Convert string from UTF-8 to code page defined in C<import_xml>.
1148    
1149     my $text = $webpac->_x('utf8 text');
1150    
1151    =cut
1152    
1153    sub _x {
1154            my $self = shift;
1155            my $utf8 = shift || return;
1156    
1157            return $self->{'utf2cp'}->convert($utf8) ||
1158                    $self->_get_logger()->logwarn("can't convert '$utf8'");
1159  }  }
1160    
1161  #  #
# Line 706  B<This is different from normal Log4perl Line 1176  B<This is different from normal Log4perl
1176  also use method names, and not only classes (which are just few)  also use method names, and not only classes (which are just few)
1177  to filter logging.  to filter logging.
1178    
1179    
1180    =head1 MEMORY USAGE
1181    
1182    C<low_mem> options is double-edged sword. If enabled, WebPAC
1183    will run on memory constraint machines (which doesn't have enough
1184    physical RAM to create memory structure for whole source database).
1185    
1186    If your machine has 512Mb or more of RAM and database is around 10000 records,
1187    memory shouldn't be an issue. If you don't have enough physical RAM, you
1188    might consider using virtual memory (if your operating system is handling it
1189    well, like on FreeBSD or Linux) instead of dropping to L<DBD::Deep> to handle
1190    parsed structure of ISIS database (this is what C<low_mem> option does).
1191    
1192    Hitting swap at end of reading source database is probably o.k. However,
1193    hitting swap before 90% will dramatically decrease performance and you will
1194    be better off with C<low_mem> and using rest of availble memory for
1195    operating system disk cache (Linux is particuallary good about this).
1196    However, every access to database record will require disk access, so
1197    generation phase will be slower 10-100 times.
1198    
1199    Parsed structures are essential - you just have option to trade RAM memory
1200    (which is fast) for disk space (which is slow). Be sure to have planty of
1201    disk space if you are using C<low_mem> and thus L<DBD::Deep>.
1202    
1203    However, when WebPAC is running on desktop machines (or laptops :-), it's
1204    highly undesireable for system to start swapping. Using C<low_mem> option can
1205    reduce WecPAC memory usage to around 64Mb for same database with lookup
1206    fields and sorted indexes which stay in RAM. Performance will suffer, but
1207    memory usage will really be minimal. It might be also more confortable to
1208    run WebPAC reniced on those machines.
1209    
1210  =cut  =cut
1211    
1212  1;  1;
Legend:
Removed from v.372  
changed lines
  Added in v.563
  ViewVC Help
Powered by ViewVC 1.1.26