/[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 431 by dpavlin, Sun Sep 12 20:31:34 2004 UTC revision 555 by dpavlin, Fri Oct 29 22:09:04 2004 UTC
# Line 34  Create new instance of WebPAC using conf Line 34  Create new instance of WebPAC using conf
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,]          low_mem => 1,
39            filter => {
40                    'lower' => sub { lc($_[0]) },
41            },
42   );   );
43    
44  Default C<code_page> is C<ISO-8859-2>.  Default C<code_page> is C<ISO-8859-2>.
45    
46  Default is not to use C<low_mem> options (see L<MEMORY USAGE> below).  Default is not to use C<low_mem> options (see L<MEMORY USAGE> below).
47    
48    There is optinal parametar C<filter> which specify different filters which
49    can be applied using C<filter{name}> notation.
50    
51  This method will also read configuration files  This method will also read configuration files
52  C<global.conf> (used by indexer and Web font-end)  C<global.conf> (used by indexer and Web font-end)
53  and configuration file specified by C<config_file>  and configuration file specified by C<config_file>
# Line 123  sub new { Line 129  sub new {
129                          $log->debug("removed '$db_file' from last run");                          $log->debug("removed '$db_file' from last run");
130                  }                  }
131    
132                  use DBM::Deep;                  require DBM::Deep;
133    
134                  my $db = new DBM::Deep $db_file;                  my $db = new DBM::Deep $db_file;
135    
# Line 138  sub new { Line 144  sub new {
144                  $self->{'db'} = $db;                  $self->{'db'} = $db;
145          }          }
146    
147            $log->debug("filters defined: ",Dumper($self->{'filter'}));
148    
149          return $self;          return $self;
150  }  }
151    
# Line 185  sub open_isis { Line 193  sub open_isis {
193          $log->logcroak("need filename") if (! $arg->{'filename'});          $log->logcroak("need filename") if (! $arg->{'filename'});
194          my $code_page = $arg->{'code_page'} || '852';          my $code_page = $arg->{'code_page'} || '852';
195    
196            $log->logdie("can't find database ",$arg->{'filename'}) unless (glob($arg->{'filename'}.'.*'));
197    
198          # store data in object          # store data in object
199          $self->{'isis_filename'} = $arg->{'filename'};          $self->{'isis_filename'} = $arg->{'filename'};
200          $self->{'isis_code_page'} = $code_page;          $self->{'isis_code_page'} = $code_page;
# Line 207  sub open_isis { Line 217  sub open_isis {
217          if (my $s = $self->{'start_mfn'}) {          if (my $s = $self->{'start_mfn'}) {
218                  $log->info("skipping to MFN $s");                  $log->info("skipping to MFN $s");
219                  $startmfn = $s;                  $startmfn = $s;
220            } else {
221                    $self->{'start_mfn'} = $startmfn;
222          }          }
223    
224          $maxmfn = $startmfn + $self->{limit_mfn} if ($self->{limit_mfn});          $maxmfn = $startmfn + $self->{limit_mfn} if ($self->{limit_mfn});
# Line 262  sub open_isis { Line 274  sub open_isis {
274    
275          }          }
276    
277          $self->{'current_mfn'} = $startmfn;          $self->{'current_mfn'} = -1;
278          $self->{'last_pcnt'} = 0;          $self->{'last_pcnt'} = 0;
279    
280          $log->debug("max mfn: $maxmfn");          $log->debug("max mfn: $maxmfn");
# Line 285  sub fetch_rec { Line 297  sub fetch_rec {
297    
298          my $log = $self->_get_logger();          my $log = $self->_get_logger();
299    
300          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'});
301    
302            if ($self->{'current_mfn'} == -1) {
303                    $self->{'current_mfn'} = $self->{'start_mfn'};
304            } else {
305                    $self->{'current_mfn'}++;
306            }
307    
308            my $mfn = $self->{'current_mfn'};
309    
310          if ($mfn > $self->{'max_mfn'}) {          if ($mfn > $self->{'max_mfn'}) {
311                  $self->{'current_mfn'} = $self->{'max_mfn'};                  $self->{'current_mfn'} = $self->{'max_mfn'};
# Line 302  sub fetch_rec { Line 322  sub fetch_rec {
322          }          }
323  }  }
324    
325    =head2 mfn
326    
327    Returns current record number (MFN).
328    
329     print $webpac->mfn;
330    
331    =cut
332    
333    sub mfn {
334            my $self = shift;
335            return $self->{'current_mfn'};
336    }
337    
338  =head2 progress_bar  =head2 progress_bar
339    
340  Draw progress bar on STDERR.  Draw progress bar on STDERR.
# Line 327  sub progress_bar { Line 360  sub progress_bar {
360    
361          $self->{'last_pcnt'} ||= 1;          $self->{'last_pcnt'} ||= 1;
362    
363          my $p = int($curr * 100 / $max);          my $p = int($curr * 100 / $max) || 1;
364    
365          # reset on re-run          # reset on re-run
366          if ($p < $self->{'last_pcnt'}) {          if ($p < $self->{'last_pcnt'}) {
367                  $self->{'last_pcnt'} = $p;                  $self->{'last_pcnt'} = $p;
368                  $self->{'last_t'} = time();                  $self->{'last_t'} = time();
369                  $self->{'last_curr'} = 1;                  $self->{'last_curr'} = undef;
370          }          }
371    
372            $self->{'last_t'} ||= time();
373    
374          if ($p != $self->{'last_pcnt'}) {          if ($p != $self->{'last_pcnt'}) {
375    
376                  my $last_curr = $self->{'last_curr'} || $curr;                  my $last_curr = $self->{'last_curr'} || $curr;
# Line 535  sub fill_in { Line 570  sub fill_in {
570          # iteration (for repeatable fields)          # iteration (for repeatable fields)
571          my $i = shift || 0;          my $i = shift || 0;
572    
573            $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));
574    
575          # FIXME remove for speedup?          # FIXME remove for speedup?
576          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
577    
# Line 548  sub fill_in { Line 585  sub fill_in {
585          # remove eval{...} from beginning          # remove eval{...} from beginning
586          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
587    
588            my $filter_name;
589            # remove filter{...} from beginning
590            $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
591    
592          # do actual replacement of placeholders          # do actual replacement of placeholders
593            # repeatable fields
594          $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;
595            # non-repeatable fields
596            $format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found)/ges;
597    
598          if ($found) {          if ($found) {
599                  $log->debug("format: $format");                  $log->debug("format: $format");
# Line 557  sub fill_in { Line 601  sub fill_in {
601                          my $eval = $self->fill_in($rec,$eval_code,$i);                          my $eval = $self->fill_in($rec,$eval_code,$i);
602                          return if (! $self->_eval($eval));                          return if (! $self->_eval($eval));
603                  }                  }
604                    if ($filter_name && $self->{'filter'}->{$filter_name}) {
605                            $log->debug("filter '$filter_name' for $format");
606                            $format = $self->{'filter'}->{$filter_name}->($format);
607                            return unless(defined($format));
608                            $log->debug("filter result: $format");
609                    }
610                  # do we have lookups?                  # do we have lookups?
611                  if ($format =~ /$LOOKUP_REGEX/o) {                  if ($format =~ /$LOOKUP_REGEX/o) {
612                          $log->debug("format '$format' has lookup");                          $log->debug("format '$format' has lookup");
# Line 649  sub parse { Line 699  sub parse {
699          # remove eval{...} from beginning          # remove eval{...} from beginning
700          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
701    
702            my $filter_name;
703            # remove filter{...} from beginning
704            $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
705    
706          my $prefix;          my $prefix;
707          my $all_found=0;          my $all_found=0;
708    
709          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))?//s) {          while ($format =~ s/^(.*?)(v|s)(\d+)(?:\^(\w))?//s) {
710    
711                  my $del = $1 || '';                  my $del = $1 || '';
712                  $prefix ||= $del if ($all_found == 0);                  $prefix ||= $del if ($all_found == 0);
713    
714                    # repeatable index
715                    my $r = $i;
716                    $r = 0 if (lc("$2") eq 's');
717    
718                  my $found = 0;                  my $found = 0;
719                  my $tmp = $self->get_data(\$rec,$2,$3,$i,\$found);                  my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found);
720    
721                  if ($found) {                  if ($found) {
722                          push @out, $del;                          push @out, $del;
# Line 682  sub parse { Line 740  sub parse {
740          }          }
741    
742          if ($eval_code) {          if ($eval_code) {
743                  my $eval = $self->fill_in($rec,$eval_code,$i);                  my $eval = $self->fill_in($rec,$eval_code,$i) || return;
744                  $log->debug("about to eval{",$eval,"} format: $out");                  $log->debug("about to eval{$eval} format: $out");
745                  return if (! $self->_eval($eval));                  return if (! $self->_eval($eval));
746          }          }
747            
748            if ($filter_name && $self->{'filter'}->{$filter_name}) {
749                    $log->debug("about to filter{$filter_name} format: $out");
750                    $out = $self->{'filter'}->{$filter_name}->($out);
751                    return unless(defined($out));
752                    $log->debug("filter result: $out");
753            }
754    
755          return $out;          return $out;
756  }  }
# Line 752  sub fill_in_to_arr { Line 817  sub fill_in_to_arr {
817          return @arr;          return @arr;
818  }  }
819    
820    =head2 sort_arr
821    
822    Sort array ignoring case and html in data
823    
824     my @sorted = $webpac->sort_arr(@unsorted);
825    
826    =cut
827    
828    sub sort_arr {
829            my $self = shift;
830    
831            my $log = $self->_get_logger();
832    
833            # FIXME add Schwartzian Transformation?
834    
835            my @sorted = sort {
836                    $a =~ s#<[^>]+/*>##;
837                    $b =~ s#<[^>]+/*>##;
838                    lc($b) cmp lc($a)
839            } @_;
840            $log->debug("sorted values: ",sub { join(", ",@sorted) });
841    
842            return @sorted;
843    }
844    
845    
846  =head2 data_structure  =head2 data_structure
847    
# Line 808  sub data_structure { Line 898  sub data_structure {
898                          }                          }
899                          next if (! @v);                          next if (! @v);
900    
901                            if ($tag->{'sort'}) {
902                                    @v = $self->sort_arr(@v);
903                                    $log->warn("sort within tag is usually not what you want!");
904                            }
905    
906                          # use format?                          # use format?
907                          if ($tag->{'format_name'}) {                          if ($tag->{'format_name'}) {
908                                  @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 822  sub data_structure { Line 917  sub data_structure {
917                                  next; # don't return headline in data_structure!                                  next; # don't return headline in data_structure!
918                          }                          }
919    
920                          # does tag have type?                          # delimiter will join repeatable fields
921                          if ($tag->{'type'}) {                          if ($tag->{'delimiter'}) {
922                                  push @{$row->{$tag->{'type'}}}, @v;                                  @v = ( join($tag->{'delimiter'}, @v) );
923                          } else {                          }
924                                  push @{$row->{'display'}}, @v;  
925                                  push @{$row->{'swish'}}, @v;                          # default types
926                            my @types = qw(display swish);
927                            # override by type attribute
928                            @types = ( $tag->{'type'} ) if ($tag->{'type'});
929    
930                            foreach my $type (@types) {
931                                    # append to previous line?
932                                    $log->debug("type: $type ",sub { join(" ",@v) }, $row->{'append'} || 'no append');
933                                    if ($tag->{'append'}) {
934    
935                                            # I will delimit appended part with
936                                            # delimiter (or ,)
937                                            my $d = $tag->{'delimiter'};
938                                            # default delimiter
939                                            $d ||= " ";
940    
941                                            my $last = pop @{$row->{$type}};
942                                            $d = "" if (! $last);
943                                            $last .= $d . join($d, @v);
944                                            push @{$row->{$type}}, $last;
945    
946                                    } else {
947                                            push @{$row->{$type}}, @v;
948                                    }
949                          }                          }
950    
951    
# Line 840  sub data_structure { Line 958  sub data_structure {
958                          my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};                          my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
959                          $row->{'name'} = $name ? $self->_x($name) : $field;                          $row->{'name'} = $name ? $self->_x($name) : $field;
960    
961                            # post-sort all values in field
962                            if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {
963                                    $log->warn("sort at field tag not implemented");
964                            }
965    
966                          push @ds, $row;                          push @ds, $row;
967    
968                          $log->debug("row $field: ",sub { Dumper($row) });                          $log->debug("row $field: ",sub { Dumper($row) });
# Line 985  sub _eval { Line 1108  sub _eval {
1108    
1109          $log->debug("eval: ",$code," [",$ret,"]");          $log->debug("eval: ",$code," [",$ret,"]");
1110    
1111          return $ret || 0;          return $ret || undef;
1112  }  }
1113    
1114  =head2 _sort_by_order  =head2 _sort_by_order
Legend:
Removed from v.431  
changed lines
  Added in v.555
  ViewVC Help
Powered by ViewVC 1.1.26