/[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 707 by dpavlin, Wed Jul 13 23:36:53 2005 UTC
# Line 9  use Config::IniFiles; Line 9  use Config::IniFiles;
9  use XML::Simple;  use XML::Simple;
10  use Template;  use Template;
11  use Log::Log4perl qw(get_logger :levels);  use Log::Log4perl qw(get_logger :levels);
12    use Time::HiRes qw(time);
13    
14  use Data::Dumper;  use Data::Dumper;
15    
16    my ($have_biblio_isis, $have_openisis) = (0,0);
17    
18    eval "use Biblio::Isis 0.13;";
19    unless ($@) {
20            $have_biblio_isis = 1
21    } else {
22            eval "use OpenIsis;";
23            $have_openisis = 1 unless ($@);
24    }
25    
26    #my $LOOKUP_REGEX = '\[[^\[\]]+\]';
27    #my $LOOKUP_REGEX_SAVE = '\[([^\[\]]+)\]';
28    my $LOOKUP_REGEX = 'lookup{[^\{\}]+}';
29    my $LOOKUP_REGEX_SAVE = 'lookup{([^\{\}]+)}';
30    
31  =head1 NAME  =head1 NAME
32    
33  WebPAC - base class for WebPAC  WebPAC - base class for WebPAC
# Line 24  This module implements methods used by W Line 40  This module implements methods used by W
40    
41  =head2 new  =head2 new
42    
43  This will create new instance of WebPAC using configuration specified by C<config_file>.  Create new instance of WebPAC using configuration specified by C<config_file>.
44    
45   my $webpac = new WebPAC(   my $webpac = new WebPAC(
46          config_file => 'name.conf',          config_file => 'name.conf',
47          [code_page => 'ISO-8859-2',]          code_page => 'ISO-8859-2',
48            low_mem => 1,
49            filter => {
50                    'lower' => sub { lc($_[0]) },
51            },
52   );   );
53    
54  Default C<code_page> is C<ISO-8859-2>.  Default C<code_page> is C<ISO-8859-2>.
55    
56  It will also read configuration files  Default is not to use C<low_mem> options (see L<MEMORY USAGE> below).
57    
58    There is optinal parametar C<filter> which specify different filters which
59    can be applied using C<filter{name}> notation.
60    Same filters can be used in Template Toolkit files.
61    
62    This method will also read configuration files
63  C<global.conf> (used by indexer and Web font-end)  C<global.conf> (used by indexer and Web font-end)
64  and configuration file specified by C<config_file>  and configuration file specified by C<config_file>
65  which describes databases to be indexed.  which describes databases to be indexed.
# Line 54  sub new { Line 80  sub new {
80          my $self = {@_};          my $self = {@_};
81          bless($self, $class);          bless($self, $class);
82    
83            $self->{'start_t'} = time();
84    
85          my $log_file = $self->{'log'} || "log.conf";          my $log_file = $self->{'log'} || "log.conf";
86          Log::Log4perl->init($log_file);          Log::Log4perl->init($log_file);
87    
# Line 95  sub new { Line 123  sub new {
123          # create Template toolkit instance          # create Template toolkit instance
124          $self->{'tt'} = Template->new(          $self->{'tt'} = Template->new(
125                  INCLUDE_PATH => ($self->{'global_config_file'}->{'output_template'} || './output_template'),                  INCLUDE_PATH => ($self->{'global_config_file'}->{'output_template'} || './output_template'),
126  #               FILTERS => {                  FILTERS => $self->{'filter'},
 #                       'foo' => \&foo_filter,  
 #               },  
127                  EVAL_PERL => 1,                  EVAL_PERL => 1,
128          );          );
129    
130            # running with low_mem flag? well, use DBM::Deep then.
131            if ($self->{'low_mem'}) {
132                    $log->info("running with low_mem which impacts performance (<32 Mb memory usage)");
133    
134                    my $db_file = "data.db";
135    
136                    if (-e $db_file) {
137                            unlink $db_file or $log->logdie("can't remove '$db_file' from last run");
138                            $log->debug("removed '$db_file' from last run");
139                    }
140    
141                    require DBM::Deep;
142    
143                    my $db = new DBM::Deep $db_file;
144    
145                    $log->logdie("DBM::Deep error: $!") unless ($db);
146    
147                    if ($db->error()) {
148                            $log->logdie("can't open '$db_file' under low_mem: ",$db->error());
149                    } else {
150                            $log->debug("using file '$db_file' for DBM::Deep");
151                    }
152    
153                    $self->{'db'} = $db;
154            }
155    
156            $log->debug("filters defined: ",Dumper($self->{'filter'}));
157    
158          return $self;          return $self;
159  }  }
160    
161  =head2 open_isis  =head2 open_isis
162    
163  Open CDS/ISIS database using OpenIsis module and read all records to memory.  Open CDS/ISIS, WinISIS or IsisMarc database using IsisDB or OpenIsis module
164    and read all records to memory.
165    
166   $webpac->open_isis(   $webpac->open_isis(
167          filename => '/data/ISIS/ISIS',          filename => '/data/ISIS/ISIS',
168          code_page => '852',          code_page => '852',
169          limit_mfn => '500',          limit_mfn => 500,
170            start_mfn => 6000,
171          lookup => [ ... ],          lookup => [ ... ],
172   );   );
173    
174  By default, ISIS code page is assumed to be C<852>.  By default, ISIS code page is assumed to be C<852>.
175    
176    If optional parametar C<start_mfn> is set, this will be first MFN to read
177    from database (so you can skip beginning of your database if you need to).
178    
179  If optional parametar C<limit_mfn> is set, it will read just 500 records  If optional parametar C<limit_mfn> is set, it will read just 500 records
180  from database in example above.  from database in example above.
181    
# Line 144  sub open_isis { Line 203  sub open_isis {
203          $log->logcroak("need filename") if (! $arg->{'filename'});          $log->logcroak("need filename") if (! $arg->{'filename'});
204          my $code_page = $arg->{'code_page'} || '852';          my $code_page = $arg->{'code_page'} || '852';
205    
206          use OpenIsis;          $log->logdie("can't find database ",$arg->{'filename'}) unless (glob($arg->{'filename'}.'.*'));
207    
208            # store data in object
209            $self->{'isis_filename'} = $arg->{'filename'};
210            $self->{'isis_code_page'} = $code_page;
211    
212          #$self->{'isis_code_page'} = $code_page;          #$self->{'isis_code_page'} = $code_page;
213    
# Line 152  sub open_isis { Line 215  sub open_isis {
215          my $cp = Text::Iconv->new($code_page,$self->{'code_page'});          my $cp = Text::Iconv->new($code_page,$self->{'code_page'});
216    
217          $log->info("reading ISIS database '",$arg->{'filename'},"'");          $log->info("reading ISIS database '",$arg->{'filename'},"'");
218            $log->debug("isis code page: $code_page");
219    
220            my ($isis_db,$maxmfn);
221    
222            if ($have_openisis) {
223                    $log->debug("using OpenIsis perl bindings");
224                    $isis_db = OpenIsis::open($arg->{'filename'});
225                    $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;
226            } elsif ($have_biblio_isis) {
227                    $log->debug("using Biblio::Isis");
228                    use Biblio::Isis;
229                    $isis_db = new Biblio::Isis(
230                            isisdb => $arg->{'filename'},
231                            include_deleted => 1,
232                            hash_filter => sub {
233                                    my $l = shift || return;
234                                    $l = $cp->convert($l);
235                                    return $l;
236                            },
237                    );
238                    $maxmfn = $isis_db->count;
239    
240                    unless ($maxmfn) {
241                            $log->logwarn("no records in database ", $arg->{'filename'}, ", skipping...");
242                            return;
243                    }
244    
245            } else {
246                    $log->logdie("Can't find supported ISIS library for perl. I suggent that you install Bilbio::Isis from CPAN.");
247            }
248    
         my $isis_db = OpenIsis::open($arg->{'filename'});  
249    
250          my $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;          my $startmfn = 1;
251    
252            if (my $s = $self->{'start_mfn'}) {
253                    $log->info("skipping to MFN $s");
254                    $startmfn = $s;
255            } else {
256                    $self->{'start_mfn'} = $startmfn;
257            }
258    
259          $maxmfn = $self->{limit_mfn} if ($self->{limit_mfn});          $maxmfn = $startmfn + $self->{limit_mfn} if ($self->{limit_mfn});
260    
261            $log->info("processing ",($maxmfn-$startmfn)." records using ",( $have_openisis ? 'OpenIsis' : 'Biblio::Isis'));
262    
         $log->info("processing $maxmfn records...");  
263    
264          # read database          # read database
265          for (my $mfn = 1; $mfn <= $maxmfn; $mfn++) {          for (my $mfn = $startmfn; $mfn <= $maxmfn; $mfn++) {
266    
267    
268                    $log->debug("mfn: $mfn\n");
269    
270                    my $rec;
271    
272                  # read record                  if ($have_openisis) {
273                  my $row = OpenIsis::read( $isis_db, $mfn );  
274                  foreach my $k (keys %{$row}) {                          # read record using OpenIsis
275                          if ($k ne "mfn") {                          my $row = OpenIsis::read( $isis_db, $mfn );
276                                  foreach my $l (@{$row->{$k}}) {                          foreach my $k (keys %{$row}) {
277                                          $l = $cp->convert($l);                                  if ($k ne "mfn") {
278                                          # has subfields?                                          foreach my $l (@{$row->{$k}}) {
279                                          my $val;                                                  $l = $cp->convert($l);
280                                          if ($l =~ m/\^/) {                                                  # has subfields?
281                                                  foreach my $t (split(/\^/,$l)) {                                                  my $val;
282                                                          next if (! $t);                                                  if ($l =~ m/\^/) {
283                                                          $val->{substr($t,0,1)} = substr($t,1);                                                          foreach my $t (split(/\^/,$l)) {
284                                                                    next if (! $t);
285                                                                    $val->{substr($t,0,1)} = substr($t,1);
286                                                            }
287                                                    } else {
288                                                            $val = $l;
289                                                  }                                                  }
                                         } else {  
                                                 $val = $l;  
                                         }  
290    
291                                          push @{$self->{'data'}->{$mfn}->{$k}}, $val;                                                  push @{$rec->{$k}}, $val;
292                                            }
293                                    } else {
294                                            push @{$rec->{'000'}}, $mfn;
295                                  }                                  }
296                          }                          }
297    
298                    } elsif ($have_biblio_isis) {
299                            $rec = $isis_db->to_hash($mfn);
300                    } else {
301                            $log->logdie("hum? implementation missing?");
302                    }
303    
304                    $log->confess("record $mfn empty?") unless ($rec);
305    
306                    # store
307                    if ($self->{'low_mem'}) {
308                            $self->{'db'}->put($mfn, $rec);
309                    } else {
310                            $self->{'data'}->{$mfn} = $rec;
311                  }                  }
312    
313                  # create lookup                  # create lookup
                 my $rec = $self->{'data'}->{$mfn};  
314                  $self->create_lookup($rec, @{$arg->{'lookup'}});                  $self->create_lookup($rec, @{$arg->{'lookup'}});
315    
316                    $self->progress_bar($mfn,$maxmfn);
317    
318          }          }
319    
320          $self->{'current_mfn'} = 1;          $self->{'current_mfn'} = -1;
321            $self->{'last_pcnt'} = 0;
322    
323            $log->debug("max mfn: $maxmfn");
324    
325          # store max mfn and return it.          # store max mfn and return it.
326          return $self->{'max_mfn'} = $maxmfn;          return $self->{'max_mfn'} = $maxmfn;
# Line 213  sub fetch_rec { Line 340  sub fetch_rec {
340    
341          my $log = $self->_get_logger();          my $log = $self->_get_logger();
342    
343          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'});
344    
345            if ($self->{'current_mfn'} == -1) {
346                    $self->{'current_mfn'} = $self->{'start_mfn'};
347            } else {
348                    $self->{'current_mfn'}++;
349            }
350    
351            my $mfn = $self->{'current_mfn'};
352    
353          if ($mfn > $self->{'max_mfn'}) {          if ($mfn > $self->{'max_mfn'}) {
354                  $self->{'current_mfn'} = $self->{'max_mfn'};                  $self->{'current_mfn'} = $self->{'max_mfn'};
355                    $log->debug("at EOF");
356                  return;                  return;
357          }          }
358    
359          return $self->{'data'}->{$mfn};          $self->progress_bar($mfn,$self->{'max_mfn'});
360    
361            if ($self->{'low_mem'}) {
362                    return $self->{'db'}->get($mfn);
363            } else {
364                    return $self->{'data'}->{$mfn};
365            }
366    }
367    
368    =head2 mfn
369    
370    Returns current record number (MFN).
371    
372     print $webpac->mfn;
373    
374    =cut
375    
376    sub mfn {
377            my $self = shift;
378            return $self->{'current_mfn'};
379    }
380    
381    =head2 progress_bar
382    
383    Draw progress bar on STDERR.
384    
385     $webpac->progress_bar($current, $max);
386    
387    =cut
388    
389    sub progress_bar {
390            my $self = shift;
391    
392            my ($curr,$max) = @_;
393    
394            my $log = $self->_get_logger();
395    
396            $log->logconfess("no current value!") if (! $curr);
397            $log->logconfess("no maximum value!") if (! $max);
398    
399            if ($curr > $max) {
400                    $max = $curr;
401                    $log->debug("overflow to $curr");
402            }
403    
404            $self->{'last_pcnt'} ||= 1;
405    
406            my $p = int($curr * 100 / $max) || 1;
407    
408            # reset on re-run
409            if ($p < $self->{'last_pcnt'}) {
410                    $self->{'last_pcnt'} = $p;
411                    $self->{'start_t'} = time();
412            }
413    
414            if ($p != $self->{'last_pcnt'}) {
415    
416                    my $t = time();
417                    my $rate = ($curr / ($t - $self->{'start_t'} || 1));
418                    my $eta = ($max-$curr) / ($rate || 1);
419                    printf STDERR ("%5d [%-38s] %-5d %0.1f/s %s\r",$curr,"=" x ($p/3)."$p%>", $max, $rate, $self->fmt_time($eta));
420                    $self->{'last_pcnt'} = $p;
421                    $self->{'last_curr'} = $curr;
422            }
423            print STDERR "\n" if ($p == 100);
424    }
425    
426    =head2 fmt_time
427    
428    Format time (in seconds) for display.
429    
430     print $webpac->fmt_time(time());
431    
432    This method is called by L<progress_bar> to display remaining time.
433    
434    =cut
435    
436    sub fmt_time {
437            my $self = shift;
438    
439            my $t = shift || 0;
440            my $out = "";
441    
442            my ($ss,$mm,$hh) = gmtime($t);
443            $out .= "${hh}h" if ($hh);
444            $out .= sprintf("%02d:%02d", $mm,$ss);
445            $out .= "  " if ($hh == 0);
446            return $out;
447  }  }
448    
449  =head2 open_import_xml  =head2 open_import_xml
# Line 246  sub open_import_xml { Line 469  sub open_import_xml {
469    
470          $self->{'tag'} = $type2tag{$type_base};          $self->{'tag'} = $type2tag{$type_base};
471    
472          $log->debug("using type '",$self->{'type'},"' tag <",$self->{'tag'},">") if ($self->{'debug'});          $log->info("using type '",$self->{'type'},"' tag <",$self->{'tag'},">");
473    
474          my $f = "./import_xml/".$self->{'type'}.".xml";          my $f = "./import_xml/".$self->{'type'}.".xml";
475          $log->logconfess("import_xml file '$f' doesn't exist!") if (! -e "$f");          $log->logconfess("import_xml file '$f' doesn't exist!") if (! -e "$f");
476    
477          $log->debug("reading '$f'") if ($self->{'debug'});          $log->info("reading '$f'");
478    
479            $self->{'import_xml_file'} = $f;
480    
481          $self->{'import_xml'} = XMLin($f,          $self->{'import_xml'} = XMLin($f,
482                  ForceArray => [ $self->{'tag'}, 'config', 'format' ],                  ForceArray => [ $self->{'tag'}, 'config', 'format' ],
                 ForceContent => 1  
483          );          );
484    
485            $log->debug("import xml is ",sub { Dumper($self->{'import_xml'}) });
486    
487  }  }
488    
489  =head2 create_lookup  =head2 create_lookup
# Line 279  sub create_lookup { Line 505  sub create_lookup {
505          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
506    
507          foreach my $i (@_) {          foreach my $i (@_) {
508                  if ($i->{'eval'}) {                  $log->logconfess("need key") unless defined($i->{'key'});
509                          my $eval = $self->fill_in($rec,$i->{'eval'});                  $log->logconfess("need val") unless defined($i->{'val'});
510                          my $key = $self->fill_in($rec,$i->{'key'});  
511                          my @val = $self->fill_in($rec,$i->{'val'});                  if (defined($i->{'eval'})) {
512                          if ($key && @val && eval $eval) {                          # eval first, so we can skip fill_in for key and val
513                            my $eval = $self->fill_in($rec,$i->{'eval'}) || next;
514                            if ($self->_eval($eval)) {
515                                    my $key = $self->fill_in($rec,$i->{'key'}) || next;
516                                    my @val = $self->fill_in($rec,$i->{'val'}) || next;
517                                    $log->debug("stored $key = ",sub { join(" | ",@val) });
518                                  push @{$self->{'lookup'}->{$key}}, @val;                                  push @{$self->{'lookup'}->{$key}}, @val;
519                          }                          }
520                  } else {                  } else {
521                          my $key = $self->fill_in($rec,$i->{'key'});                          my $key = $self->fill_in($rec,$i->{'key'}) || next;
522                          my @val = $self->fill_in($rec,$i->{'val'});                          my @val = $self->fill_in($rec,$i->{'val'}) || next;
523                          if ($key && @val) {                          $log->debug("stored $key = ",sub { join(" | ",@val) });
524                                  push @{$self->{'lookup'}->{$key}}, @val;                          push @{$self->{'lookup'}->{$key}}, @val;
                         }  
525                  }                  }
526          }          }
527  }  }
# Line 322  sub get_data { Line 552  sub get_data {
552    
553          if ($$rec->{$f}) {          if ($$rec->{$f}) {
554                  return '' if (! $$rec->{$f}->[$i]);                  return '' if (! $$rec->{$f}->[$i]);
555                    no strict 'refs';
556                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {                  if ($sf && $$rec->{$f}->[$i]->{$sf}) {
557                          $$found++ if (defined($$found));                          $$found++ if (defined($$found));
558                          return $$rec->{$f}->[$i]->{$sf};                          return $$rec->{$f}->[$i]->{$sf};
# Line 362  Following example will read second value Line 593  Following example will read second value
593  This function B<does not> perform parsing of format to inteligenty skip  This function B<does not> perform parsing of format to inteligenty skip
594  delimiters before fields which aren't used.  delimiters before fields which aren't used.
595    
596    This method will automatically decode UTF-8 string to local code page
597    if needed.
598    
599  =cut  =cut
600    
601  sub fill_in {  sub fill_in {
# Line 374  sub fill_in { Line 608  sub fill_in {
608          # iteration (for repeatable fields)          # iteration (for repeatable fields)
609          my $i = shift || 0;          my $i = shift || 0;
610    
611            $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));
612    
613          # FIXME remove for speedup?          # FIXME remove for speedup?
614          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
615    
616            if (utf8::is_utf8($format)) {
617                    $format = $self->_x($format);
618            }
619    
620          my $found = 0;          my $found = 0;
621    
622          my $eval_code;          my $eval_code;
623          # remove eval{...} from beginning          # remove eval{...} from beginning
624          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
625    
626            my $filter_name;
627            # remove filter{...} from beginning
628            $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
629    
630          # do actual replacement of placeholders          # do actual replacement of placeholders
631          $format =~ s/v(\d+)(?:\^(\w))*/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;          # repeatable fields
632            $format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;
633            # non-repeatable fields
634            $format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found)/ges;
635    
636          if ($found) {          if ($found) {
637                    $log->debug("format: $format");
638                  if ($eval_code) {                  if ($eval_code) {
639                          my $eval = $self->fill_in($rec,$eval_code,$i);                          my $eval = $self->fill_in($rec,$eval_code,$i);
640                          return if (! $self->_eval($eval));                          return if (! $self->_eval($eval));
641                  }                  }
642                    if ($filter_name && $self->{'filter'}->{$filter_name}) {
643                            $log->debug("filter '$filter_name' for $format");
644                            $format = $self->{'filter'}->{$filter_name}->($format);
645                            return unless(defined($format));
646                            $log->debug("filter result: $format");
647                    }
648                  # do we have lookups?                  # do we have lookups?
649                  $log->debug("test format '$format' for lookups");                  if ($format =~ /$LOOKUP_REGEX/o) {
650                  if ($format =~ /\[[^\[\]]+\]/o) {                          $log->debug("format '$format' has lookup");
651                          return $self->lookup($format);                          return $self->lookup($format);
652                  } else {                  } else {
653                          return $format;                          return $format;
# Line 420  sub lookup { Line 674  sub lookup {
674    
675          my $tmp = shift || $log->logconfess("need format");          my $tmp = shift || $log->logconfess("need format");
676    
677          if ($tmp =~ /\[[^\[\]]+\]/o) {          if ($tmp =~ /$LOOKUP_REGEX/o) {
678                  my @in = ( $tmp );                  my @in = ( $tmp );
679    
680                  $log->debug("lookup for: ",$tmp);                  $log->debug("lookup for: ",$tmp);
681    
682                  my @out;                  my @out;
683                  while (my $f = shift @in) {                  while (my $f = shift @in) {
684                          if ($f =~ /\[([^\[\]]+)\]/) {                          if ($f =~ /$LOOKUP_REGEX_SAVE/o) {
685                                  my $k = $1;                                  my $k = $1;
686                                  if ($self->{'lookup'}->{$k}) {                                  if ($self->{'lookup'}->{$k}) {
687                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {
688                                                  my $tmp2 = $f;                                                  my $tmp2 = $f;
689                                                  $tmp2 =~ s/\[$k\]/$nv/g;                                                  $tmp2 =~ s/lookup{$k}/$nv/g;
690                                                  push @in, $tmp2;                                                  push @in, $tmp2;
691                                          }                                          }
692                                  } else {                                  } else {
# Line 442  sub lookup { Line 696  sub lookup {
696                                  push @out, $f;                                  push @out, $f;
697                          }                          }
698                  }                  }
699                    $log->logconfess("return is array and it's not expected!") unless wantarray;
700                  return @out;                  return @out;
701          } else {          } else {
702                  return $tmp;                  return $tmp;
# Line 472  sub parse { Line 727  sub parse {
727    
728          $i = 0 if (! $i);          $i = 0 if (! $i);
729    
730          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'});
731    
732          my @out;          my @out;
733    
734            $log->debug("format: $format");
735    
736          my $eval_code;          my $eval_code;
737          # remove eval{...} from beginning          # remove eval{...} from beginning
738          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
739    
740            my $filter_name;
741            # remove filter{...} from beginning
742            $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
743    
744          my $prefix;          my $prefix;
745          my $all_found=0;          my $all_found=0;
746    
747          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))*//s) {          while ($format =~ s/^(.*?)(v|s)(\d+)(?:\^(\w))?//s) {
748    
749                  my $del = $1 || '';                  my $del = $1 || '';
750                  $prefix ||= $del if ($all_found == 0);                  $prefix ||= $del if ($all_found == 0);
751    
752                    # repeatable index
753                    my $r = $i;
754                    $r = 0 if (lc("$2") eq 's');
755    
756                  my $found = 0;                  my $found = 0;
757                  my $tmp = $self->get_data(\$rec,$2,$3,$i,\$found);                  my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found);
758    
759                  if ($found) {                  if ($found) {
760                          push @out, $del;                          push @out, $del;
# Line 500  sub parse { Line 765  sub parse {
765    
766          return if (! $all_found);          return if (! $all_found);
767    
768          my $out = join('',@out) . $format;          my $out = join('',@out);
769    
770            if ($out) {
771                    # add rest of format (suffix)
772                    $out .= $format;
773    
774          # add prefix if not there                  # add prefix if not there
775          $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);                  $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);
776    
777                    $log->debug("result: $out");
778            }
779    
780          if ($eval_code) {          if ($eval_code) {
781                  my $eval = $self->fill_in($rec,$eval_code,$i);                  my $eval = $self->fill_in($rec,$eval_code,$i) || return;
782                  $log->debug("about to eval ",$eval," [$out]");                  $log->debug("about to eval{$eval} format: $out");
783                  return if (! $self->_eval($eval));                  return if (! $self->_eval($eval));
784          }          }
785            
786            if ($filter_name && $self->{'filter'}->{$filter_name}) {
787                    $log->debug("about to filter{$filter_name} format: $out");
788                    $out = $self->{'filter'}->{$filter_name}->($out);
789                    return unless(defined($out));
790                    $log->debug("filter result: $out");
791            }
792    
793          return $out;          return $out;
794  }  }
# Line 539  sub parse_to_arr { Line 818  sub parse_to_arr {
818                  push @arr, $v;                  push @arr, $v;
819          }          }
820    
821            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
822    
823            return @arr;
824    }
825    
826    =head2 fill_in_to_arr
827    
828    Similar to C<fill_in>, but returns array of all repeatable fields. Usable
829    for fields which have lookups, so they shouldn't be parsed but rather
830    C<fill_id>ed.
831    
832     my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]');
833    
834    =cut
835    
836    sub fill_in_to_arr {
837            my $self = shift;
838    
839            my ($rec, $format_utf8) = @_;
840    
841            my $log = $self->_get_logger();
842    
843            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
844            return if (! $format_utf8);
845    
846            my $i = 0;
847            my @arr;
848    
849            while (my @v = $self->fill_in($rec,$format_utf8,$i++)) {
850                    push @arr, @v;
851            }
852    
853            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
854    
855          return @arr;          return @arr;
856  }  }
857    
858    =head2 sort_arr
859    
860    Sort array ignoring case and html in data
861    
862     my @sorted = $webpac->sort_arr(@unsorted);
863    
864    =cut
865    
866    sub sort_arr {
867            my $self = shift;
868    
869            my $log = $self->_get_logger();
870    
871            # FIXME add Schwartzian Transformation?
872    
873            my @sorted = sort {
874                    $a =~ s#<[^>]+/*>##;
875                    $b =~ s#<[^>]+/*>##;
876                    lc($b) cmp lc($a)
877            } @_;
878            $log->debug("sorted values: ",sub { join(", ",@sorted) });
879    
880            return @sorted;
881    }
882    
883    
884  =head2 data_structure  =head2 data_structure
885    
886  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 888  It is used later to produce output.
888    
889   my @ds = $webpac->data_structure($rec);   my @ds = $webpac->data_structure($rec);
890    
891    This method will also set C<$webpac->{'currnet_filename'}> if there is
892    <filename> tag in C<import_xml> and C<$webpac->{'headline'}> if there is
893    <headline> tag.
894    
895  =cut  =cut
896    
897  sub data_structure {  sub data_structure {
# Line 559  sub data_structure { Line 902  sub data_structure {
902          my $rec = shift;          my $rec = shift;
903          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
904    
905            undef $self->{'currnet_filename'};
906            undef $self->{'headline'};
907    
908          my @sorted_tags;          my @sorted_tags;
909          if ($self->{tags_by_order}) {          if ($self->{tags_by_order}) {
910                  @sorted_tags = @{$self->{tags_by_order}};                  @sorted_tags = @{$self->{tags_by_order}};
# Line 569  sub data_structure { Line 915  sub data_structure {
915    
916          my @ds;          my @ds;
917    
918            $log->debug("tags: ",sub { join(", ",@sorted_tags) });
919    
920          foreach my $field (@sorted_tags) {          foreach my $field (@sorted_tags) {
921    
922                  my $row;                  my $row;
# Line 576  sub data_structure { Line 924  sub data_structure {
924  #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'}});
925    
926                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {                  foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
927                          my @v = $self->parse_to_arr($rec,$tag->{'content'});                          my $format = $tag->{'value'} || $tag->{'content'};
928    
929                          next if (! @v);                          $log->debug("format: $format");
930    
931                          # does tag have type?                          my @v;
932                          if ($tag->{'type'}) {                          if ($format =~ /$LOOKUP_REGEX/o) {
933                                  push @{$row->{$tag->{'type'}}}, @v;                                  @v = $self->fill_in_to_arr($rec,$format);
934                          } else {                          } else {
935                                  push @{$row->{'display'}}, @v;                                  @v = $self->parse_to_arr($rec,$format);
936                                  push @{$row->{'swish'}}, @v;                          }
937                            next if (! @v);
938    
939                            if ($tag->{'sort'}) {
940                                    @v = $self->sort_arr(@v);
941                            }
942    
943                            # use format?
944                            if ($tag->{'format_name'}) {
945                                    @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
946                          }                          }
947    
948                            if ($field eq 'filename') {
949                                    $self->{'current_filename'} = join('',@v);
950                                    $log->debug("filename: ",$self->{'current_filename'});
951                            } elsif ($field eq 'headline') {
952                                    $self->{'headline'} .= join('',@v);
953                                    $log->debug("headline: ",$self->{'headline'});
954                                    next; # don't return headline in data_structure!
955                            }
956    
957                            # delimiter will join repeatable fields
958                            if ($tag->{'delimiter'}) {
959                                    @v = ( join($tag->{'delimiter'}, @v) );
960                            }
961    
962                            # default types
963                            my @types = qw(display swish);
964                            # override by type attribute
965                            @types = ( $tag->{'type'} ) if ($tag->{'type'});
966    
967                            foreach my $type (@types) {
968                                    # append to previous line?
969                                    $log->debug("type: $type ",sub { join(" ",@v) }, $row->{'append'} || 'no append');
970                                    if ($tag->{'append'}) {
971    
972                                            # I will delimit appended part with
973                                            # delimiter (or ,)
974                                            my $d = $tag->{'delimiter'};
975                                            # default delimiter
976                                            $d ||= " ";
977    
978                                            my $last = pop @{$row->{$type}};
979                                            $d = "" if (! $last);
980                                            $last .= $d . join($d, @v);
981                                            push @{$row->{$type}}, $last;
982    
983                                    } else {
984                                            push @{$row->{$type}}, @v;
985                                    }
986                            }
987    
988    
989                  }                  }
990    
991                  if ($row) {                  if ($row) {
992                          $row->{'tag'} = $field;                          $row->{'tag'} = $field;
993    
994                            # TODO: name_sigular, name_plural
995                            my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
996                            $row->{'name'} = $name ? $self->_x($name) : $field;
997    
998                            # post-sort all values in field
999                            if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {
1000                                    $log->warn("sort at field tag not implemented");
1001                            }
1002    
1003                          push @ds, $row;                          push @ds, $row;
1004    
1005                            $log->debug("row $field: ",sub { Dumper($row) });
1006                  }                  }
1007    
1008          }          }
# Line 629  sub output { Line 1040  sub output {
1040          return $out;          return $out;
1041  }  }
1042    
1043    =head2 output_file
1044    
1045    Create output from in-memory data structure using Template Toolkit template
1046    to a file.
1047    
1048     $webpac->output_file(
1049            file => 'out.txt',
1050            template => 'text.tt',
1051            data => @ds
1052     );
1053    
1054    =cut
1055    
1056    sub output_file {
1057            my $self = shift;
1058    
1059            my $args = {@_};
1060    
1061            my $log = $self->_get_logger();
1062    
1063            my $file = $args->{'file'} || $log->logconfess("need file name");
1064    
1065            $log->debug("creating file ",$file);
1066    
1067            open(my $fh, ">", $file) || $log->logdie("can't open output file '$file': $!");
1068            print $fh $self->output(
1069                    template => $args->{'template'},
1070                    data => $args->{'data'},
1071            ) || $log->logdie("print: $!");
1072            close($fh) || $log->logdie("close: $!");
1073    }
1074    
1075    =head2 apply_format
1076    
1077    Apply format specified in tag with C<format_name="name"> and
1078    C<format_delimiter=";;">.
1079    
1080     my $text = $webpac->apply_format($format_name,$format_delimiter,$data);
1081    
1082    Formats can contain C<lookup{...}> if you need them.
1083    
1084    =cut
1085    
1086    sub apply_format {
1087            my $self = shift;
1088    
1089            my ($name,$delimiter,$data) = @_;
1090    
1091            my $log = $self->_get_logger();
1092    
1093            if (! $self->{'import_xml'}->{'format'}->{$name}) {
1094                    $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});
1095                    return $data;
1096            }
1097    
1098            $log->warn("no delimiter for format $name") if (! $delimiter);
1099    
1100            my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");
1101    
1102            my @data = split(/\Q$delimiter\E/, $data);
1103    
1104            my $out = sprintf($format, @data);
1105            $log->debug("using format $name [$format] on $data to produce: $out");
1106    
1107            if ($out =~ m/$LOOKUP_REGEX/o) {
1108                    return $self->lookup($out);
1109            } else {
1110                    return $out;
1111            }
1112    
1113    }
1114    
1115    
1116  #  #
1117  #  #
1118  #  #
# Line 661  sub _eval { Line 1145  sub _eval {
1145    
1146          $log->debug("eval: ",$code," [",$ret,"]");          $log->debug("eval: ",$code," [",$ret,"]");
1147    
1148          return $ret || 0;          return $ret || undef;
1149  }  }
1150    
1151  =head2 _sort_by_order  =head2 _sort_by_order
# Line 681  sub _sort_by_order { Line 1165  sub _sort_by_order {
1165          return $va <=> $vb;          return $va <=> $vb;
1166  }  }
1167    
1168    =head2 _get_logger
1169    
1170    Get C<Log::Log4perl> object with a twist: domains are defined for each
1171    method
1172    
1173     my $log = $webpac->_get_logger();
1174    
1175    =cut
1176    
1177  sub _get_logger {  sub _get_logger {
1178          my $self = shift;          my $self = shift;
1179    
1180          my @c = caller(1);          my $name = (caller(1))[3] || caller;
1181          return get_logger($c[3]);          return get_logger($name);
1182    }
1183    
1184    =head2 _x
1185    
1186    Convert string from UTF-8 to code page defined in C<import_xml>.
1187    
1188     my $text = $webpac->_x('utf8 text');
1189    
1190    =cut
1191    
1192    sub _x {
1193            my $self = shift;
1194            my $utf8 = shift || return;
1195    
1196            return $self->{'utf2cp'}->convert($utf8) ||
1197                    $self->_get_logger()->logwarn("can't convert '$utf8'");
1198  }  }
1199    
1200  #  #
# Line 706  B<This is different from normal Log4perl Line 1215  B<This is different from normal Log4perl
1215  also use method names, and not only classes (which are just few)  also use method names, and not only classes (which are just few)
1216  to filter logging.  to filter logging.
1217    
1218    
1219    =head1 MEMORY USAGE
1220    
1221    C<low_mem> options is double-edged sword. If enabled, WebPAC
1222    will run on memory constraint machines (which doesn't have enough
1223    physical RAM to create memory structure for whole source database).
1224    
1225    If your machine has 512Mb or more of RAM and database is around 10000 records,
1226    memory shouldn't be an issue. If you don't have enough physical RAM, you
1227    might consider using virtual memory (if your operating system is handling it
1228    well, like on FreeBSD or Linux) instead of dropping to L<DBD::Deep> to handle
1229    parsed structure of ISIS database (this is what C<low_mem> option does).
1230    
1231    Hitting swap at end of reading source database is probably o.k. However,
1232    hitting swap before 90% will dramatically decrease performance and you will
1233    be better off with C<low_mem> and using rest of availble memory for
1234    operating system disk cache (Linux is particuallary good about this).
1235    However, every access to database record will require disk access, so
1236    generation phase will be slower 10-100 times.
1237    
1238    Parsed structures are essential - you just have option to trade RAM memory
1239    (which is fast) for disk space (which is slow). Be sure to have planty of
1240    disk space if you are using C<low_mem> and thus L<DBD::Deep>.
1241    
1242    However, when WebPAC is running on desktop machines (or laptops :-), it's
1243    highly undesireable for system to start swapping. Using C<low_mem> option can
1244    reduce WecPAC memory usage to around 64Mb for same database with lookup
1245    fields and sorted indexes which stay in RAM. Performance will suffer, but
1246    memory usage will really be minimal. It might be also more confortable to
1247    run WebPAC reniced on those machines.
1248    
1249  =cut  =cut
1250    
1251  1;  1;
Legend:
Removed from v.372  
changed lines
  Added in v.707
  ViewVC Help
Powered by ViewVC 1.1.26