/[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 422 by dpavlin, Sat Sep 11 08:36:38 2004 UTC revision 560 by dpavlin, Sat Oct 30 23:04:37 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    Same filters can be used in Template Toolkit files.
51    
52  This method will also read configuration files  This method will also read configuration files
53  C<global.conf> (used by indexer and Web font-end)  C<global.conf> (used by indexer and Web font-end)
54  and configuration file specified by C<config_file>  and configuration file specified by C<config_file>
# Line 106  sub new { Line 113  sub new {
113          # create Template toolkit instance          # create Template toolkit instance
114          $self->{'tt'} = Template->new(          $self->{'tt'} = Template->new(
115                  INCLUDE_PATH => ($self->{'global_config_file'}->{'output_template'} || './output_template'),                  INCLUDE_PATH => ($self->{'global_config_file'}->{'output_template'} || './output_template'),
116  #               FILTERS => {                  FILTERS => $self->{'filter'},
 #                       'foo' => \&foo_filter,  
 #               },  
117                  EVAL_PERL => 1,                  EVAL_PERL => 1,
118          );          );
119    
# Line 123  sub new { Line 128  sub new {
128                          $log->debug("removed '$db_file' from last run");                          $log->debug("removed '$db_file' from last run");
129                  }                  }
130    
131                  use DBM::Deep;                  require DBM::Deep;
132    
133                  my $db = new DBM::Deep $db_file;                  my $db = new DBM::Deep $db_file;
134    
# Line 138  sub new { Line 143  sub new {
143                  $self->{'db'} = $db;                  $self->{'db'} = $db;
144          }          }
145    
146            $log->debug("filters defined: ",Dumper($self->{'filter'}));
147    
148          return $self;          return $self;
149  }  }
150    
# Line 148  Open CDS/ISIS database using OpenIsis mo Line 155  Open CDS/ISIS database using OpenIsis mo
155   $webpac->open_isis(   $webpac->open_isis(
156          filename => '/data/ISIS/ISIS',          filename => '/data/ISIS/ISIS',
157          code_page => '852',          code_page => '852',
158          limit_mfn => '500',          limit_mfn => 500,
159            start_mfn => 6000,
160          lookup => [ ... ],          lookup => [ ... ],
161   );   );
162    
163  By default, ISIS code page is assumed to be C<852>.  By default, ISIS code page is assumed to be C<852>.
164    
165    If optional parametar C<start_mfn> is set, this will be first MFN to read
166    from database (so you can skip beginning of your database if you need to).
167    
168  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
169  from database in example above.  from database in example above.
170    
# Line 181  sub open_isis { Line 192  sub open_isis {
192          $log->logcroak("need filename") if (! $arg->{'filename'});          $log->logcroak("need filename") if (! $arg->{'filename'});
193          my $code_page = $arg->{'code_page'} || '852';          my $code_page = $arg->{'code_page'} || '852';
194    
195            $log->logdie("can't find database ",$arg->{'filename'}) unless (glob($arg->{'filename'}.'.*'));
196    
197          # store data in object          # store data in object
198          $self->{'isis_filename'} = $arg->{'filename'};          $self->{'isis_filename'} = $arg->{'filename'};
199          $self->{'isis_code_page'} = $code_page;          $self->{'isis_code_page'} = $code_page;
# Line 198  sub open_isis { Line 211  sub open_isis {
211          my $isis_db = OpenIsis::open($arg->{'filename'});          my $isis_db = OpenIsis::open($arg->{'filename'});
212    
213          my $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;          my $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;
214            my $startmfn = 1;
215    
216            if (my $s = $self->{'start_mfn'}) {
217                    $log->info("skipping to MFN $s");
218                    $startmfn = $s;
219            } else {
220                    $self->{'start_mfn'} = $startmfn;
221            }
222    
223          $maxmfn = $self->{limit_mfn} if ($self->{limit_mfn});          $maxmfn = $startmfn + $self->{limit_mfn} if ($self->{limit_mfn});
224    
225          $log->info("processing $maxmfn records...");          $log->info("processing ",($maxmfn-$startmfn)." records...");
226    
227          # read database          # read database
228          for (my $mfn = 1; $mfn <= $maxmfn; $mfn++) {          for (my $mfn = $startmfn; $mfn <= $maxmfn; $mfn++) {
229    
230    
231                  $log->debug("mfn: $mfn\n");                  $log->debug("mfn: $mfn\n");
# Line 252  sub open_isis { Line 273  sub open_isis {
273    
274          }          }
275    
276          $self->{'current_mfn'} = 1;          $self->{'current_mfn'} = -1;
277          $self->{'last_pcnt'} = 0;          $self->{'last_pcnt'} = 0;
278    
279          $log->debug("max mfn: $maxmfn");          $log->debug("max mfn: $maxmfn");
# Line 275  sub fetch_rec { Line 296  sub fetch_rec {
296    
297          my $log = $self->_get_logger();          my $log = $self->_get_logger();
298    
299          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'});
300    
301            if ($self->{'current_mfn'} == -1) {
302                    $self->{'current_mfn'} = $self->{'start_mfn'};
303            } else {
304                    $self->{'current_mfn'}++;
305            }
306    
307            my $mfn = $self->{'current_mfn'};
308    
309          if ($mfn > $self->{'max_mfn'}) {          if ($mfn > $self->{'max_mfn'}) {
310                  $self->{'current_mfn'} = $self->{'max_mfn'};                  $self->{'current_mfn'} = $self->{'max_mfn'};
# Line 292  sub fetch_rec { Line 321  sub fetch_rec {
321          }          }
322  }  }
323    
324    =head2 mfn
325    
326    Returns current record number (MFN).
327    
328     print $webpac->mfn;
329    
330    =cut
331    
332    sub mfn {
333            my $self = shift;
334            return $self->{'current_mfn'};
335    }
336    
337  =head2 progress_bar  =head2 progress_bar
338    
339  Draw progress bar on STDERR.  Draw progress bar on STDERR.
# Line 317  sub progress_bar { Line 359  sub progress_bar {
359    
360          $self->{'last_pcnt'} ||= 1;          $self->{'last_pcnt'} ||= 1;
361    
362          my $p = int($curr * 100 / $max);          my $p = int($curr * 100 / $max) || 1;
363    
364          # reset on re-run          # reset on re-run
365          if ($p < $self->{'last_pcnt'}) {          if ($p < $self->{'last_pcnt'}) {
366                  $self->{'last_pcnt'} = $p;                  $self->{'last_pcnt'} = $p;
367                  $self->{'last_t'} = time();                  $self->{'last_t'} = time();
368                  $self->{'last_curr'} = 1;                  $self->{'last_curr'} = undef;
369          }          }
370    
371            $self->{'last_t'} ||= time();
372    
373          if ($p != $self->{'last_pcnt'}) {          if ($p != $self->{'last_pcnt'}) {
374    
375                  my $last_curr = $self->{'last_curr'} || $curr;                  my $last_curr = $self->{'last_curr'} || $curr;
# Line 525  sub fill_in { Line 569  sub fill_in {
569          # iteration (for repeatable fields)          # iteration (for repeatable fields)
570          my $i = shift || 0;          my $i = shift || 0;
571    
572            $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));
573    
574          # FIXME remove for speedup?          # FIXME remove for speedup?
575          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
576    
# Line 538  sub fill_in { Line 584  sub fill_in {
584          # remove eval{...} from beginning          # remove eval{...} from beginning
585          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
586    
587            my $filter_name;
588            # remove filter{...} from beginning
589            $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
590    
591          # do actual replacement of placeholders          # do actual replacement of placeholders
592            # repeatable fields
593          $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;
594            # non-repeatable fields
595            $format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found)/ges;
596    
597          if ($found) {          if ($found) {
598                  $log->debug("format: $format");                  $log->debug("format: $format");
# Line 547  sub fill_in { Line 600  sub fill_in {
600                          my $eval = $self->fill_in($rec,$eval_code,$i);                          my $eval = $self->fill_in($rec,$eval_code,$i);
601                          return if (! $self->_eval($eval));                          return if (! $self->_eval($eval));
602                  }                  }
603                    if ($filter_name && $self->{'filter'}->{$filter_name}) {
604                            $log->debug("filter '$filter_name' for $format");
605                            $format = $self->{'filter'}->{$filter_name}->($format);
606                            return unless(defined($format));
607                            $log->debug("filter result: $format");
608                    }
609                  # do we have lookups?                  # do we have lookups?
610                  if ($format =~ /$LOOKUP_REGEX/o) {                  if ($format =~ /$LOOKUP_REGEX/o) {
611                          $log->debug("format '$format' has lookup");                          $log->debug("format '$format' has lookup");
# Line 639  sub parse { Line 698  sub parse {
698          # remove eval{...} from beginning          # remove eval{...} from beginning
699          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
700    
701            my $filter_name;
702            # remove filter{...} from beginning
703            $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
704    
705          my $prefix;          my $prefix;
706          my $all_found=0;          my $all_found=0;
707    
708          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))?//s) {          while ($format =~ s/^(.*?)(v|s)(\d+)(?:\^(\w))?//s) {
709    
710                  my $del = $1 || '';                  my $del = $1 || '';
711                  $prefix ||= $del if ($all_found == 0);                  $prefix ||= $del if ($all_found == 0);
712    
713                    # repeatable index
714                    my $r = $i;
715                    $r = 0 if (lc("$2") eq 's');
716    
717                  my $found = 0;                  my $found = 0;
718                  my $tmp = $self->get_data(\$rec,$2,$3,$i,\$found);                  my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found);
719    
720                  if ($found) {                  if ($found) {
721                          push @out, $del;                          push @out, $del;
# Line 672  sub parse { Line 739  sub parse {
739          }          }
740    
741          if ($eval_code) {          if ($eval_code) {
742                  my $eval = $self->fill_in($rec,$eval_code,$i);                  my $eval = $self->fill_in($rec,$eval_code,$i) || return;
743                  $log->debug("about to eval{",$eval,"} format: $out");                  $log->debug("about to eval{$eval} format: $out");
744                  return if (! $self->_eval($eval));                  return if (! $self->_eval($eval));
745          }          }
746            
747            if ($filter_name && $self->{'filter'}->{$filter_name}) {
748                    $log->debug("about to filter{$filter_name} format: $out");
749                    $out = $self->{'filter'}->{$filter_name}->($out);
750                    return unless(defined($out));
751                    $log->debug("filter result: $out");
752            }
753    
754          return $out;          return $out;
755  }  }
# Line 742  sub fill_in_to_arr { Line 816  sub fill_in_to_arr {
816          return @arr;          return @arr;
817  }  }
818    
819    =head2 sort_arr
820    
821    Sort array ignoring case and html in data
822    
823     my @sorted = $webpac->sort_arr(@unsorted);
824    
825    =cut
826    
827    sub sort_arr {
828            my $self = shift;
829    
830            my $log = $self->_get_logger();
831    
832            # FIXME add Schwartzian Transformation?
833    
834            my @sorted = sort {
835                    $a =~ s#<[^>]+/*>##;
836                    $b =~ s#<[^>]+/*>##;
837                    lc($b) cmp lc($a)
838            } @_;
839            $log->debug("sorted values: ",sub { join(", ",@sorted) });
840    
841            return @sorted;
842    }
843    
844    
845  =head2 data_structure  =head2 data_structure
846    
# Line 798  sub data_structure { Line 897  sub data_structure {
897                          }                          }
898                          next if (! @v);                          next if (! @v);
899    
900                            if ($tag->{'sort'}) {
901                                    @v = $self->sort_arr(@v);
902                                    $log->warn("sort within tag is usually not what you want!");
903                            }
904    
905                          # use format?                          # use format?
906                          if ($tag->{'format_name'}) {                          if ($tag->{'format_name'}) {
907                                  @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 812  sub data_structure { Line 916  sub data_structure {
916                                  next; # don't return headline in data_structure!                                  next; # don't return headline in data_structure!
917                          }                          }
918    
919                          # does tag have type?                          # delimiter will join repeatable fields
920                          if ($tag->{'type'}) {                          if ($tag->{'delimiter'}) {
921                                  push @{$row->{$tag->{'type'}}}, @v;                                  @v = ( join($tag->{'delimiter'}, @v) );
922                          } else {                          }
923                                  push @{$row->{'display'}}, @v;  
924                                  push @{$row->{'swish'}}, @v;                          # default types
925                            my @types = qw(display swish);
926                            # override by type attribute
927                            @types = ( $tag->{'type'} ) if ($tag->{'type'});
928    
929                            foreach my $type (@types) {
930                                    # append to previous line?
931                                    $log->debug("type: $type ",sub { join(" ",@v) }, $row->{'append'} || 'no append');
932                                    if ($tag->{'append'}) {
933    
934                                            # I will delimit appended part with
935                                            # delimiter (or ,)
936                                            my $d = $tag->{'delimiter'};
937                                            # default delimiter
938                                            $d ||= " ";
939    
940                                            my $last = pop @{$row->{$type}};
941                                            $d = "" if (! $last);
942                                            $last .= $d . join($d, @v);
943                                            push @{$row->{$type}}, $last;
944    
945                                    } else {
946                                            push @{$row->{$type}}, @v;
947                                    }
948                          }                          }
949    
950    
# Line 830  sub data_structure { Line 957  sub data_structure {
957                          my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};                          my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
958                          $row->{'name'} = $name ? $self->_x($name) : $field;                          $row->{'name'} = $name ? $self->_x($name) : $field;
959    
960                            # post-sort all values in field
961                            if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {
962                                    $log->warn("sort at field tag not implemented");
963                            }
964    
965                          push @ds, $row;                          push @ds, $row;
966    
967                          $log->debug("row $field: ",sub { Dumper($row) });                          $log->debug("row $field: ",sub { Dumper($row) });
# Line 975  sub _eval { Line 1107  sub _eval {
1107    
1108          $log->debug("eval: ",$code," [",$ret,"]");          $log->debug("eval: ",$code," [",$ret,"]");
1109    
1110          return $ret || 0;          return $ret || undef;
1111  }  }
1112    
1113  =head2 _sort_by_order  =head2 _sort_by_order
Legend:
Removed from v.422  
changed lines
  Added in v.560
  ViewVC Help
Powered by ViewVC 1.1.26