/[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 352 by dpavlin, Tue Jun 15 22:40:07 2004 UTC revision 434 by dpavlin, Mon Sep 13 14:39:16 2004 UTC
# Line 1  Line 1 
1  package WebPac;  package WebPAC;
2    
3    use warnings;
4    use strict;
5    
6  use Carp;  use Carp;
7    use Text::Iconv;
8    use Config::IniFiles;
9    use XML::Simple;
10    use Template;
11    use Log::Log4perl qw(get_logger :levels);
12    use Time::HiRes qw(time);
13    
14    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
24    
25  =head1 DESCRIPTION  =head1 DESCRIPTION
26    
27  This class does basic thing for WebPac.  This module implements methods used by WebPAC.
28    
29  =head1 METHODS  =head1 METHODS
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    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)
47    and configuration file specified by C<config_file>
48    which describes databases to be indexed.
49    
50  =cut  =cut
51    
52    # mapping between data type and tag which specify
53    # format in XML file
54    my %type2tag = (
55            'isis' => 'isis',
56    #       'excel' => 'column',
57    #       'marc' => 'marc',
58    #       'feed' => 'feed'
59    );
60    
61  sub new {  sub new {
62          my $class = shift;          my $class = shift;
63          my $self = {@_};          my $self = {@_};
64          bless($self, $class);          bless($self, $class);
65    
66          # fill in default values          $self->{'start_t'} = time();
         # output codepage  
         $self->{'code_page'} = 'ISO-8859-2' if (! $self->{'code_page'});  
67    
68          return $self;          my $log_file = $self->{'log'} || "log.conf";
69  }          Log::Log4perl->init($log_file);
   
 =head2 read_global_config  
70    
71  Read global configuration (used by indexer and Web font-end)          my $log = $self->_get_logger();
72    
73  =cut          # fill in default values
74            # output codepage
75            $self->{'code_page'} = 'ISO-8859-2' if (! $self->{'code_page'});
76    
77  sub read_global_config {          #
78          my $self = shift;          # read global.conf
79            #
80            $log->debug("read 'global.conf'");
81    
82          $self->{global_config_file} = 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 56  sub read_global_config { Line 89  sub read_global_config {
89                          dbi_passwd                          dbi_passwd
90                          show_progress                          show_progress
91                          my_unac_filter                          my_unac_filter
92                            output_template
93                  )) {                  )) {
94                  $self->{global_config}->{$var} = $self->{global_config_file}->val('global', $var);                  $self->{'global_config'}->{$var} = $config->val('global', $var);
95          }          }
96    
97          return $self;          #
98  }          # read indexer config file
99            #
100  =head2 read_indexer_config  
101            $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
104            $self->{'utf2cp'} = Text::Iconv->new('UTF-8' ,$self->{'code_page'});
105    
106            # create Template toolkit instance
107            $self->{'tt'} = Template->new(
108                    INCLUDE_PATH => ($self->{'global_config_file'}->{'output_template'} || './output_template'),
109    #               FILTERS => {
110    #                       'foo' => \&foo_filter,
111    #               },
112                    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  Read indexer configuration (specify databases, types etc.)                  require DBM::Deep;
127    
128  =cut                  my $db = new DBM::Deep $db_file;
129    
130  sub read_indexer_config {                  $log->logdie("DBM::Deep error: $!") unless ($db);
         my $self = shift;  
131    
132          $self->{indexer_config_file} = new Config::IniFiles( -file => $self->{config_file} ) || croak "can't open '$self->{config_file}'";                  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          # read global config parametars                  $self->{'db'} = $db;
         foreach my $var (qw(  
                         dbi_dbd  
                         dbi_dsn  
                         dbi_user  
                         dbi_passwd  
                         show_progress  
                         my_unac_filter  
                 )) {  
                 $self->{global_config}->{$var} = $self->{global_config_file}->val('global', $var);  
139          }          }
140    
141          return $self;          return $self;
# Line 96  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 C<limit_mfn> is set, it will read just 500 records from  If optional parametar C<start_mfn> is set, this will be first MFN to read
159  database in example above.  from database (so you can skip beginning of your database if you need to).
160    
161  Returns number of last record read into memory (size of database, really).  If optional parametar C<limit_mfn> is set, it will read just 500 records
162    from database in example above.
163    
164  C<lookup> argument is an array of lookups to create. Each lookup must have C<key> and  C<lookup> argument is an array of lookups to create. Each lookup must have C<key> and
165  C<val>. Optional parametar C<eval> is perl code to evaluate before storing  C<val>. Optional parametar C<eval> is perl code to evaluate before storing
# Line 118  value in index. Line 172  value in index.
172      'val' => 'v900' },      'val' => 'v900' },
173   ]   ]
174    
175    Returns number of last record read into memory (size of database, really).
176    
177  =cut  =cut
178    
179  sub open_isis {  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            # store data in object
189            $self->{'isis_filename'} = $arg->{'filename'};
190            $self->{'isis_code_page'} = $code_page;
191    
192            use OpenIsis;
193    
194          #$self->{'isis_code_page'} = $code_page;          #$self->{'isis_code_page'} = $code_page;
195    
196          # create Text::Iconv object          # create Text::Iconv object
197          my $cp = Text::Iconv->new($code_page,$self->{'code_page'});          my $cp = Text::Iconv->new($code_page,$self->{'code_page'});
198    
199            $log->info("reading ISIS database '",$arg->{'filename'},"'");
200            $log->debug("isis code page: $code_page");
201    
202          my $isis_db = OpenIsis::open($arg->{'filename'});          my $isis_db = OpenIsis::open($arg->{'filename'});
203    
204          my $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;          my $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;
205            my $startmfn = 1;
206    
207            if (my $s = $self->{'start_mfn'}) {
208                    $log->info("skipping to MFN $s");
209                    $startmfn = $s;
210            }
211    
212            $maxmfn = $startmfn + $self->{limit_mfn} if ($self->{limit_mfn});
213    
214            $log->info("processing ",($maxmfn-$startmfn)." records...");
215    
216          # read database          # read database
217          for (my $mfn = 1; $mfn <= $maxmfn; $mfn++) {          for (my $mfn = $startmfn; $mfn <= $maxmfn; $mfn++) {
218    
219    
220                    $log->debug("mfn: $mfn\n");
221    
222                    my $rec;
223    
224                  # read record                  # read record
225                  my $row = OpenIsis::read( $isis_db, $mfn );                  my $row = OpenIsis::read( $isis_db, $mfn );
# Line 156  sub open_isis { Line 238  sub open_isis {
238                                                  $val = $l;                                                  $val = $l;
239                                          }                                          }
240    
241                                          push @{$self->{'data'}->{$mfn}->{$k}}, $val;                                          push @{$rec->{$k}}, $val;
242                                  }                                  }
243                            } else {
244                                    push @{$rec->{'000'}}, $mfn;
245                          }                          }
246    
247                  }                  }
248    
249                    $log->confess("record $mfn empty?") unless ($rec);
250    
251                    # store
252                    if ($self->{'low_mem'}) {
253                            $self->{'db'}->put($mfn, $rec);
254                    } else {
255                            $self->{'data'}->{$mfn} = $rec;
256                    }
257    
258                  # create lookup                  # create lookup
259                    $self->create_lookup($rec, @{$arg->{'lookup'}});
260    
261                    $self->progress_bar($mfn,$maxmfn);
262    
263            }
264    
265            $self->{'current_mfn'} = $startmfn;
266            $self->{'last_pcnt'} = 0;
267    
268            $log->debug("max mfn: $maxmfn");
269    
270            # store max mfn and return it.
271            return $self->{'max_mfn'} = $maxmfn;
272    }
273    
274    =head2 fetch_rec
275    
276    Fetch next record from database. It will also display progress bar (once
277    it's implemented, that is).
278    
279     my $rec = $webpac->fetch_rec;
280    
281    =cut
282    
283    sub fetch_rec {
284            my $self = shift;
285    
286            my $log = $self->_get_logger();
287    
288            my $mfn = $self->{'current_mfn'}++ || $log->logconfess("it seems that you didn't load database!");
289    
290            if ($mfn > $self->{'max_mfn'}) {
291                    $self->{'current_mfn'} = $self->{'max_mfn'};
292                    $log->debug("at EOF");
293                    return;
294            }
295    
296            $self->progress_bar($mfn,$self->{'max_mfn'});
297    
298            if ($self->{'low_mem'}) {
299                    return $self->{'db'}->get($mfn);
300            } else {
301                    return $self->{'data'}->{$mfn};
302            }
303    }
304    
305    =head2 progress_bar
306    
307    Draw progress bar on STDERR.
308    
309     $webpac->progress_bar($current, $max);
310    
311    =cut
312    
313    sub progress_bar {
314            my $self = shift;
315    
316            my ($curr,$max) = @_;
317    
318            my $log = $self->_get_logger();
319    
320            $log->logconfess("no current value!") if (! $curr);
321            $log->logconfess("no maximum value!") if (! $max);
322    
323            if ($curr > $max) {
324                    $max = $curr;
325                    $log->debug("overflow to $curr");
326            }
327    
328            $self->{'last_pcnt'} ||= 1;
329    
330            my $p = int($curr * 100 / $max);
331    
332            # reset on re-run
333            if ($p < $self->{'last_pcnt'}) {
334                    $self->{'last_pcnt'} = $p;
335                    $self->{'last_t'} = time();
336                    $self->{'last_curr'} = 1;
337            }
338    
339            if ($p != $self->{'last_pcnt'}) {
340    
341                    my $last_curr = $self->{'last_curr'} || $curr;
342                    my $t = time();
343                    my $rate = ($curr - $last_curr) / (($t - $self->{'last_t'} || 1));
344                    my $eta = ($max-$curr) / ($rate || 1);
345                    printf STDERR ("%5d [%-38s] %-5d %0.1f/s %s\r",$curr,"=" x ($p/3)."$p%>", $max, $rate, $self->fmt_time($eta));
346                    $self->{'last_pcnt'} = $p;
347                    $self->{'last_t'} = time();
348                    $self->{'last_curr'} = $curr;
349            }
350            print STDERR "\n" if ($p == 100);
351    }
352    
353    =head2 fmt_time
354    
355                  foreach my $i (@{$arg->{lookup}}) {  Format time (in seconds) for display.
356                          my $rec = $self->{'data'}->{$mfn};  
357                          if ($i->{'eval'}) {   print $webpac->fmt_time(time());
358                                  my $eval = $self->fill_in($rec,$i->{'eval'});  
359                                  my $key = $self->fill_in($rec,$i->{'key'});  This method is called by L<progress_bar> to display remaining time.
360                                  my @val = $self->fill_in($rec,$i->{'val'});  
361                                  if ($key && @val && eval $eval) {  =cut
362                                          push @{$self->{'lookup'}->{$key}}, @val;  
363    sub fmt_time {
364            my $self = shift;
365    
366            my $t = shift || 0;
367            my $out = "";
368    
369            my ($ss,$mm,$hh) = gmtime($t);
370            $out .= "${hh}h" if ($hh);
371            $out .= sprintf("%02d:%02d", $mm,$ss);
372            $out .= "  " if ($hh == 0);
373            return $out;
374    }
375    
376    =head2 open_import_xml
377    
378    Read file from C<import_xml/> directory and parse it.
379    
380     $webpac->open_import_xml(type => 'isis');
381    
382    =cut
383    
384    sub open_import_xml {
385            my $self = shift;
386    
387            my $log = $self->_get_logger();
388    
389            my $arg = {@_};
390            $log->logconfess("need type to load file from import_xml/") if (! $arg->{'type'});
391    
392            $self->{'type'} = $arg->{'type'};
393    
394            my $type_base = $arg->{'type'};
395            $type_base =~ s/_.*$//g;
396    
397            $self->{'tag'} = $type2tag{$type_base};
398    
399            $log->info("using type '",$self->{'type'},"' tag <",$self->{'tag'},">");
400    
401            my $f = "./import_xml/".$self->{'type'}.".xml";
402            $log->logconfess("import_xml file '$f' doesn't exist!") if (! -e "$f");
403    
404            $log->info("reading '$f'");
405    
406            $self->{'import_xml_file'} = $f;
407    
408            $self->{'import_xml'} = XMLin($f,
409                    ForceArray => [ $self->{'tag'}, 'config', 'format' ],
410            );
411    
412            $log->debug("import xml is ",sub { Dumper($self->{'import_xml'}) });
413    
414    }
415    
416    =head2 create_lookup
417    
418    Create lookup from record using lookup definition.
419    
420     $self->create_lookup($rec, @lookups);
421    
422    Called internally by C<open_*> methods.
423    
424    =cut
425    
426    sub create_lookup {
427            my $self = shift;
428    
429            my $log = $self->_get_logger();
430    
431            my $rec = shift || $log->logconfess("need record to create lookup");
432            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
433    
434            foreach my $i (@_) {
435                    $log->logconfess("need key") unless defined($i->{'key'});
436                    $log->logconfess("need val") unless defined($i->{'val'});
437    
438                    if (defined($i->{'eval'})) {
439                            # eval first, so we can skip fill_in for key and val
440                            my $eval = $self->fill_in($rec,$i->{'eval'}) || next;
441                            if ($self->_eval($eval)) {
442                                    my $key = $self->fill_in($rec,$i->{'key'}) || next;
443                                    my @val = $self->fill_in($rec,$i->{'val'}) || next;
444                                    $log->debug("stored $key = ",sub { join(" | ",@val) });
445                                    push @{$self->{'lookup'}->{$key}}, @val;
446                            }
447                    } else {
448                            my $key = $self->fill_in($rec,$i->{'key'}) || next;
449                            my @val = $self->fill_in($rec,$i->{'val'}) || next;
450                            $log->debug("stored $key = ",sub { join(" | ",@val) });
451                            push @{$self->{'lookup'}->{$key}}, @val;
452                    }
453            }
454    }
455    
456    =head2 get_data
457    
458    Returns value from record.
459    
460     my $text = $self->get_data(\$rec,$f,$sf,$i,\$found);
461    
462    Arguments are:
463    record reference C<$rec>,
464    field C<$f>,
465    optional subfiled C<$sf>,
466    index for repeatable values C<$i>.
467    
468    Optinal variable C<$found> will be incremeted if there
469    is field.
470    
471    Returns value or empty string.
472    
473    =cut
474    
475    sub get_data {
476            my $self = shift;
477    
478            my ($rec,$f,$sf,$i,$found) = @_;
479    
480            if ($$rec->{$f}) {
481                    return '' if (! $$rec->{$f}->[$i]);
482                    no strict 'refs';
483                    if ($sf && $$rec->{$f}->[$i]->{$sf}) {
484                            $$found++ if (defined($$found));
485                            return $$rec->{$f}->[$i]->{$sf};
486                    } elsif ($$rec->{$f}->[$i]) {
487                            $$found++ if (defined($$found));
488                            # it still might have subfield, just
489                            # not specified, so we'll dump all
490                            if ($$rec->{$f}->[$i] =~ /HASH/o) {
491                                    my $out;
492                                    foreach my $k (keys %{$$rec->{$f}->[$i]}) {
493                                            $out .= $$rec->{$f}->[$i]->{$k}." ";
494                                  }                                  }
495                                    return $out;
496                          } else {                          } else {
497                                  my $key = $self->fill_in($rec,$i->{'key'});                                  return $$rec->{$f}->[$i];
                                 my @val = $self->fill_in($rec,$i->{'val'});  
                                 if ($key && @val) {  
                                         push @{$self->{'lookup'}->{$key}}, @val;  
                                 }  
498                          }                          }
499                  }                  }
500            } else {
501                    return '';
502          }          }
   
         # store max mfn and return it.  
         return $self->{'max_mfn'} = $maxmfn;  
503  }  }
504    
505  =head2 fill_in  =head2 fill_in
# Line 193  Workhourse of all: takes record from in- Line 508  Workhourse of all: takes record from in-
508  strings with placeholders and returns string or array of with substituted  strings with placeholders and returns string or array of with substituted
509  values from record.  values from record.
510    
511   $webpac->fill_in($rec,'v250^a');   my $text = $webpac->fill_in($rec,'v250^a');
512    
513  Optional argument is ordinal number for repeatable fields. By default,  Optional argument is ordinal number for repeatable fields. By default,
514  it's assume to be first repeatable field.  it's assume to be first repeatable field (fields are perl array, so first
515    element is 0).
516    Following example will read second value from repeatable field.
517    
518     my $text = $webpac->fill_in($rec,'Title: v250^a',1);
519    
520    This function B<does not> perform parsing of format to inteligenty skip
521    delimiters before fields which aren't used.
522    
523    This method will automatically decode UTF-8 string to local code page
524    if needed.
525    
526  =cut  =cut
527    
528  sub fill_in {  sub fill_in {
529          my $self = shift;          my $self = shift;
530    
531          my $rec = shift || confess "need data record";          my $log = $self->_get_logger();
532          my $format = shift || confess "need format to parse";  
533            my $rec = shift || $log->logconfess("need data record");
534            my $format = shift || $log->logconfess("need format to parse");
535          # iteration (for repeatable fields)          # iteration (for repeatable fields)
536          my $i = shift || 0;          my $i = shift || 0;
537    
538          # FIXME remove for speedup?          # FIXME remove for speedup?
539          if ($rec !~ /HASH/) {          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
540                  confess("need HASH as first argument!");  
541            if (utf8::is_utf8($format)) {
542                    $format = $self->_x($format);
543          }          }
544    
545          my $found = 0;          my $found = 0;
546    
547          # get field with subfield          my $eval_code;
548          sub get_sf {          # remove eval{...} from beginning
549                  my ($found,$rec,$f,$sf,$i) = @_;          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
                 if ($$rec->{$f} && $$rec->{$f}->[$i]->{$sf}) {  
                         $$found++;  
                         return $$rec->{$f}->[$i]->{$sf};  
                 } else {  
                         return '';  
                 }  
         }  
   
         # get field (without subfield)  
         sub get_nosf {  
                 my ($found,$rec,$f,$i) = @_;  
                 if ($$rec->{$f} && $$rec->{$f}->[$i]) {  
                         $$found++;  
                         return $$rec->{$f}->[$i];  
                 } else {  
                         return '';  
                 }  
         }  
550    
551          # do actual replacement of placeholders          # do actual replacement of placeholders
552          $format =~ s/v(\d+)\^(\w)/get_sf(\$found,\$rec,$1,$2,$i)/ges;          $format =~ s/v(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;
         $format =~ s/v(\d+)/get_nosf(\$found,\$rec,$1,$i)/ges;  
553    
554          if ($found) {            if ($found) {
555                  return $format;                  $log->debug("format: $format");
556                    if ($eval_code) {
557                            my $eval = $self->fill_in($rec,$eval_code,$i);
558                            return if (! $self->_eval($eval));
559                    }
560                    # do we have lookups?
561                    if ($format =~ /$LOOKUP_REGEX/o) {
562                            $log->debug("format '$format' has lookup");
563                            return $self->lookup($format);
564                    } else {
565                            return $format;
566                    }
567          } else {          } else {
568                  return;                  return;
569          }          }
# Line 250  sub fill_in { Line 571  sub fill_in {
571    
572  =head2 lookup  =head2 lookup
573    
574  This function will perform lookups on format supplied to it.  Perform lookups on format supplied to it.
575    
576     my $text = $self->lookup('[v900]');
577    
578   my $txt = $self->lookup('[v900]');  Lookups can be nested (like C<[d:[a:[v900]]]>).
579    
580  =cut  =cut
581    
582  sub lookup {  sub lookup {
583          my $self = shift;          my $self = shift;
584    
585          my $tmp = shift || confess "need format";          my $log = $self->_get_logger();
586    
587            my $tmp = shift || $log->logconfess("need format");
588    
589          if ($tmp =~ /\[[^\[\]]+\]/) {          if ($tmp =~ /$LOOKUP_REGEX/o) {
590                  my @in = ( $tmp );                  my @in = ( $tmp );
591  print "##lookup $tmp\n";  
592                    $log->debug("lookup for: ",$tmp);
593    
594                  my @out;                  my @out;
595                  while (my $f = shift @in) {                  while (my $f = shift @in) {
596                          if ($f =~ /\[([^\[\]]+)\]/) {                          if ($f =~ /$LOOKUP_REGEX_SAVE/o) {
597                                  my $k = $1;                                  my $k = $1;
598                                  if ($self->{'lookup'}->{$k}) {                                  if ($self->{'lookup'}->{$k}) {
 print "## lookup key = $k\n";  
599                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {
600                                                  my $tmp2 = $f;                                                  my $tmp2 = $f;
601                                                  $tmp2 =~ s/\[$k\]/$nv/g;                                                  $tmp2 =~ s/lookup{$k}/$nv/g;
602                                                  push @in, $tmp2;                                                  push @in, $tmp2;
 print "## lookup in => $tmp2\n";  
603                                          }                                          }
604                                  } else {                                  } else {
605                                          undef $f;                                          undef $f;
606                                  }                                  }
607                          } elsif ($f) {                          } elsif ($f) {
608                                  push @out, $f;                                  push @out, $f;
 print "## lookup out => $f\n";  
609                          }                          }
610                  }                  }
611                    $log->logconfess("return is array and it's not expected!") unless wantarray;
612                  return @out;                  return @out;
613          } else {          } else {
614                  return $tmp;                  return $tmp;
615          }          }
616  }  }
617    
618    =head2 parse
619    
620    Perform smart parsing of string, skipping delimiters for fields which aren't
621    defined. It can also eval code in format starting with C<eval{...}> and
622    return output or nothing depending on eval code.
623    
624     my $text = $webpac->parse($rec,'eval{"v901^a" eq "Deskriptor"}descriptor: v250^a', $i);
625    
626    =cut
627    
628    sub parse {
629            my $self = shift;
630    
631            my ($rec, $format_utf8, $i) = @_;
632    
633            return if (! $format_utf8);
634    
635            my $log = $self->_get_logger();
636    
637            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
638            $log->logconfess("need utf2cp Text::Iconv object!") if (! $self->{'utf2cp'});
639    
640            $i = 0 if (! $i);
641    
642            my $format = $self->_x($format_utf8) || $log->logconfess("can't convert '$format_utf8' from UTF-8 to ",$self->{'code_page'});
643    
644            my @out;
645    
646            $log->debug("format: $format");
647    
648            my $eval_code;
649            # remove eval{...} from beginning
650            $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
651    
652            my $prefix;
653            my $all_found=0;
654    
655            while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))?//s) {
656    
657                    my $del = $1 || '';
658                    $prefix ||= $del if ($all_found == 0);
659    
660                    my $found = 0;
661                    my $tmp = $self->get_data(\$rec,$2,$3,$i,\$found);
662    
663                    if ($found) {
664                            push @out, $del;
665                            push @out, $tmp;
666                            $all_found += $found;
667                    }
668            }
669    
670            return if (! $all_found);
671    
672            my $out = join('',@out);
673    
674            if ($out) {
675                    # add rest of format (suffix)
676                    $out .= $format;
677    
678                    # add prefix if not there
679                    $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);
680    
681                    $log->debug("result: $out");
682            }
683    
684            if ($eval_code) {
685                    my $eval = $self->fill_in($rec,$eval_code,$i);
686                    $log->debug("about to eval{",$eval,"} format: $out");
687                    return if (! $self->_eval($eval));
688            }
689    
690            return $out;
691    }
692    
693    =head2 parse_to_arr
694    
695    Similar to C<parse>, but returns array of all repeatable fields
696    
697     my @arr = $webpac->parse_to_arr($rec,'v250^a');
698    
699    =cut
700    
701    sub parse_to_arr {
702            my $self = shift;
703    
704            my ($rec, $format_utf8) = @_;
705    
706            my $log = $self->_get_logger();
707    
708            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
709            return if (! $format_utf8);
710    
711            my $i = 0;
712            my @arr;
713    
714            while (my $v = $self->parse($rec,$format_utf8,$i++)) {
715                    push @arr, $v;
716            }
717    
718            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
719    
720            return @arr;
721    }
722    
723    =head2 fill_in_to_arr
724    
725    Similar to C<fill_in>, but returns array of all repeatable fields. Usable
726    for fields which have lookups, so they shouldn't be parsed but rather
727    C<fill_id>ed.
728    
729     my @arr = $webpac->fill_in_to_arr($rec,'[v900];;[v250^a]');
730    
731    =cut
732    
733    sub fill_in_to_arr {
734            my $self = shift;
735    
736            my ($rec, $format_utf8) = @_;
737    
738            my $log = $self->_get_logger();
739    
740            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
741            return if (! $format_utf8);
742    
743            my $i = 0;
744            my @arr;
745    
746            while (my @v = $self->fill_in($rec,$format_utf8,$i++)) {
747                    push @arr, @v;
748            }
749    
750            $log->debug("format '$format_utf8' returned ",--$i," elements: ", sub { join(" | ",@arr) }) if (@arr);
751    
752            return @arr;
753    }
754    
755    
756    =head2 data_structure
757    
758    Create in-memory data structure which represents layout from C<import_xml>.
759    It is used later to produce output.
760    
761     my @ds = $webpac->data_structure($rec);
762    
763    This method will also set C<$webpac->{'currnet_filename'}> if there is
764    <filename> tag in C<import_xml> and C<$webpac->{'headline'}> if there is
765    <headline> tag.
766    
767    =cut
768    
769    sub data_structure {
770            my $self = shift;
771    
772            my $log = $self->_get_logger();
773    
774            my $rec = shift;
775            $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
776    
777            undef $self->{'currnet_filename'};
778            undef $self->{'headline'};
779    
780            my @sorted_tags;
781            if ($self->{tags_by_order}) {
782                    @sorted_tags = @{$self->{tags_by_order}};
783            } else {
784                    @sorted_tags = sort { $self->_sort_by_order } keys %{$self->{'import_xml'}->{'indexer'}};
785                    $self->{tags_by_order} = \@sorted_tags;
786            }
787    
788            my @ds;
789    
790            $log->debug("tags: ",sub { join(", ",@sorted_tags) });
791    
792            foreach my $field (@sorted_tags) {
793    
794                    my $row;
795    
796    #print "field $field [",$self->{'tag'},"] = ",Dumper($self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}});
797    
798                    foreach my $tag (@{$self->{'import_xml'}->{'indexer'}->{$field}->{$self->{'tag'}}}) {
799                            my $format = $tag->{'value'} || $tag->{'content'};
800    
801                            $log->debug("format: $format");
802    
803                            my @v;
804                            if ($format =~ /$LOOKUP_REGEX/o) {
805                                    @v = $self->fill_in_to_arr($rec,$format);
806                            } else {
807                                    @v = $self->parse_to_arr($rec,$format);
808                            }
809                            next if (! @v);
810    
811                            # use format?
812                            if ($tag->{'format_name'}) {
813                                    @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
814                            }
815    
816                            if ($field eq 'filename') {
817                                    $self->{'current_filename'} = join('',@v);
818                                    $log->debug("filename: ",$self->{'current_filename'});
819                            } elsif ($field eq 'headline') {
820                                    $self->{'headline'} .= join('',@v);
821                                    $log->debug("headline: ",$self->{'headline'});
822                                    next; # don't return headline in data_structure!
823                            }
824    
825                            # does tag have type?
826                            if ($tag->{'type'}) {
827                                    push @{$row->{$tag->{'type'}}}, @v;
828                            } else {
829                                    push @{$row->{'display'}}, @v;
830                                    push @{$row->{'swish'}}, @v;
831                            }
832    
833    
834                    }
835    
836                    if ($row) {
837                            $row->{'tag'} = $field;
838    
839                            # TODO: name_sigular, name_plural
840                            my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
841                            $row->{'name'} = $name ? $self->_x($name) : $field;
842    
843                            push @ds, $row;
844    
845                            $log->debug("row $field: ",sub { Dumper($row) });
846                    }
847    
848            }
849    
850            return @ds;
851    
852    }
853    
854    =head2 output
855    
856    Create output from in-memory data structure using Template Toolkit template.
857    
858    my $text = $webpac->output( template => 'text.tt', data => @ds );
859    
860    =cut
861    
862    sub output {
863            my $self = shift;
864    
865            my $args = {@_};
866    
867            my $log = $self->_get_logger();
868    
869            $log->logconfess("need template name") if (! $args->{'template'});
870            $log->logconfess("need data array") if (! $args->{'data'});
871    
872            my $out;
873    
874            $self->{'tt'}->process(
875                    $args->{'template'},
876                    $args,
877                    \$out
878            ) || confess $self->{'tt'}->error();
879    
880            return $out;
881    }
882    
883    =head2 output_file
884    
885    Create output from in-memory data structure using Template Toolkit template
886    to a file.
887    
888     $webpac->output_file(
889            file => 'out.txt',
890            template => 'text.tt',
891            data => @ds
892     );
893    
894    =cut
895    
896    sub output_file {
897            my $self = shift;
898    
899            my $args = {@_};
900    
901            my $log = $self->_get_logger();
902    
903            my $file = $args->{'file'} || $log->logconfess("need file name");
904    
905            $log->debug("creating file ",$file);
906    
907            open(my $fh, ">", $file) || $log->logdie("can't open output file '$file': $!");
908            print $fh $self->output(
909                    template => $args->{'template'},
910                    data => $args->{'data'},
911            ) || $log->logdie("print: $!");
912            close($fh) || $log->logdie("close: $!");
913    }
914    
915    =head2 apply_format
916    
917    Apply format specified in tag with C<format_name="name"> and
918    C<format_delimiter=";;">.
919    
920     my $text = $webpac->apply_format($format_name,$format_delimiter,$data);
921    
922    Formats can contain C<lookup{...}> if you need them.
923    
924    =cut
925    
926    sub apply_format {
927            my $self = shift;
928    
929            my ($name,$delimiter,$data) = @_;
930    
931            my $log = $self->_get_logger();
932    
933            if (! $self->{'import_xml'}->{'format'}->{$name}) {
934                    $log->warn("<format name=\"$name\"> is not defined in ",$self->{'import_xml_file'});
935                    return $data;
936            }
937    
938            $log->warn("no delimiter for format $name") if (! $delimiter);
939    
940            my $format = $self->_x($self->{'import_xml'}->{'format'}->{$name}->{'content'}) || $log->logdie("can't find format '$name'");
941    
942            my @data = split(/\Q$delimiter\E/, $data);
943    
944            my $out = sprintf($format, @data);
945            $log->debug("using format $name [$format] on $data to produce: $out");
946    
947            if ($out =~ m/$LOOKUP_REGEX/o) {
948                    return $self->lookup($out);
949            } else {
950                    return $out;
951            }
952    
953    }
954    
955    
956    #
957    #
958    #
959    
960    =head1 INTERNAL METHODS
961    
962    Here is a quick list of internal methods, mostly useful to turn debugging
963    on them (see L<LOGGING> below for explanation).
964    
965    =cut
966    
967    =head2 _eval
968    
969    Internal function to eval code without C<strict 'subs'>.
970    
971    =cut
972    
973    sub _eval {
974            my $self = shift;
975    
976            my $code = shift || return;
977    
978            my $log = $self->_get_logger();
979    
980            no strict 'subs';
981            my $ret = eval $code;
982            if ($@) {
983                    $log->error("problem with eval code [$code]: $@");
984            }
985    
986            $log->debug("eval: ",$code," [",$ret,"]");
987    
988            return $ret || 0;
989    }
990    
991    =head2 _sort_by_order
992    
993    Sort xml tags data structure accoding to C<order=""> attribute.
994    
995    =cut
996    
997    sub _sort_by_order {
998            my $self = shift;
999    
1000            my $va = $self->{'import_xml'}->{'indexer'}->{$a}->{'order'} ||
1001                    $self->{'import_xml'}->{'indexer'}->{$a};
1002            my $vb = $self->{'import_xml'}->{'indexer'}->{$b}->{'order'} ||
1003                    $self->{'import_xml'}->{'indexer'}->{$b};
1004    
1005            return $va <=> $vb;
1006    }
1007    
1008    =head2 _get_logger
1009    
1010    Get C<Log::Log4perl> object with a twist: domains are defined for each
1011    method
1012    
1013     my $log = $webpac->_get_logger();
1014    
1015    =cut
1016    
1017    sub _get_logger {
1018            my $self = shift;
1019    
1020            my $name = (caller(1))[3] || caller;
1021            return get_logger($name);
1022    }
1023    
1024    =head2 _x
1025    
1026    Convert string from UTF-8 to code page defined in C<import_xml>.
1027    
1028     my $text = $webpac->_x('utf8 text');
1029    
1030    =cut
1031    
1032    sub _x {
1033            my $self = shift;
1034            my $utf8 = shift || return;
1035    
1036            return $self->{'utf2cp'}->convert($utf8) ||
1037                    $self->_get_logger()->logwarn("can't convert '$utf8'");
1038    }
1039    
1040    #
1041    #
1042    #
1043    
1044    =head1 LOGGING
1045    
1046    Logging in WebPAC is performed by L<Log::Log4perl> with config file
1047    C<log.conf>.
1048    
1049    Methods defined above have different levels of logging, so
1050    it's descriptions will be useful to turn (mostry B<debug> logging) on
1051    or off to see why WabPAC isn't perforing as you expect it (it might even
1052    be a bug!).
1053    
1054    B<This is different from normal Log4perl behaviour>. To repeat, you can
1055    also use method names, and not only classes (which are just few)
1056    to filter logging.
1057    
1058    
1059    =head1 MEMORY USAGE
1060    
1061    C<low_mem> options is double-edged sword. If enabled, WebPAC
1062    will run on memory constraint machines (which doesn't have enough
1063    physical RAM to create memory structure for whole source database).
1064    
1065    If your machine has 512Mb or more of RAM and database is around 10000 records,
1066    memory shouldn't be an issue. If you don't have enough physical RAM, you
1067    might consider using virtual memory (if your operating system is handling it
1068    well, like on FreeBSD or Linux) instead of dropping to L<DBD::Deep> to handle
1069    parsed structure of ISIS database (this is what C<low_mem> option does).
1070    
1071    Hitting swap at end of reading source database is probably o.k. However,
1072    hitting swap before 90% will dramatically decrease performance and you will
1073    be better off with C<low_mem> and using rest of availble memory for
1074    operating system disk cache (Linux is particuallary good about this).
1075    However, every access to database record will require disk access, so
1076    generation phase will be slower 10-100 times.
1077    
1078    Parsed structures are essential - you just have option to trade RAM memory
1079    (which is fast) for disk space (which is slow). Be sure to have planty of
1080    disk space if you are using C<low_mem> and thus L<DBD::Deep>.
1081    
1082    However, when WebPAC is running on desktop machines (or laptops :-), it's
1083    highly undesireable for system to start swapping. Using C<low_mem> option can
1084    reduce WecPAC memory usage to around 64Mb for same database with lookup
1085    fields and sorted indexes which stay in RAM. Performance will suffer, but
1086    memory usage will really be minimal. It might be also more confortable to
1087    run WebPAC reniced on those machines.
1088    
1089    =cut
1090    
1091  1;  1;
Legend:
Removed from v.352  
changed lines
  Added in v.434
  ViewVC Help
Powered by ViewVC 1.1.26