/[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 398 by dpavlin, Sat Jul 24 13:48:08 2004 UTC revision 705 by dpavlin, Wed Jul 13 22:34:52 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 = '\[[^\[\]]+\]';  #my $LOOKUP_REGEX = '\[[^\[\]]+\]';
27  #my $LOOKUP_REGEX_SAVE = '\[([^\[\]]+)\]';  #my $LOOKUP_REGEX_SAVE = '\[([^\[\]]+)\]';
28  my $LOOKUP_REGEX = 'lookup{[^\{\}]+}';  my $LOOKUP_REGEX = 'lookup{[^\{\}]+}';
# Line 29  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 59  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 100  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 149  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 157  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          my $isis_db = OpenIsis::open($arg->{'filename'});          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->{'maxmfn'};
239            } else {
240                    $log->logdie("Can't find supported ISIS library for perl. I suggent that you install Bilbio::Isis from CPAN.");
241            }
242    
         my $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;  
243    
244          $maxmfn = $self->{limit_mfn} if ($self->{limit_mfn});          my $startmfn = 1;
245    
246            if (my $s = $self->{'start_mfn'}) {
247                    $log->info("skipping to MFN $s");
248                    $startmfn = $s;
249            } else {
250                    $self->{'start_mfn'} = $startmfn;
251            }
252    
253            $maxmfn = $startmfn + $self->{limit_mfn} if ($self->{limit_mfn});
254    
255            $log->info("processing ",($maxmfn-$startmfn)." records using ",( $have_openisis ? 'OpenIsis' : 'Biblio::Isis'));
256    
         $log->info("processing $maxmfn records...");  
257    
258          # read database          # read database
259          for (my $mfn = 1; $mfn <= $maxmfn; $mfn++) {          for (my $mfn = $startmfn; $mfn <= $maxmfn; $mfn++) {
260    
261    
262                    $log->debug("mfn: $mfn\n");
263    
264                    my $rec;
265    
266                    if ($have_openisis) {
267    
268                  # read record                          # read record using OpenIsis
269                  my $row = OpenIsis::read( $isis_db, $mfn );                          my $row = OpenIsis::read( $isis_db, $mfn );
270                  foreach my $k (keys %{$row}) {                          foreach my $k (keys %{$row}) {
271                          if ($k ne "mfn") {                                  if ($k ne "mfn") {
272                                  foreach my $l (@{$row->{$k}}) {                                          foreach my $l (@{$row->{$k}}) {
273                                          $l = $cp->convert($l);                                                  $l = $cp->convert($l);
274                                          # has subfields?                                                  # has subfields?
275                                          my $val;                                                  my $val;
276                                          if ($l =~ m/\^/) {                                                  if ($l =~ m/\^/) {
277                                                  foreach my $t (split(/\^/,$l)) {                                                          foreach my $t (split(/\^/,$l)) {
278                                                          next if (! $t);                                                                  next if (! $t);
279                                                          $val->{substr($t,0,1)} = substr($t,1);                                                                  $val->{substr($t,0,1)} = substr($t,1);
280                                                            }
281                                                    } else {
282                                                            $val = $l;
283                                                  }                                                  }
                                         } else {  
                                                 $val = $l;  
                                         }  
284    
285                                          push @{$self->{'data'}->{$mfn}->{$k}}, $val;                                                  push @{$rec->{$k}}, $val;
286                                            }
287                                    } else {
288                                            push @{$rec->{'000'}}, $mfn;
289                                  }                                  }
                         } else {  
                                 push @{$self->{'data'}->{$mfn}->{'000'}}, $mfn;  
290                          }                          }
291    
292                    } elsif ($have_biblio_isis) {
293                            $rec = $isis_db->to_hash($mfn);
294                    } else {
295                            $log->logdie("hum? implementation missing?");
296                    }
297    
298                    $log->confess("record $mfn empty?") unless ($rec);
299    
300                    # store
301                    if ($self->{'low_mem'}) {
302                            $self->{'db'}->put($mfn, $rec);
303                    } else {
304                            $self->{'data'}->{$mfn} = $rec;
305                  }                  }
306    
307                  # create lookup                  # create lookup
                 my $rec = $self->{'data'}->{$mfn};  
308                  $self->create_lookup($rec, @{$arg->{'lookup'}});                  $self->create_lookup($rec, @{$arg->{'lookup'}});
309    
310                  $self->progress_bar($mfn,$maxmfn);                  $self->progress_bar($mfn,$maxmfn);
311    
312          }          }
313    
314          $self->{'current_mfn'} = 1;          $self->{'current_mfn'} = -1;
315          $self->{'last_pcnt'} = 0;          $self->{'last_pcnt'} = 0;
316    
317            $log->debug("max mfn: $maxmfn");
318    
319          # store max mfn and return it.          # store max mfn and return it.
320          return $self->{'max_mfn'} = $maxmfn;          return $self->{'max_mfn'} = $maxmfn;
321  }  }
# Line 223  sub fetch_rec { Line 334  sub fetch_rec {
334    
335          my $log = $self->_get_logger();          my $log = $self->_get_logger();
336    
337          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'});
338    
339            if ($self->{'current_mfn'} == -1) {
340                    $self->{'current_mfn'} = $self->{'start_mfn'};
341            } else {
342                    $self->{'current_mfn'}++;
343            }
344    
345            my $mfn = $self->{'current_mfn'};
346    
347          if ($mfn > $self->{'max_mfn'}) {          if ($mfn > $self->{'max_mfn'}) {
348                  $self->{'current_mfn'} = $self->{'max_mfn'};                  $self->{'current_mfn'} = $self->{'max_mfn'};
# Line 233  sub fetch_rec { Line 352  sub fetch_rec {
352    
353          $self->progress_bar($mfn,$self->{'max_mfn'});          $self->progress_bar($mfn,$self->{'max_mfn'});
354    
355          return $self->{'data'}->{$mfn};          if ($self->{'low_mem'}) {
356                    return $self->{'db'}->get($mfn);
357            } else {
358                    return $self->{'data'}->{$mfn};
359            }
360    }
361    
362    =head2 mfn
363    
364    Returns current record number (MFN).
365    
366     print $webpac->mfn;
367    
368    =cut
369    
370    sub mfn {
371            my $self = shift;
372            return $self->{'current_mfn'};
373  }  }
374    
375  =head2 progress_bar  =head2 progress_bar
# Line 261  sub progress_bar { Line 397  sub progress_bar {
397    
398          $self->{'last_pcnt'} ||= 1;          $self->{'last_pcnt'} ||= 1;
399    
400          $self->{'last_pcnt'} = $curr if ($curr < $self->{'last_pcnt'});          my $p = int($curr * 100 / $max) || 1;
401    
402            # reset on re-run
403            if ($p < $self->{'last_pcnt'}) {
404                    $self->{'last_pcnt'} = $p;
405                    $self->{'start_t'} = time();
406            }
407    
         my $p = int($curr * 100 / $max);  
408          if ($p != $self->{'last_pcnt'}) {          if ($p != $self->{'last_pcnt'}) {
409                  printf STDERR ("%5d / %5d [%-51s] %-2d %% \r",$curr,$max,"=" x ($p/2).">", $p );  
410                    my $t = time();
411                    my $rate = ($curr / ($t - $self->{'start_t'} || 1));
412                    my $eta = ($max-$curr) / ($rate || 1);
413                    printf STDERR ("%5d [%-38s] %-5d %0.1f/s %s\r",$curr,"=" x ($p/3)."$p%>", $max, $rate, $self->fmt_time($eta));
414                  $self->{'last_pcnt'} = $p;                  $self->{'last_pcnt'} = $p;
415                    $self->{'last_curr'} = $curr;
416          }          }
417            print STDERR "\n" if ($p == 100);
418    }
419    
420    =head2 fmt_time
421    
422    Format time (in seconds) for display.
423    
424     print $webpac->fmt_time(time());
425    
426    This method is called by L<progress_bar> to display remaining time.
427    
428    =cut
429    
430    sub fmt_time {
431            my $self = shift;
432    
433            my $t = shift || 0;
434            my $out = "";
435    
436            my ($ss,$mm,$hh) = gmtime($t);
437            $out .= "${hh}h" if ($hh);
438            $out .= sprintf("%02d:%02d", $mm,$ss);
439            $out .= "  " if ($hh == 0);
440            return $out;
441  }  }
442    
443  =head2 open_import_xml  =head2 open_import_xml
# Line 329  sub create_lookup { Line 499  sub create_lookup {
499          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
500    
501          foreach my $i (@_) {          foreach my $i (@_) {
502                  if ($i->{'eval'}) {                  $log->logconfess("need key") unless defined($i->{'key'});
503                          my $eval = $self->fill_in($rec,$i->{'eval'});                  $log->logconfess("need val") unless defined($i->{'val'});
504                          my $key = $self->fill_in($rec,$i->{'key'});  
505                          my @val = $self->fill_in($rec,$i->{'val'});                  if (defined($i->{'eval'})) {
506                          if ($key && @val && eval $eval) {                          # eval first, so we can skip fill_in for key and val
507                            my $eval = $self->fill_in($rec,$i->{'eval'}) || next;
508                            if ($self->_eval($eval)) {
509                                    my $key = $self->fill_in($rec,$i->{'key'}) || next;
510                                    my @val = $self->fill_in($rec,$i->{'val'}) || next;
511                                  $log->debug("stored $key = ",sub { join(" | ",@val) });                                  $log->debug("stored $key = ",sub { join(" | ",@val) });
512                                  push @{$self->{'lookup'}->{$key}}, @val;                                  push @{$self->{'lookup'}->{$key}}, @val;
513                          }                          }
514                  } else {                  } else {
515                          my $key = $self->fill_in($rec,$i->{'key'});                          my $key = $self->fill_in($rec,$i->{'key'}) || next;
516                          my @val = $self->fill_in($rec,$i->{'val'});                          my @val = $self->fill_in($rec,$i->{'val'}) || next;
517                          if ($key && @val) {                          $log->debug("stored $key = ",sub { join(" | ",@val) });
518                                  $log->debug("stored $key = ",sub { join(" | ",@val) });                          push @{$self->{'lookup'}->{$key}}, @val;
                                 push @{$self->{'lookup'}->{$key}}, @val;  
                         }  
519                  }                  }
520          }          }
521  }  }
# Line 430  sub fill_in { Line 602  sub fill_in {
602          # iteration (for repeatable fields)          # iteration (for repeatable fields)
603          my $i = shift || 0;          my $i = shift || 0;
604    
605            $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));
606    
607          # FIXME remove for speedup?          # FIXME remove for speedup?
608          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
609    
# Line 443  sub fill_in { Line 617  sub fill_in {
617          # remove eval{...} from beginning          # remove eval{...} from beginning
618          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
619    
620            my $filter_name;
621            # remove filter{...} from beginning
622            $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
623    
624          # do actual replacement of placeholders          # do actual replacement of placeholders
625            # repeatable fields
626          $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;
627            # non-repeatable fields
628            $format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found)/ges;
629    
630          if ($found) {          if ($found) {
631                  $log->debug("format: $format");                  $log->debug("format: $format");
# Line 452  sub fill_in { Line 633  sub fill_in {
633                          my $eval = $self->fill_in($rec,$eval_code,$i);                          my $eval = $self->fill_in($rec,$eval_code,$i);
634                          return if (! $self->_eval($eval));                          return if (! $self->_eval($eval));
635                  }                  }
636                    if ($filter_name && $self->{'filter'}->{$filter_name}) {
637                            $log->debug("filter '$filter_name' for $format");
638                            $format = $self->{'filter'}->{$filter_name}->($format);
639                            return unless(defined($format));
640                            $log->debug("filter result: $format");
641                    }
642                  # do we have lookups?                  # do we have lookups?
643                  if ($format =~ /$LOOKUP_REGEX/o) {                  if ($format =~ /$LOOKUP_REGEX/o) {
644                          $log->debug("format '$format' has lookup");                          $log->debug("format '$format' has lookup");
# Line 544  sub parse { Line 731  sub parse {
731          # remove eval{...} from beginning          # remove eval{...} from beginning
732          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
733    
734            my $filter_name;
735            # remove filter{...} from beginning
736            $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
737    
738          my $prefix;          my $prefix;
739          my $all_found=0;          my $all_found=0;
740    
741          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))?//s) {          while ($format =~ s/^(.*?)(v|s)(\d+)(?:\^(\w))?//s) {
742    
743                  my $del = $1 || '';                  my $del = $1 || '';
744                  $prefix ||= $del if ($all_found == 0);                  $prefix ||= $del if ($all_found == 0);
745    
746                    # repeatable index
747                    my $r = $i;
748                    $r = 0 if (lc("$2") eq 's');
749    
750                  my $found = 0;                  my $found = 0;
751                  my $tmp = $self->get_data(\$rec,$2,$3,$i,\$found);                  my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found);
752    
753                  if ($found) {                  if ($found) {
754                          push @out, $del;                          push @out, $del;
# Line 577  sub parse { Line 772  sub parse {
772          }          }
773    
774          if ($eval_code) {          if ($eval_code) {
775                  my $eval = $self->fill_in($rec,$eval_code,$i);                  my $eval = $self->fill_in($rec,$eval_code,$i) || return;
776                  $log->debug("about to eval{",$eval,"} format: $out");                  $log->debug("about to eval{$eval} format: $out");
777                  return if (! $self->_eval($eval));                  return if (! $self->_eval($eval));
778          }          }
779            
780            if ($filter_name && $self->{'filter'}->{$filter_name}) {
781                    $log->debug("about to filter{$filter_name} format: $out");
782                    $out = $self->{'filter'}->{$filter_name}->($out);
783                    return unless(defined($out));
784                    $log->debug("filter result: $out");
785            }
786    
787          return $out;          return $out;
788  }  }
# Line 647  sub fill_in_to_arr { Line 849  sub fill_in_to_arr {
849          return @arr;          return @arr;
850  }  }
851    
852    =head2 sort_arr
853    
854    Sort array ignoring case and html in data
855    
856     my @sorted = $webpac->sort_arr(@unsorted);
857    
858    =cut
859    
860    sub sort_arr {
861            my $self = shift;
862    
863            my $log = $self->_get_logger();
864    
865            # FIXME add Schwartzian Transformation?
866    
867            my @sorted = sort {
868                    $a =~ s#<[^>]+/*>##;
869                    $b =~ s#<[^>]+/*>##;
870                    lc($b) cmp lc($a)
871            } @_;
872            $log->debug("sorted values: ",sub { join(", ",@sorted) });
873    
874            return @sorted;
875    }
876    
877    
878  =head2 data_structure  =head2 data_structure
879    
# Line 703  sub data_structure { Line 930  sub data_structure {
930                          }                          }
931                          next if (! @v);                          next if (! @v);
932    
933                            if ($tag->{'sort'}) {
934                                    @v = $self->sort_arr(@v);
935                            }
936    
937                          # use format?                          # use format?
938                          if ($tag->{'format_name'}) {                          if ($tag->{'format_name'}) {
939                                  @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;                                  @v = map { $self->apply_format($tag->{'format_name'},$tag->{'format_delimiter'},$_) } @v;
# Line 717  sub data_structure { Line 948  sub data_structure {
948                                  next; # don't return headline in data_structure!                                  next; # don't return headline in data_structure!
949                          }                          }
950    
951                          # does tag have type?                          # delimiter will join repeatable fields
952                          if ($tag->{'type'}) {                          if ($tag->{'delimiter'}) {
953                                  push @{$row->{$tag->{'type'}}}, @v;                                  @v = ( join($tag->{'delimiter'}, @v) );
954                          } else {                          }
955                                  push @{$row->{'display'}}, @v;  
956                                  push @{$row->{'swish'}}, @v;                          # default types
957                            my @types = qw(display swish);
958                            # override by type attribute
959                            @types = ( $tag->{'type'} ) if ($tag->{'type'});
960    
961                            foreach my $type (@types) {
962                                    # append to previous line?
963                                    $log->debug("type: $type ",sub { join(" ",@v) }, $row->{'append'} || 'no append');
964                                    if ($tag->{'append'}) {
965    
966                                            # I will delimit appended part with
967                                            # delimiter (or ,)
968                                            my $d = $tag->{'delimiter'};
969                                            # default delimiter
970                                            $d ||= " ";
971    
972                                            my $last = pop @{$row->{$type}};
973                                            $d = "" if (! $last);
974                                            $last .= $d . join($d, @v);
975                                            push @{$row->{$type}}, $last;
976    
977                                    } else {
978                                            push @{$row->{$type}}, @v;
979                                    }
980                          }                          }
981    
982    
# Line 735  sub data_structure { Line 989  sub data_structure {
989                          my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};                          my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
990                          $row->{'name'} = $name ? $self->_x($name) : $field;                          $row->{'name'} = $name ? $self->_x($name) : $field;
991    
992                            # post-sort all values in field
993                            if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {
994                                    $log->warn("sort at field tag not implemented");
995                            }
996    
997                          push @ds, $row;                          push @ds, $row;
998    
999                          $log->debug("row $field: ",sub { Dumper($row) });                          $log->debug("row $field: ",sub { Dumper($row) });
# Line 775  sub output { Line 1034  sub output {
1034          return $out;          return $out;
1035  }  }
1036    
1037    =head2 output_file
1038    
1039    Create output from in-memory data structure using Template Toolkit template
1040    to a file.
1041    
1042     $webpac->output_file(
1043            file => 'out.txt',
1044            template => 'text.tt',
1045            data => @ds
1046     );
1047    
1048    =cut
1049    
1050    sub output_file {
1051            my $self = shift;
1052    
1053            my $args = {@_};
1054    
1055            my $log = $self->_get_logger();
1056    
1057            my $file = $args->{'file'} || $log->logconfess("need file name");
1058    
1059            $log->debug("creating file ",$file);
1060    
1061            open(my $fh, ">", $file) || $log->logdie("can't open output file '$file': $!");
1062            print $fh $self->output(
1063                    template => $args->{'template'},
1064                    data => $args->{'data'},
1065            ) || $log->logdie("print: $!");
1066            close($fh) || $log->logdie("close: $!");
1067    }
1068    
1069  =head2 apply_format  =head2 apply_format
1070    
1071  Apply format specified in tag with C<format_name="name"> and  Apply format specified in tag with C<format_name="name"> and
# Line 848  sub _eval { Line 1139  sub _eval {
1139    
1140          $log->debug("eval: ",$code," [",$ret,"]");          $log->debug("eval: ",$code," [",$ret,"]");
1141    
1142          return $ret || 0;          return $ret || undef;
1143  }  }
1144    
1145  =head2 _sort_by_order  =head2 _sort_by_order
# Line 918  B<This is different from normal Log4perl Line 1209  B<This is different from normal Log4perl
1209  also use method names, and not only classes (which are just few)  also use method names, and not only classes (which are just few)
1210  to filter logging.  to filter logging.
1211    
1212    
1213    =head1 MEMORY USAGE
1214    
1215    C<low_mem> options is double-edged sword. If enabled, WebPAC
1216    will run on memory constraint machines (which doesn't have enough
1217    physical RAM to create memory structure for whole source database).
1218    
1219    If your machine has 512Mb or more of RAM and database is around 10000 records,
1220    memory shouldn't be an issue. If you don't have enough physical RAM, you
1221    might consider using virtual memory (if your operating system is handling it
1222    well, like on FreeBSD or Linux) instead of dropping to L<DBD::Deep> to handle
1223    parsed structure of ISIS database (this is what C<low_mem> option does).
1224    
1225    Hitting swap at end of reading source database is probably o.k. However,
1226    hitting swap before 90% will dramatically decrease performance and you will
1227    be better off with C<low_mem> and using rest of availble memory for
1228    operating system disk cache (Linux is particuallary good about this).
1229    However, every access to database record will require disk access, so
1230    generation phase will be slower 10-100 times.
1231    
1232    Parsed structures are essential - you just have option to trade RAM memory
1233    (which is fast) for disk space (which is slow). Be sure to have planty of
1234    disk space if you are using C<low_mem> and thus L<DBD::Deep>.
1235    
1236    However, when WebPAC is running on desktop machines (or laptops :-), it's
1237    highly undesireable for system to start swapping. Using C<low_mem> option can
1238    reduce WecPAC memory usage to around 64Mb for same database with lookup
1239    fields and sorted indexes which stay in RAM. Performance will suffer, but
1240    memory usage will really be minimal. It might be also more confortable to
1241    run WebPAC reniced on those machines.
1242    
1243  =cut  =cut
1244    
1245  1;  1;
Legend:
Removed from v.398  
changed lines
  Added in v.705
  ViewVC Help
Powered by ViewVC 1.1.26