/[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 371 by dpavlin, Thu Jun 17 20:44:45 2004 UTC revision 439 by dpavlin, Mon Sep 13 23:13:54 2004 UTC
# Line 8  use Text::Iconv; Line 8  use Text::Iconv;
8  use Config::IniFiles;  use Config::IniFiles;
9  use XML::Simple;  use XML::Simple;
10  use Template;  use Template;
11    use Log::Log4perl qw(get_logger :levels);
12    use Time::HiRes qw(time);
13    
14  use Data::Dumper;  use Data::Dumper;
15    
16    #my $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 23  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   );   );
40    
41  Default C<code_page> is C<ISO-8859-2>.  Default C<code_page> is C<ISO-8859-2>.
42    
43  It will also read configuration files  Default is not to use C<low_mem> options (see L<MEMORY USAGE> below).
44    
45    This method will also read configuration files
46  C<global.conf> (used by indexer and Web font-end)  C<global.conf> (used by indexer and Web font-end)
47  and configuration file specified by C<config_file>  and configuration file specified by C<config_file>
48  which describes databases to be indexed.  which describes databases to be indexed.
# Line 53  sub new { Line 63  sub new {
63          my $self = {@_};          my $self = {@_};
64          bless($self, $class);          bless($self, $class);
65    
66            $self->{'start_t'} = time();
67    
68            my $log_file = $self->{'log'} || "log.conf";
69            Log::Log4perl->init($log_file);
70    
71            my $log = $self->_get_logger();
72    
73          # fill in default values          # fill in default values
74          # output codepage          # output codepage
75          $self->{'code_page'} = 'ISO-8859-2' if (! $self->{'code_page'});          $self->{'code_page'} = 'ISO-8859-2' if (! $self->{'code_page'});
# Line 60  sub new { Line 77  sub new {
77          #          #
78          # read global.conf          # read global.conf
79          #          #
80            $log->debug("read 'global.conf'");
81    
82          my $config = new Config::IniFiles( -file => 'global.conf' ) || croak "can't open 'global.conf'";          my $config = new Config::IniFiles( -file => 'global.conf' ) || $log->logcroak("can't open 'global.conf'");
83    
84          # read global config parametars          # read global config parametars
85          foreach my $var (qw(          foreach my $var (qw(
# Line 80  sub new { Line 98  sub new {
98          # read indexer config file          # read indexer config file
99          #          #
100    
101          $self->{indexer_config_file} = new Config::IniFiles( -file => $self->{config_file} ) || croak "can't open '$self->{config_file}'";          $self->{indexer_config_file} = new Config::IniFiles( -file => $self->{config_file} ) || $log->logcroak("can't open '",$self->{config_file},"'");
102    
103          # create UTF-8 convertor for import_xml files          # create UTF-8 convertor for import_xml files
104          $self->{'utf2cp'} = Text::Iconv->new('UTF-8' ,$self->{'code_page'});          $self->{'utf2cp'} = Text::Iconv->new('UTF-8' ,$self->{'code_page'});
# Line 94  sub new { Line 112  sub new {
112                  EVAL_PERL => 1,                  EVAL_PERL => 1,
113          );          );
114    
115            # running with low_mem flag? well, use DBM::Deep then.
116            if ($self->{'low_mem'}) {
117                    $log->info("running with low_mem which impacts performance (<32 Mb memory usage)");
118    
119                    my $db_file = "data.db";
120    
121                    if (-e $db_file) {
122                            unlink $db_file or $log->logdie("can't remove '$db_file' from last run");
123                            $log->debug("removed '$db_file' from last run");
124                    }
125    
126                    require DBM::Deep;
127    
128                    my $db = new DBM::Deep $db_file;
129    
130                    $log->logdie("DBM::Deep error: $!") unless ($db);
131    
132                    if ($db->error()) {
133                            $log->logdie("can't open '$db_file' under low_mem: ",$db->error());
134                    } else {
135                            $log->debug("using file '$db_file' for DBM::Deep");
136                    }
137    
138                    $self->{'db'} = $db;
139            }
140    
141          return $self;          return $self;
142  }  }
143    
# Line 104  Open CDS/ISIS database using OpenIsis mo Line 148  Open CDS/ISIS database using OpenIsis mo
148   $webpac->open_isis(   $webpac->open_isis(
149          filename => '/data/ISIS/ISIS',          filename => '/data/ISIS/ISIS',
150          code_page => '852',          code_page => '852',
151          limit_mfn => '500',          limit_mfn => 500,
152            start_mfn => 6000,
153          lookup => [ ... ],          lookup => [ ... ],
154   );   );
155    
156  By default, ISIS code page is assumed to be C<852>.  By default, ISIS code page is assumed to be C<852>.
157    
158    If optional parametar C<start_mfn> is set, this will be first MFN to read
159    from database (so you can skip beginning of your database if you need to).
160    
161  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
162  from database in example above.  from database in example above.
163    
# Line 132  sub open_isis { Line 180  sub open_isis {
180          my $self = shift;          my $self = shift;
181          my $arg = {@_};          my $arg = {@_};
182    
183          croak "need filename" if (! $arg->{'filename'});          my $log = $self->_get_logger();
184    
185            $log->logcroak("need filename") if (! $arg->{'filename'});
186          my $code_page = $arg->{'code_page'} || '852';          my $code_page = $arg->{'code_page'} || '852';
187    
188            $log->logdie("can't find database ",$arg->{'filename'}) unless (glob($arg->{'filename'}.'.*'));
189    
190            # store data in object
191            $self->{'isis_filename'} = $arg->{'filename'};
192            $self->{'isis_code_page'} = $code_page;
193    
194          use OpenIsis;          use OpenIsis;
195    
196          #$self->{'isis_code_page'} = $code_page;          #$self->{'isis_code_page'} = $code_page;
# Line 142  sub open_isis { Line 198  sub open_isis {
198          # create Text::Iconv object          # create Text::Iconv object
199          my $cp = Text::Iconv->new($code_page,$self->{'code_page'});          my $cp = Text::Iconv->new($code_page,$self->{'code_page'});
200    
201          print STDERR "reading ISIS database '",$arg->{'filename'},"'\n" if ($self->{'debug'});          $log->info("reading ISIS database '",$arg->{'filename'},"'");
202            $log->debug("isis code page: $code_page");
203    
204          my $isis_db = OpenIsis::open($arg->{'filename'});          my $isis_db = OpenIsis::open($arg->{'filename'});
205    
206          my $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;          my $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;
207            my $startmfn = 1;
208    
209            if (my $s = $self->{'start_mfn'}) {
210                    $log->info("skipping to MFN $s");
211                    $startmfn = $s;
212            }
213    
214          $maxmfn = $self->{limit_mfn} if ($self->{limit_mfn});          $maxmfn = $startmfn + $self->{limit_mfn} if ($self->{limit_mfn});
215    
216          print STDERR "processing $maxmfn records...\n" if ($self->{'debug'});          $log->info("processing ",($maxmfn-$startmfn)." records...");
217    
218          # read database          # read database
219          for (my $mfn = 1; $mfn <= $maxmfn; $mfn++) {          for (my $mfn = $startmfn; $mfn <= $maxmfn; $mfn++) {
220    
221    
222                    $log->debug("mfn: $mfn\n");
223    
224                    my $rec;
225    
226                  # read record                  # read record
227                  my $row = OpenIsis::read( $isis_db, $mfn );                  my $row = OpenIsis::read( $isis_db, $mfn );
# Line 172  sub open_isis { Line 240  sub open_isis {
240                                                  $val = $l;                                                  $val = $l;
241                                          }                                          }
242    
243                                          push @{$self->{'data'}->{$mfn}->{$k}}, $val;                                          push @{$rec->{$k}}, $val;
244                                  }                                  }
245                            } else {
246                                    push @{$rec->{'000'}}, $mfn;
247                          }                          }
248    
249                  }                  }
250    
251                    $log->confess("record $mfn empty?") unless ($rec);
252    
253                    # store
254                    if ($self->{'low_mem'}) {
255                            $self->{'db'}->put($mfn, $rec);
256                    } else {
257                            $self->{'data'}->{$mfn} = $rec;
258                    }
259    
260                  # create lookup                  # create lookup
                 my $rec = $self->{'data'}->{$mfn};  
261                  $self->create_lookup($rec, @{$arg->{'lookup'}});                  $self->create_lookup($rec, @{$arg->{'lookup'}});
262    
263                    $self->progress_bar($mfn,$maxmfn);
264    
265          }          }
266    
267          $self->{'current_mfn'} = 1;          $self->{'current_mfn'} = $startmfn;
268            $self->{'last_pcnt'} = 0;
269    
270            $log->debug("max mfn: $maxmfn");
271    
272          # store max mfn and return it.          # store max mfn and return it.
273          return $self->{'max_mfn'} = $maxmfn;          return $self->{'max_mfn'} = $maxmfn;
# Line 202  it's implemented, that is). Line 285  it's implemented, that is).
285  sub fetch_rec {  sub fetch_rec {
286          my $self = shift;          my $self = shift;
287    
288          my $mfn = $self->{'current_mfn'}++ || confess "it seems that you didn't load database!";          my $log = $self->_get_logger();
289    
290            my $mfn = $self->{'current_mfn'}++ || $log->logconfess("it seems that you didn't load database!");
291    
292          if ($mfn > $self->{'max_mfn'}) {          if ($mfn > $self->{'max_mfn'}) {
293                  $self->{'current_mfn'} = $self->{'max_mfn'};                  $self->{'current_mfn'} = $self->{'max_mfn'};
294                    $log->debug("at EOF");
295                  return;                  return;
296          }          }
297    
298          return $self->{'data'}->{$mfn};          $self->progress_bar($mfn,$self->{'max_mfn'});
299    
300            if ($self->{'low_mem'}) {
301                    return $self->{'db'}->get($mfn);
302            } else {
303                    return $self->{'data'}->{$mfn};
304            }
305    }
306    
307    =head2 progress_bar
308    
309    Draw progress bar on STDERR.
310    
311     $webpac->progress_bar($current, $max);
312    
313    =cut
314    
315    sub progress_bar {
316            my $self = shift;
317    
318            my ($curr,$max) = @_;
319    
320            my $log = $self->_get_logger();
321    
322            $log->logconfess("no current value!") if (! $curr);
323            $log->logconfess("no maximum value!") if (! $max);
324    
325            if ($curr > $max) {
326                    $max = $curr;
327                    $log->debug("overflow to $curr");
328            }
329    
330            $self->{'last_pcnt'} ||= 1;
331    
332            my $p = int($curr * 100 / $max);
333    
334            # reset on re-run
335            if ($p < $self->{'last_pcnt'}) {
336                    $self->{'last_pcnt'} = $p;
337                    $self->{'last_t'} = time();
338                    $self->{'last_curr'} = 1;
339            }
340    
341            if ($p != $self->{'last_pcnt'}) {
342    
343                    my $last_curr = $self->{'last_curr'} || $curr;
344                    my $t = time();
345                    my $rate = ($curr - $last_curr) / (($t - $self->{'last_t'} || 1));
346                    my $eta = ($max-$curr) / ($rate || 1);
347                    printf STDERR ("%5d [%-38s] %-5d %0.1f/s %s\r",$curr,"=" x ($p/3)."$p%>", $max, $rate, $self->fmt_time($eta));
348                    $self->{'last_pcnt'} = $p;
349                    $self->{'last_t'} = time();
350                    $self->{'last_curr'} = $curr;
351            }
352            print STDERR "\n" if ($p == 100);
353    }
354    
355    =head2 fmt_time
356    
357    Format time (in seconds) for display.
358    
359     print $webpac->fmt_time(time());
360    
361    This method is called by L<progress_bar> to display remaining time.
362    
363    =cut
364    
365    sub fmt_time {
366            my $self = shift;
367    
368            my $t = shift || 0;
369            my $out = "";
370    
371            my ($ss,$mm,$hh) = gmtime($t);
372            $out .= "${hh}h" if ($hh);
373            $out .= sprintf("%02d:%02d", $mm,$ss);
374            $out .= "  " if ($hh == 0);
375            return $out;
376  }  }
377    
378  =head2 open_import_xml  =head2 open_import_xml
# Line 223  Read file from C<import_xml/> directory Line 386  Read file from C<import_xml/> directory
386  sub open_import_xml {  sub open_import_xml {
387          my $self = shift;          my $self = shift;
388    
389            my $log = $self->_get_logger();
390    
391          my $arg = {@_};          my $arg = {@_};
392          confess "need type to load file from import_xml/" if (! $arg->{'type'});          $log->logconfess("need type to load file from import_xml/") if (! $arg->{'type'});
393    
394          $self->{'type'} = $arg->{'type'};          $self->{'type'} = $arg->{'type'};
395    
# Line 233  sub open_import_xml { Line 398  sub open_import_xml {
398    
399          $self->{'tag'} = $type2tag{$type_base};          $self->{'tag'} = $type2tag{$type_base};
400    
401          print STDERR "using type '",$self->{'type'},"' tag <",$self->{'tag'},">\n" if ($self->{'debug'});          $log->info("using type '",$self->{'type'},"' tag <",$self->{'tag'},">");
402    
403          my $f = "./import_xml/".$self->{'type'}.".xml";          my $f = "./import_xml/".$self->{'type'}.".xml";
404          confess "import_xml file '$f' doesn't exist!" if (! -e "$f");          $log->logconfess("import_xml file '$f' doesn't exist!") if (! -e "$f");
405    
406            $log->info("reading '$f'");
407    
408          print STDERR "reading '$f'\n" if ($self->{'debug'});          $self->{'import_xml_file'} = $f;
409    
410          $self->{'import_xml'} = XMLin($f,          $self->{'import_xml'} = XMLin($f,
411                  ForceArray => [ $self->{'tag'}, 'config', 'format' ],                  ForceArray => [ $self->{'tag'}, 'config', 'format' ],
                 ForceContent => 1  
412          );          );
413    
414            $log->debug("import xml is ",sub { Dumper($self->{'import_xml'}) });
415    
416  }  }
417    
418  =head2 create_lookup  =head2 create_lookup
# Line 260  Called internally by C<open_*> methods. Line 428  Called internally by C<open_*> methods.
428  sub create_lookup {  sub create_lookup {
429          my $self = shift;          my $self = shift;
430    
431          my $rec = shift || confess "need record to create lookup";          my $log = $self->_get_logger();
432          confess("need HASH as first argument!") if ($rec !~ /HASH/o);  
433            my $rec = shift || $log->logconfess("need record to create lookup");
434            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
435    
436          foreach my $i (@_) {          foreach my $i (@_) {
437                  if ($i->{'eval'}) {                  $log->logconfess("need key") unless defined($i->{'key'});
438                          my $eval = $self->fill_in($rec,$i->{'eval'});                  $log->logconfess("need val") unless defined($i->{'val'});
439                          my $key = $self->fill_in($rec,$i->{'key'});  
440                          my @val = $self->fill_in($rec,$i->{'val'});                  if (defined($i->{'eval'})) {
441                          if ($key && @val && eval $eval) {                          # eval first, so we can skip fill_in for key and val
442                            my $eval = $self->fill_in($rec,$i->{'eval'}) || next;
443                            if ($self->_eval($eval)) {
444                                    my $key = $self->fill_in($rec,$i->{'key'}) || next;
445                                    my @val = $self->fill_in($rec,$i->{'val'}) || next;
446                                    $log->debug("stored $key = ",sub { join(" | ",@val) });
447                                  push @{$self->{'lookup'}->{$key}}, @val;                                  push @{$self->{'lookup'}->{$key}}, @val;
448                          }                          }
449                  } else {                  } else {
450                          my $key = $self->fill_in($rec,$i->{'key'});                          my $key = $self->fill_in($rec,$i->{'key'}) || next;
451                          my @val = $self->fill_in($rec,$i->{'val'});                          my @val = $self->fill_in($rec,$i->{'val'}) || next;
452                          if ($key && @val) {                          $log->debug("stored $key = ",sub { join(" | ",@val) });
453                                  push @{$self->{'lookup'}->{$key}}, @val;                          push @{$self->{'lookup'}->{$key}}, @val;
                         }  
454                  }                  }
455          }          }
456  }  }
# Line 307  sub get_data { Line 481  sub get_data {
481    
482          if ($$rec->{$f}) {          if ($$rec->{$f}) {
483                  return '' if (! $$rec->{$f}->[$i]);                  return '' if (! $$rec->{$f}->[$i]);
484                    no strict 'refs';
485                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {
486                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
487                          return $$rec->{$f}->[$i]->{$sf};                          return $$rec->{$f}->[$i]->{$sf};
# Line 347  Following example will read second value Line 522  Following example will read second value
522  This function B<does not> perform parsing of format to inteligenty skip  This function B<does not> perform parsing of format to inteligenty skip
523  delimiters before fields which aren't used.  delimiters before fields which aren't used.
524    
525  =cut  This method will automatically decode UTF-8 string to local code page
526    if needed.
 # internal function to eval code  
 sub _eval {  
         my $self = shift;  
527    
528          my $code = shift || return;  =cut
         no strict 'subs';  
         my $ret = eval $code;  
         if ($@) {  
                 print STDERR "problem with eval code [$code]: $@\n";  
         }  
         return $ret;  
 }  
529    
530  sub fill_in {  sub fill_in {
531          my $self = shift;          my $self = shift;
532    
533          my $rec = shift || confess "need data record";          my $log = $self->_get_logger();
534          my $format = shift || confess "need format to parse";  
535            my $rec = shift || $log->logconfess("need data record");
536            my $format = shift || $log->logconfess("need format to parse");
537          # iteration (for repeatable fields)          # iteration (for repeatable fields)
538          my $i = shift || 0;          my $i = shift || 0;
539    
540          # FIXME remove for speedup?          # FIXME remove for speedup?
541          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
542    
543            if (utf8::is_utf8($format)) {
544                    $format = $self->_x($format);
545            }
546    
547          my $found = 0;          my $found = 0;
548    
# Line 380  sub fill_in { Line 551  sub fill_in {
551          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
552    
553          # do actual replacement of placeholders          # do actual replacement of placeholders
554          $format =~ s/v(\d+)(?:\^(\w))*/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;          $format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;
555    
556          if ($found) {          if ($found) {
557                    $log->debug("format: $format");
558                  if ($eval_code) {                  if ($eval_code) {
559                          my $eval = $self->fill_in($rec,$eval_code,$i);                          my $eval = $self->fill_in($rec,$eval_code,$i);
560                          return if (! $self->_eval($eval));                          return if (! $self->_eval($eval));
561                  }                  }
562                  # do we have lookups?                  # do we have lookups?
563                  if ($format =~ /\[[^\[\]]+\]/o) {                  if ($format =~ /$LOOKUP_REGEX/o) {
564  print "## probable lookup: $format\n";                          $log->debug("format '$format' has lookup");
565                          return $self->lookup($format);                          return $self->lookup($format);
566                  } else {                  } else {
567                          return $format;                          return $format;
# Line 412  Lookups can be nested (like C<[d:[a:[v90 Line 584  Lookups can be nested (like C<[d:[a:[v90
584  sub lookup {  sub lookup {
585          my $self = shift;          my $self = shift;
586    
587          my $tmp = shift || confess "need format";          my $log = $self->_get_logger();
588    
589            my $tmp = shift || $log->logconfess("need format");
590    
591          if ($tmp =~ /\[[^\[\]]+\]/o) {          if ($tmp =~ /$LOOKUP_REGEX/o) {
592                  my @in = ( $tmp );                  my @in = ( $tmp );
593  print "## lookup $tmp\n";  
594                    $log->debug("lookup for: ",$tmp);
595    
596                  my @out;                  my @out;
597                  while (my $f = shift @in) {                  while (my $f = shift @in) {
598                          if ($f =~ /\[([^\[\]]+)\]/) {                          if ($f =~ /$LOOKUP_REGEX_SAVE/o) {
599                                  my $k = $1;                                  my $k = $1;
600                                  if ($self->{'lookup'}->{$k}) {                                  if ($self->{'lookup'}->{$k}) {
601                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {
602                                                  my $tmp2 = $f;                                                  my $tmp2 = $f;
603                                                  $tmp2 =~ s/\[$k\]/$nv/g;                                                  $tmp2 =~ s/lookup{$k}/$nv/g;
604                                                  push @in, $tmp2;                                                  push @in, $tmp2;
605                                          }                                          }
606                                  } else {                                  } else {
# Line 434  print "## lookup $tmp\n"; Line 610  print "## lookup $tmp\n";
610                                  push @out, $f;                                  push @out, $f;
611                          }                          }
612                  }                  }
613                    $log->logconfess("return is array and it's not expected!") unless wantarray;
614                  return @out;                  return @out;
615          } else {          } else {
616                  return $tmp;                  return $tmp;
# Line 457  sub parse { Line 634  sub parse {
634    
635          return if (! $format_utf8);          return if (! $format_utf8);
636    
637          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          my $log = $self->_get_logger();
638          confess("need utf2cp Text::Iconv object!") if (! $self->{'utf2cp'});  
639            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
640            $log->logconfess("need utf2cp Text::Iconv object!") if (! $self->{'utf2cp'});
641    
642          $i = 0 if (! $i);          $i = 0 if (! $i);
643    
644          my $format = $self->{'utf2cp'}->convert($format_utf8) || confess("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'});
645    
646          my @out;          my @out;
647    
648            $log->debug("format: $format");
649    
650          my $eval_code;          my $eval_code;
651          # remove eval{...} from beginning          # remove eval{...} from beginning
652          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
# Line 473  sub parse { Line 654  sub parse {
654          my $prefix;          my $prefix;
655          my $all_found=0;          my $all_found=0;
656    
657          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))*//s) {          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))?//s) {
658    
659                  my $del = $1 || '';                  my $del = $1 || '';
660                  $prefix ||= $del if ($all_found == 0);                  $prefix ||= $del if ($all_found == 0);
# Line 490  sub parse { Line 671  sub parse {
671    
672          return if (! $all_found);          return if (! $all_found);
673    
674          my $out = join('',@out) . $format;          my $out = join('',@out);
675    
676          # add prefix if not there          if ($out) {
677          $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);                  # add rest of format (suffix)
678                    $out .= $format;
679    
680                    # add prefix if not there
681                    $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);
682    
683                    $log->debug("result: $out");
684            }
685    
686          if ($eval_code) {          if ($eval_code) {
687                  my $eval = $self->fill_in($rec,$eval_code,$i);                  my $eval = $self->fill_in($rec,$eval_code,$i);
688                    $log->debug("about to eval{",$eval,"} format: $out");
689                  return if (! $self->_eval($eval));                  return if (! $self->_eval($eval));
690          }          }
691    
# Line 516  sub parse_to_arr { Line 705  sub parse_to_arr {
705    
706          my ($rec, $format_utf8) = @_;          my ($rec, $format_utf8) = @_;
707    
708          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          my $log = $self->_get_logger();
709    
710            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
711          return if (! $format_utf8);          return if (! $format_utf8);
712    
713          my $i = 0;          my $i = 0;
# Line 526  sub parse_to_arr { Line 717  sub parse_to_arr {
717                  push @arr, $v;                  push @arr, $v;
718          }          }
719    
720            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
721    
722          return @arr;          return @arr;
723  }  }
724    
725  =head2 data_structure  =head2 fill_in_to_arr
726    
727  Create in-memory data structure which represents layout from C<import_xml>.  Similar to C<fill_in>, but returns array of all repeatable fields. Usable
728  It is used later to produce output.  for fields which have lookups, so they shouldn't be parsed but rather
729    C<fill_id>ed.
730    
731   my @ds = $webpac->data_structure($rec);   my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]');
732    
733  =cut  =cut
734    
735  # private method _sort_by_order  sub fill_in_to_arr {
 # sort subrouting using order="" attribute  
 sub _sort_by_order {  
736          my $self = shift;          my $self = shift;
737    
738          my $va = $self->{'import_xml'}->{'indexer'}->{$a}->{'order'} ||          my ($rec, $format_utf8) = @_;
                 $self->{'import_xml'}->{'indexer'}->{$a};  
         my $vb = $self->{'import_xml'}->{'indexer'}->{$b}->{'order'} ||  
                 $self->{'import_xml'}->{'indexer'}->{$b};  
739    
740          return $va <=> $vb;          my $log = $self->_get_logger();
741    
742            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
743            return if (! $format_utf8);
744    
745            my $i = 0;
746            my @arr;
747    
748            while (my @v = $self->fill_in($rec,$format_utf8,$i++)) {
749                    push @arr, @v;
750            }
751    
752            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
753    
754            return @arr;
755  }  }
756    
757    
758    =head2 data_structure
759    
760    Create in-memory data structure which represents layout from C<import_xml>.
761    It is used later to produce output.
762    
763     my @ds = $webpac->data_structure($rec);
764    
765    This method will also set C<$webpac->{'currnet_filename'}> if there is
766    <filename> tag in C<import_xml> and C<$webpac->{'headline'}> if there is
767    <headline> tag.
768    
769    =cut
770    
771  sub data_structure {  sub data_structure {
772          my $self = shift;          my $self = shift;
773    
774            my $log = $self->_get_logger();
775    
776          my $rec = shift;          my $rec = shift;
777          confess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
778    
779            undef $self->{'currnet_filename'};
780            undef $self->{'headline'};
781    
782          my @sorted_tags;          my @sorted_tags;
783          if ($self->{tags_by_order}) {          if ($self->{tags_by_order}) {
# Line 567  sub data_structure { Line 789  sub data_structure {
789    
790          my @ds;          my @ds;
791    
792            $log->debug("tags: ",sub { join(", ",@sorted_tags) });
793    
794          foreach my $field (@sorted_tags) {          foreach my $field (@sorted_tags) {
795    
796                  my $row;                  my $row;
# Line 574  sub data_structure { Line 798  sub data_structure {
798  #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'}});
799    
800                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
801                          my @v = $self->parse_to_arr($rec,$tag->{'content'});                          my $format = $tag->{'value'} || $tag->{'content'};
802    
803                          next if (! @v);                          $log->debug("format: $format");
804    
805                          # does tag have type?                          my @v;
806                          if ($tag->{'type'}) {                          if ($format =~ /$LOOKUP_REGEX/o) {
807                                  push @{$row->{$tag->{'type'}}}, @v;                                  @v = $self->fill_in_to_arr($rec,$format);
808                          } else {                          } else {
809                                  push @{$row->{'display'}}, @v;                                  @v = $self->parse_to_arr($rec,$format);
810                                  push @{$row->{'swish'}}, @v;                          }
811                            next if (! @v);
812    
813                            if ($tag->{'sort'}) {
814                                    # very special sort, ignoring case and
815                                    # html
816                                    @v = sort {
817                                            $a =~ s#<[^>]+/*>##;
818                                            $b =~ s#<[^>]+/*>##;
819                                            lc($b) cmp lc($a)
820                                    } @v;
821                                    $log->warn("sort within tag is usually not what you want!");
822                                    $log->debug("sorted values: ",sub { join(", ",@v) });
823                            }
824    
825                            # use format?
826                            if ($tag->{'format_name'}) {
827                                    @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
828                            }
829    
830                            if ($field eq 'filename') {
831                                    $self->{'current_filename'} = join('',@v);
832                                    $log->debug("filename: ",$self->{'current_filename'});
833                            } elsif ($field eq 'headline') {
834                                    $self->{'headline'} .= join('',@v);
835                                    $log->debug("headline: ",$self->{'headline'});
836                                    next; # don't return headline in data_structure!
837                            }
838    
839                            # delimiter will join repeatable fields
840                            if ($tag->{'delimiter'}) {
841                                    @v = ( join($tag->{'delimiter'}, @v) );
842                            }
843    
844                            # default types
845                            my @types = qw(display swish);
846                            # override by type attribute
847                            @types = ( $tag->{'type'} ) if ($tag->{'type'});
848    
849                            foreach my $type (@types) {
850                                    # append to previous line?
851                                    $log->debug("type: $type ",sub { join(" ",@v) }, $row->{'append'} || 'no append');
852                                    if ($tag->{'append'}) {
853    
854                                            # I will delimit appended part with
855                                            # delimiter (or ,)
856                                            my $d = $tag->{'delimiter'};
857                                            # default delimiter
858                                            $d ||= ", ";
859    
860                                            my $last = pop @{$row->{$type}};
861                                            $d = "" if (! $last);
862                                            $last .= $d . join($d, @v);
863                                            push @{$row->{$type}}, $last;
864    
865                                    } else {
866                                            push @{$row->{$type}}, @v;
867                                    }
868                          }                          }
869    
870    
871                  }                  }
872    
873                  if ($row) {                  if ($row) {
874                          $row->{'tag'} = $field;                          $row->{'tag'} = $field;
875    
876                            # TODO: name_sigular, name_plural
877                            my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
878                            $row->{'name'} = $name ? $self->_x($name) : $field;
879    
880                            # post-sort all values in field
881                            if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {
882                                    $log->warn("sort at field tag not implemented");
883    
884                            }
885    
886                          push @ds, $row;                          push @ds, $row;
887    
888                            $log->debug("row $field: ",sub { Dumper($row) });
889                  }                  }
890    
891          }          }
# Line 611  sub output { Line 907  sub output {
907    
908          my $args = {@_};          my $args = {@_};
909    
910          confess("need template name") if (! $args->{'template'});          my $log = $self->_get_logger();
911          confess("need data array") if (! $args->{'data'});  
912            $log->logconfess("need template name") if (! $args->{'template'});
913            $log->logconfess("need data array") if (! $args->{'data'});
914    
915          my $out;          my $out;
916    
# Line 625  sub output { Line 923  sub output {
923          return $out;          return $out;
924  }  }
925    
926    =head2 output_file
927    
928    Create output from in-memory data structure using Template Toolkit template
929    to a file.
930    
931     $webpac->output_file(
932            file => 'out.txt',
933            template => 'text.tt',
934            data => @ds
935     );
936    
937    =cut
938    
939    sub output_file {
940            my $self = shift;
941    
942            my $args = {@_};
943    
944            my $log = $self->_get_logger();
945    
946            my $file = $args->{'file'} || $log->logconfess("need file name");
947    
948            $log->debug("creating file ",$file);
949    
950            open(my $fh, ">", $file) || $log->logdie("can't open output file '$file': $!");
951            print $fh $self->output(
952                    template => $args->{'template'},
953                    data => $args->{'data'},
954            ) || $log->logdie("print: $!");
955            close($fh) || $log->logdie("close: $!");
956    }
957    
958    =head2 apply_format
959    
960    Apply format specified in tag with C<format_name="name"> and
961    C<format_delimiter=";;">.
962    
963     my $text = $webpac->apply_format($format_name,$format_delimiter,$data);
964    
965    Formats can contain C<lookup{...}> if you need them.
966    
967    =cut
968    
969    sub apply_format {
970            my $self = shift;
971    
972            my ($name,$delimiter,$data) = @_;
973    
974            my $log = $self->_get_logger();
975    
976            if (! $self->{'import_xml'}->{'format'}->{$name}) {
977                    $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});
978                    return $data;
979            }
980    
981            $log->warn("no delimiter for format $name") if (! $delimiter);
982    
983            my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");
984    
985            my @data = split(/\Q$delimiter\E/, $data);
986    
987            my $out = sprintf($format, @data);
988            $log->debug("using format $name [$format] on $data to produce: $out");
989    
990            if ($out =~ m/$LOOKUP_REGEX/o) {
991                    return $self->lookup($out);
992            } else {
993                    return $out;
994            }
995    
996    }
997    
998    
999    #
1000    #
1001    #
1002    
1003    =head1 INTERNAL METHODS
1004    
1005    Here is a quick list of internal methods, mostly useful to turn debugging
1006    on them (see L<LOGGING> below for explanation).
1007    
1008    =cut
1009    
1010    =head2 _eval
1011    
1012    Internal function to eval code without C<strict 'subs'>.
1013    
1014    =cut
1015    
1016    sub _eval {
1017            my $self = shift;
1018    
1019            my $code = shift || return;
1020    
1021            my $log = $self->_get_logger();
1022    
1023            no strict 'subs';
1024            my $ret = eval $code;
1025            if ($@) {
1026                    $log->error("problem with eval code [$code]: $@");
1027            }
1028    
1029            $log->debug("eval: ",$code," [",$ret,"]");
1030    
1031            return $ret || 0;
1032    }
1033    
1034    =head2 _sort_by_order
1035    
1036    Sort xml tags data structure accoding to C<order=""> attribute.
1037    
1038    =cut
1039    
1040    sub _sort_by_order {
1041            my $self = shift;
1042    
1043            my $va = $self->{'import_xml'}->{'indexer'}->{$a}->{'order'} ||
1044                    $self->{'import_xml'}->{'indexer'}->{$a};
1045            my $vb = $self->{'import_xml'}->{'indexer'}->{$b}->{'order'} ||
1046                    $self->{'import_xml'}->{'indexer'}->{$b};
1047    
1048            return $va <=> $vb;
1049    }
1050    
1051    =head2 _get_logger
1052    
1053    Get C<Log::Log4perl> object with a twist: domains are defined for each
1054    method
1055    
1056     my $log = $webpac->_get_logger();
1057    
1058    =cut
1059    
1060    sub _get_logger {
1061            my $self = shift;
1062    
1063            my $name = (caller(1))[3] || caller;
1064            return get_logger($name);
1065    }
1066    
1067    =head2 _x
1068    
1069    Convert string from UTF-8 to code page defined in C<import_xml>.
1070    
1071     my $text = $webpac->_x('utf8 text');
1072    
1073    =cut
1074    
1075    sub _x {
1076            my $self = shift;
1077            my $utf8 = shift || return;
1078    
1079            return $self->{'utf2cp'}->convert($utf8) ||
1080                    $self->_get_logger()->logwarn("can't convert '$utf8'");
1081    }
1082    
1083    #
1084    #
1085    #
1086    
1087    =head1 LOGGING
1088    
1089    Logging in WebPAC is performed by L<Log::Log4perl> with config file
1090    C<log.conf>.
1091    
1092    Methods defined above have different levels of logging, so
1093    it's descriptions will be useful to turn (mostry B<debug> logging) on
1094    or off to see why WabPAC isn't perforing as you expect it (it might even
1095    be a bug!).
1096    
1097    B<This is different from normal Log4perl behaviour>. To repeat, you can
1098    also use method names, and not only classes (which are just few)
1099    to filter logging.
1100    
1101    
1102    =head1 MEMORY USAGE
1103    
1104    C<low_mem> options is double-edged sword. If enabled, WebPAC
1105    will run on memory constraint machines (which doesn't have enough
1106    physical RAM to create memory structure for whole source database).
1107    
1108    If your machine has 512Mb or more of RAM and database is around 10000 records,
1109    memory shouldn't be an issue. If you don't have enough physical RAM, you
1110    might consider using virtual memory (if your operating system is handling it
1111    well, like on FreeBSD or Linux) instead of dropping to L<DBD::Deep> to handle
1112    parsed structure of ISIS database (this is what C<low_mem> option does).
1113    
1114    Hitting swap at end of reading source database is probably o.k. However,
1115    hitting swap before 90% will dramatically decrease performance and you will
1116    be better off with C<low_mem> and using rest of availble memory for
1117    operating system disk cache (Linux is particuallary good about this).
1118    However, every access to database record will require disk access, so
1119    generation phase will be slower 10-100 times.
1120    
1121    Parsed structures are essential - you just have option to trade RAM memory
1122    (which is fast) for disk space (which is slow). Be sure to have planty of
1123    disk space if you are using C<low_mem> and thus L<DBD::Deep>.
1124    
1125    However, when WebPAC is running on desktop machines (or laptops :-), it's
1126    highly undesireable for system to start swapping. Using C<low_mem> option can
1127    reduce WecPAC memory usage to around 64Mb for same database with lookup
1128    fields and sorted indexes which stay in RAM. Performance will suffer, but
1129    memory usage will really be minimal. It might be also more confortable to
1130    run WebPAC reniced on those machines.
1131    
1132    =cut
1133    
1134  1;  1;
Legend:
Removed from v.371  
changed lines
  Added in v.439
  ViewVC Help
Powered by ViewVC 1.1.26