/[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 707 by dpavlin, Wed Jul 13 23:36:53 2005 UTC
# Line 13  use Time::HiRes qw(time); Line 13  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 34  Create new instance of WebPAC using conf Line 44  Create new instance of WebPAC using conf
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,]          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  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).
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  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>
# Line 106  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    
# Line 123  sub new { Line 138  sub new {
138                          $log->debug("removed '$db_file' from last run");                          $log->debug("removed '$db_file' from last run");
139                  }                  }
140    
141                  use DBM::Deep;                  require DBM::Deep;
142    
143                  my $db = new DBM::Deep $db_file;                  my $db = new DBM::Deep $db_file;
144    
# Line 138  sub new { Line 153  sub new {
153                  $self->{'db'} = $db;                  $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',
# Line 185  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            $log->logdie("can't find database ",$arg->{'filename'}) unless (glob($arg->{'filename'}.'.*'));
207    
208          # store data in object          # store data in object
209          $self->{'isis_filename'} = $arg->{'filename'};          $self->{'isis_filename'} = $arg->{'filename'};
210          $self->{'isis_code_page'} = $code_page;          $self->{'isis_code_page'} = $code_page;
211    
         use OpenIsis;  
   
212          #$self->{'isis_code_page'} = $code_page;          #$self->{'isis_code_page'} = $code_page;
213    
214          # create Text::Iconv object          # create Text::Iconv object
# Line 199  sub open_isis { Line 217  sub open_isis {
217          $log->info("reading ISIS database '",$arg->{'filename'},"'");          $log->info("reading ISIS database '",$arg->{'filename'},"'");
218          $log->debug("isis code page: $code_page");          $log->debug("isis code page: $code_page");
219    
220          my $isis_db = OpenIsis::open($arg->{'filename'});          my ($isis_db,$maxmfn);
221    
222            if ($have_openisis) {
223                    $log->debug("using OpenIsis perl bindings");
224                    $isis_db = OpenIsis::open($arg->{'filename'});
225                    $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;
226            } elsif ($have_biblio_isis) {
227                    $log->debug("using Biblio::Isis");
228                    use Biblio::Isis;
229                    $isis_db = new Biblio::Isis(
230                            isisdb => $arg->{'filename'},
231                            include_deleted => 1,
232                            hash_filter => sub {
233                                    my $l = shift || return;
234                                    $l = $cp->convert($l);
235                                    return $l;
236                            },
237                    );
238                    $maxmfn = $isis_db->count;
239    
240                    unless ($maxmfn) {
241                            $log->logwarn("no records in database ", $arg->{'filename'}, ", skipping...");
242                            return;
243                    }
244    
245            } else {
246                    $log->logdie("Can't find supported ISIS library for perl. I suggent that you install Bilbio::Isis from CPAN.");
247            }
248    
249    
         my $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;  
250          my $startmfn = 1;          my $startmfn = 1;
251    
252          if (my $s = $self->{'start_mfn'}) {          if (my $s = $self->{'start_mfn'}) {
253                  $log->info("skipping to MFN $s");                  $log->info("skipping to MFN $s");
254                  $startmfn = $s;                  $startmfn = $s;
255            } else {
256                    $self->{'start_mfn'} = $startmfn;
257          }          }
258    
259          $maxmfn = $startmfn + $self->{limit_mfn} if ($self->{limit_mfn});          $maxmfn = $startmfn + $self->{limit_mfn} if ($self->{limit_mfn});
260    
261          $log->info("processing ",($maxmfn-$startmfn)." records...");          $log->info("processing ",($maxmfn-$startmfn)." records using ",( $have_openisis ? 'OpenIsis' : 'Biblio::Isis'));
262    
263    
264          # read database          # read database
265          for (my $mfn = $startmfn; $mfn <= $maxmfn; $mfn++) {          for (my $mfn = $startmfn; $mfn <= $maxmfn; $mfn++) {
# Line 221  sub open_isis { Line 269  sub open_isis {
269    
270                  my $rec;                  my $rec;
271    
272                  # read record                  if ($have_openisis) {
273                  my $row = OpenIsis::read( $isis_db, $mfn );  
274                  foreach my $k (keys %{$row}) {                          # read record using OpenIsis
275                          if ($k ne "mfn") {                          my $row = OpenIsis::read( $isis_db, $mfn );
276                                  foreach my $l (@{$row->{$k}}) {                          foreach my $k (keys %{$row}) {
277                                          $l = $cp->convert($l);                                  if ($k ne "mfn") {
278                                          # has subfields?                                          foreach my $l (@{$row->{$k}}) {
279                                          my $val;                                                  $l = $cp->convert($l);
280                                          if ($l =~ m/\^/) {                                                  # has subfields?
281                                                  foreach my $t (split(/\^/,$l)) {                                                  my $val;
282                                                          next if (! $t);                                                  if ($l =~ m/\^/) {
283                                                          $val->{substr($t,0,1)} = substr($t,1);                                                          foreach my $t (split(/\^/,$l)) {
284                                                                    next if (! $t);
285                                                                    $val->{substr($t,0,1)} = substr($t,1);
286                                                            }
287                                                    } else {
288                                                            $val = $l;
289                                                  }                                                  }
                                         } else {  
                                                 $val = $l;  
                                         }  
290    
291                                          push @{$rec->{$k}}, $val;                                                  push @{$rec->{$k}}, $val;
292                                            }
293                                    } else {
294                                            push @{$rec->{'000'}}, $mfn;
295                                  }                                  }
                         } else {  
                                 push @{$rec->{'000'}}, $mfn;  
296                          }                          }
297    
298                    } elsif ($have_biblio_isis) {
299                            $rec = $isis_db->to_hash($mfn);
300                    } else {
301                            $log->logdie("hum? implementation missing?");
302                  }                  }
303    
304                  $log->confess("record $mfn empty?") unless ($rec);                  $log->confess("record $mfn empty?") unless ($rec);
# Line 262  sub open_isis { Line 317  sub open_isis {
317    
318          }          }
319    
320          $self->{'current_mfn'} = $startmfn;          $self->{'current_mfn'} = -1;
321          $self->{'last_pcnt'} = 0;          $self->{'last_pcnt'} = 0;
322    
323          $log->debug("max mfn: $maxmfn");          $log->debug("max mfn: $maxmfn");
# Line 285  sub fetch_rec { Line 340  sub fetch_rec {
340    
341          my $log = $self->_get_logger();          my $log = $self->_get_logger();
342    
343          my $mfn = $self->{'current_mfn'}++ || $log->logconfess("it seems that you didn't load database!");          $log->logconfess("it seems that you didn't load database!") unless ($self->{'current_mfn'});
344    
345            if ($self->{'current_mfn'} == -1) {
346                    $self->{'current_mfn'} = $self->{'start_mfn'};
347            } else {
348                    $self->{'current_mfn'}++;
349            }
350    
351            my $mfn = $self->{'current_mfn'};
352    
353          if ($mfn > $self->{'max_mfn'}) {          if ($mfn > $self->{'max_mfn'}) {
354                  $self->{'current_mfn'} = $self->{'max_mfn'};                  $self->{'current_mfn'} = $self->{'max_mfn'};
# Line 302  sub fetch_rec { Line 365  sub fetch_rec {
365          }          }
366  }  }
367    
368    =head2 mfn
369    
370    Returns current record number (MFN).
371    
372     print $webpac->mfn;
373    
374    =cut
375    
376    sub mfn {
377            my $self = shift;
378            return $self->{'current_mfn'};
379    }
380    
381  =head2 progress_bar  =head2 progress_bar
382    
383  Draw progress bar on STDERR.  Draw progress bar on STDERR.
# Line 327  sub progress_bar { Line 403  sub progress_bar {
403    
404          $self->{'last_pcnt'} ||= 1;          $self->{'last_pcnt'} ||= 1;
405    
406          my $p = int($curr * 100 / $max);          my $p = int($curr * 100 / $max) || 1;
407    
408          # reset on re-run          # reset on re-run
409          if ($p < $self->{'last_pcnt'}) {          if ($p < $self->{'last_pcnt'}) {
410                  $self->{'last_pcnt'} = $p;                  $self->{'last_pcnt'} = $p;
411                  $self->{'last_t'} = time();                  $self->{'start_t'} = time();
                 $self->{'last_curr'} = 1;  
412          }          }
413    
414          if ($p != $self->{'last_pcnt'}) {          if ($p != $self->{'last_pcnt'}) {
415    
                 my $last_curr = $self->{'last_curr'} || $curr;  
416                  my $t = time();                  my $t = time();
417                  my $rate = ($curr - $last_curr) / (($t - $self->{'last_t'} || 1));                  my $rate = ($curr / ($t - $self->{'start_t'} || 1));
418                  my $eta = ($max-$curr) / ($rate || 1);                  my $eta = ($max-$curr) / ($rate || 1);
419                  printf STDERR ("%5d [%-38s] %-5d %0.1f/s %s\r",$curr,"=" x ($p/3)."$p%>", $max, $rate, $self->fmt_time($eta));                  printf STDERR ("%5d [%-38s] %-5d %0.1f/s %s\r",$curr,"=" x ($p/3)."$p%>", $max, $rate, $self->fmt_time($eta));
420                  $self->{'last_pcnt'} = $p;                  $self->{'last_pcnt'} = $p;
                 $self->{'last_t'} = time();  
421                  $self->{'last_curr'} = $curr;                  $self->{'last_curr'} = $curr;
422          }          }
423          print STDERR "\n" if ($p == 100);          print STDERR "\n" if ($p == 100);
# Line 535  sub fill_in { Line 608  sub fill_in {
608          # iteration (for repeatable fields)          # iteration (for repeatable fields)
609          my $i = shift || 0;          my $i = shift || 0;
610    
611            $log->logdie("infitite loop in format $format") if ($i > ($self->{'max_mfn'} || 9999));
612    
613          # FIXME remove for speedup?          # FIXME remove for speedup?
614          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
615    
# Line 548  sub fill_in { Line 623  sub fill_in {
623          # remove eval{...} from beginning          # remove eval{...} from beginning
624          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
625    
626            my $filter_name;
627            # remove filter{...} from beginning
628            $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
629    
630          # do actual replacement of placeholders          # do actual replacement of placeholders
631            # repeatable fields
632          $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;
633            # non-repeatable fields
634            $format =~ s/s(\d+)(?:\^(\w))?/$self->get_data(\$rec,$1,$2,0,\$found)/ges;
635    
636          if ($found) {          if ($found) {
637                  $log->debug("format: $format");                  $log->debug("format: $format");
# Line 557  sub fill_in { Line 639  sub fill_in {
639                          my $eval = $self->fill_in($rec,$eval_code,$i);                          my $eval = $self->fill_in($rec,$eval_code,$i);
640                          return if (! $self->_eval($eval));                          return if (! $self->_eval($eval));
641                  }                  }
642                    if ($filter_name && $self->{'filter'}->{$filter_name}) {
643                            $log->debug("filter '$filter_name' for $format");
644                            $format = $self->{'filter'}->{$filter_name}->($format);
645                            return unless(defined($format));
646                            $log->debug("filter result: $format");
647                    }
648                  # do we have lookups?                  # do we have lookups?
649                  if ($format =~ /$LOOKUP_REGEX/o) {                  if ($format =~ /$LOOKUP_REGEX/o) {
650                          $log->debug("format '$format' has lookup");                          $log->debug("format '$format' has lookup");
# Line 649  sub parse { Line 737  sub parse {
737          # remove eval{...} from beginning          # remove eval{...} from beginning
738          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
739    
740            my $filter_name;
741            # remove filter{...} from beginning
742            $filter_name = $1 if ($format =~ s/^filter{([^}]+)}//s);
743    
744          my $prefix;          my $prefix;
745          my $all_found=0;          my $all_found=0;
746    
747          while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))?//s) {          while ($format =~ s/^(.*?)(v|s)(\d+)(?:\^(\w))?//s) {
748    
749                  my $del = $1 || '';                  my $del = $1 || '';
750                  $prefix ||= $del if ($all_found == 0);                  $prefix ||= $del if ($all_found == 0);
751    
752                    # repeatable index
753                    my $r = $i;
754                    $r = 0 if (lc("$2") eq 's');
755    
756                  my $found = 0;                  my $found = 0;
757                  my $tmp = $self->get_data(\$rec,$2,$3,$i,\$found);                  my $tmp = $self->get_data(\$rec,$3,$4,$r,\$found);
758    
759                  if ($found) {                  if ($found) {
760                          push @out, $del;                          push @out, $del;
# Line 682  sub parse { Line 778  sub parse {
778          }          }
779    
780          if ($eval_code) {          if ($eval_code) {
781                  my $eval = $self->fill_in($rec,$eval_code,$i);                  my $eval = $self->fill_in($rec,$eval_code,$i) || return;
782                  $log->debug("about to eval{",$eval,"} format: $out");                  $log->debug("about to eval{$eval} format: $out");
783                  return if (! $self->_eval($eval));                  return if (! $self->_eval($eval));
784          }          }
785            
786            if ($filter_name && $self->{'filter'}->{$filter_name}) {
787                    $log->debug("about to filter{$filter_name} format: $out");
788                    $out = $self->{'filter'}->{$filter_name}->($out);
789                    return unless(defined($out));
790                    $log->debug("filter result: $out");
791            }
792    
793          return $out;          return $out;
794  }  }
# Line 752  sub fill_in_to_arr { Line 855  sub fill_in_to_arr {
855          return @arr;          return @arr;
856  }  }
857    
858    =head2 sort_arr
859    
860    Sort array ignoring case and html in data
861    
862     my @sorted = $webpac->sort_arr(@unsorted);
863    
864    =cut
865    
866    sub sort_arr {
867            my $self = shift;
868    
869            my $log = $self->_get_logger();
870    
871            # FIXME add Schwartzian Transformation?
872    
873            my @sorted = sort {
874                    $a =~ s#<[^>]+/*>##;
875                    $b =~ s#<[^>]+/*>##;
876                    lc($b) cmp lc($a)
877            } @_;
878            $log->debug("sorted values: ",sub { join(", ",@sorted) });
879    
880            return @sorted;
881    }
882    
883    
884  =head2 data_structure  =head2 data_structure
885    
# Line 808  sub data_structure { Line 936  sub data_structure {
936                          }                          }
937                          next if (! @v);                          next if (! @v);
938    
939                            if ($tag->{'sort'}) {
940                                    @v = $self->sort_arr(@v);
941                            }
942    
943                          # use format?                          # use format?
944                          if ($tag->{'format_name'}) {                          if ($tag->{'format_name'}) {
945                                  @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 954  sub data_structure {
954                                  next; # don't return headline in data_structure!                                  next; # don't return headline in data_structure!
955                          }                          }
956    
957                          # does tag have type?                          # delimiter will join repeatable fields
958                          if ($tag->{'type'}) {                          if ($tag->{'delimiter'}) {
959                                  push @{$row->{$tag->{'type'}}}, @v;                                  @v = ( join($tag->{'delimiter'}, @v) );
960                          } else {                          }
961                                  push @{$row->{'display'}}, @v;  
962                                  push @{$row->{'swish'}}, @v;                          # default types
963                            my @types = qw(display swish);
964                            # override by type attribute
965                            @types = ( $tag->{'type'} ) if ($tag->{'type'});
966    
967                            foreach my $type (@types) {
968                                    # append to previous line?
969                                    $log->debug("type: $type ",sub { join(" ",@v) }, $row->{'append'} || 'no append');
970                                    if ($tag->{'append'}) {
971    
972                                            # I will delimit appended part with
973                                            # delimiter (or ,)
974                                            my $d = $tag->{'delimiter'};
975                                            # default delimiter
976                                            $d ||= " ";
977    
978                                            my $last = pop @{$row->{$type}};
979                                            $d = "" if (! $last);
980                                            $last .= $d . join($d, @v);
981                                            push @{$row->{$type}}, $last;
982    
983                                    } else {
984                                            push @{$row->{$type}}, @v;
985                                    }
986                          }                          }
987    
988    
# Line 840  sub data_structure { Line 995  sub data_structure {
995                          my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};                          my $name = $self->{'import_xml'}->{'indexer'}->{$field}->{'name'};
996                          $row->{'name'} = $name ? $self->_x($name) : $field;                          $row->{'name'} = $name ? $self->_x($name) : $field;
997    
998                            # post-sort all values in field
999                            if ($self->{'import_xml'}->{'indexer'}->{$field}->{'sort'}) {
1000                                    $log->warn("sort at field tag not implemented");
1001                            }
1002    
1003                          push @ds, $row;                          push @ds, $row;
1004    
1005                          $log->debug("row $field: ",sub { Dumper($row) });                          $log->debug("row $field: ",sub { Dumper($row) });
# Line 985  sub _eval { Line 1145  sub _eval {
1145    
1146          $log->debug("eval: ",$code," [",$ret,"]");          $log->debug("eval: ",$code," [",$ret,"]");
1147    
1148          return $ret || 0;          return $ret || undef;
1149  }  }
1150    
1151  =head2 _sort_by_order  =head2 _sort_by_order
Legend:
Removed from v.431  
changed lines
  Added in v.707
  ViewVC Help
Powered by ViewVC 1.1.26