/[webpac2]/trunk/lib/WebPAC/Input.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 /trunk/lib/WebPAC/Input.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 757 by dpavlin, Tue Oct 10 10:57:59 2006 UTC revision 910 by dpavlin, Tue Oct 30 01:51:20 2007 UTC
# Line 7  use blib; Line 7  use blib;
7    
8  use WebPAC::Common;  use WebPAC::Common;
9  use base qw/WebPAC::Common/;  use base qw/WebPAC::Common/;
10  use Data::Dumper;  use Data::Dump qw/dump/;
11  use Encode qw/from_to/;  use Encode qw/from_to/;
12    
13  =head1 NAME  =head1 NAME
# Line 16  WebPAC::Input - read different file form Line 16  WebPAC::Input - read different file form
16    
17  =head1 VERSION  =head1 VERSION
18    
19  Version 0.13  Version 0.18
20    
21  =cut  =cut
22    
23  our $VERSION = '0.13';  our $VERSION = '0.18';
24    
25  =head1 SYNOPSIS  =head1 SYNOPSIS
26    
# Line 43  Perhaps a little code snippet. Line 43  Perhaps a little code snippet.
43    
44          my $db = WebPAC::Input->new(          my $db = WebPAC::Input->new(
45                  module => 'WebPAC::Input::ISIS',                  module => 'WebPAC::Input::ISIS',
                 low_mem => 1,  
46          );          );
47    
48          $db->open( path => '/path/to/database' );          $db->open( path => '/path/to/database' );
# Line 63  Create new input database object. Line 62  Create new input database object.
62    my $db = new WebPAC::Input(    my $db = new WebPAC::Input(
63          module => 'WebPAC::Input::MARC',          module => 'WebPAC::Input::MARC',
64          encoding => 'ISO-8859-2',          encoding => 'ISO-8859-2',
         low_mem => 1,  
65          recode => 'char pairs',          recode => 'char pairs',
66          no_progress_bar => 1,          no_progress_bar => 1,
67            input_config => {
68                    mapping => [ 'foo', 'bar', 'baz' ],
69            },
70    );    );
71    
72  C<module> is low-level file format module. See L<WebPAC::Input::ISIS> and  C<module> is low-level file format module. See L<WebPAC::Input::ISIS> and
# Line 75  Optional parametar C<encoding> specify a Line 76  Optional parametar C<encoding> specify a
76  used internally). This should probably be your terminal encoding, and by  used internally). This should probably be your terminal encoding, and by
77  default, it C<ISO-8859-2>.  default, it C<ISO-8859-2>.
78    
 Default is not to use C<low_mem> options (see L<MEMORY USAGE> below).  
   
79  C<recode> is optional string constisting of character or words pairs that  C<recode> is optional string constisting of character or words pairs that
80  should be replaced in input stream.  should be replaced in input stream.
81    
# Line 96  sub new { Line 95  sub new {
95    
96          $log->logconfess("code_page argument is not suppored any more. change it to encoding") if ($self->{lookup});          $log->logconfess("code_page argument is not suppored any more. change it to encoding") if ($self->{lookup});
97          $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if ($self->{lookup});          $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if ($self->{lookup});
98            $log->logconfess("low_mem argument is not suppored any more. rewrite it to load_row and save_row") if ($self->{low_mem});
99    
100          $log->logconfess("specify low-level file format module") unless ($self->{module});          $log->logconfess("specify low-level file format module") unless ($self->{module});
101          my $module_path = $self->{module};          my $module_path = $self->{module};
# Line 105  sub new { Line 105  sub new {
105    
106          require $module_path;          require $module_path;
107    
         # check if required subclasses are implemented  
         foreach my $subclass (qw/open_db fetch_rec init dump_rec/) {  
                 # FIXME  
         }  
   
108          $self->{'encoding'} ||= 'ISO-8859-2';          $self->{'encoding'} ||= 'ISO-8859-2';
109    
         # running with low_mem flag? well, use DBM::Deep then.  
         if ($self->{'low_mem'}) {  
                 $log->info("running with low_mem which impacts performance (<32 Mb memory usage)");  
   
                 my $db_file = "data.db";  
   
                 if (-e $db_file) {  
                         unlink $db_file or $log->logdie("can't remove '$db_file' from last run");  
                         $log->debug("removed '$db_file' from last run");  
                 }  
   
                 require DBM::Deep;  
   
                 my $db = new DBM::Deep $db_file;  
   
                 $log->logdie("DBM::Deep error: $!") unless ($db);  
   
                 if ($db->error()) {  
                         $log->logdie("can't open '$db_file' under low_mem: ",$db->error());  
                 } else {  
                         $log->debug("using file '$db_file' for DBM::Deep");  
                 }  
   
                 $self->{'db'} = $db;  
         }  
   
110          $self ? return $self : return undef;          $self ? return $self : return undef;
111  }  }
112    
# Line 145  sub new { Line 114  sub new {
114    
115  This function will read whole database in memory and produce lookups.  This function will read whole database in memory and produce lookups.
116    
117     my $store;     # simple in-memory hash
118    
119   $input->open(   $input->open(
120          path => '/path/to/database/file',          path => '/path/to/database/file',
121          code_page => 'cp852',          code_page => 'cp852',
# Line 160  This function will read whole database i Line 131  This function will read whole database i
131                  901 => { '*' => { '^b' => ' ; ' } },                  901 => { '*' => { '^b' => ' ; ' } },
132          },          },
133          modify_file => 'conf/modify/mapping.map',          modify_file => 'conf/modify/mapping.map',
134            save_row => sub {
135                    my $a = shift;
136                    $store->{ $a->{id} } = $a->{row};
137            },
138            load_row => sub {
139                    my $a = shift;
140                    return defined($store->{ $a->{id} }) &&
141                            $store->{ $a->{id} };
142            },
143    
144   );   );
145    
146  By default, C<code_page> is assumed to be C<cp852>.  By default, C<code_page> is assumed to be C<cp852>.
# Line 180  C<modify_file> is alternative for C<modi Line 161  C<modify_file> is alternative for C<modi
161  (hopefully) simplier sintax than YAML or perl (see L</modify_file_regex>). This option  (hopefully) simplier sintax than YAML or perl (see L</modify_file_regex>). This option
162  overrides C<modify_records> if both exists for same input.  overrides C<modify_records> if both exists for same input.
163    
164    C<save_row> and C<load_row> are low-level implementation of store engine. Calling convention
165    is documented in example above.
166    
167  Returns size of database, regardless of C<offset> and C<limit>  Returns size of database, regardless of C<offset> and C<limit>
168  parametars, see also C<size>.  parametars, see also C<size>.
169    
# Line 206  sub open { Line 190  sub open {
190                  $self->{$v} = $arg->{$v} if ($arg->{$v});                  $self->{$v} = $arg->{$v} if ($arg->{$v});
191          }          }
192    
193            if ($arg->{load_row} || $arg->{save_row}) {
194                    $log->logconfess("save_row and load_row must be defined in pair and be CODE") unless (
195                            ref($arg->{load_row}) eq 'CODE' &&
196                            ref($arg->{save_row}) eq 'CODE'
197                    );
198                    $self->{load_row} = $arg->{load_row};
199                    $self->{save_row} = $arg->{save_row};
200                    $log->debug("using load_row and save_row instead of in-memory hash");
201            }
202    
203          my $filter_ref;          my $filter_ref;
204          my $recode_regex;          my $recode_regex;
205          my $recode_map;          my $recode_map;
# Line 233  sub open { Line 227  sub open {
227                  $log->debug("using modify_file $p");                  $log->debug("using modify_file $p");
228                  $rec_regex = $self->modify_file_regexps( $p );                  $rec_regex = $self->modify_file_regexps( $p );
229          } elsif (my $h = $arg->{modify_records}) {          } elsif (my $h = $arg->{modify_records}) {
230                  $log->debug("using modify_records ", Dumper( $h ));                  $log->debug("using modify_records ", sub { dump( $h ) });
231                  $rec_regex = $self->modify_record_regexps(%{ $h });                  $rec_regex = $self->modify_record_regexps(%{ $h });
232          }          }
233          $log->debug("rec_regex: ", Dumper($rec_regex)) if ($rec_regex);          $log->debug("rec_regex: ", sub { dump($rec_regex) }) if ($rec_regex);
234    
235          my $class = $self->{module} || $log->logconfess("can't get low-level module name!");          my $class = $self->{module} || $log->logconfess("can't get low-level module name!");
236    
237          my $ll_db = $class->new(          my $ll_db = $class->new(
238                  path => $arg->{path},                  path => $arg->{path},
239                    input_config => $arg->{input_config} || $self->{input_config},
240  #               filter => sub {  #               filter => sub {
241  #                       my ($l,$f_nr) = @_;  #                       my ($l,$f_nr) = @_;
242  #                       return unless defined($l);  #                       return unless defined($l);
# Line 291  sub open { Line 286  sub open {
286                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
287    
288                  my $rec = $ll_db->fetch_rec($pos, sub {                  my $rec = $ll_db->fetch_rec($pos, sub {
289                                  my ($l,$f_nr) = @_;                                  my ($l,$f_nr,$debug) = @_;
290  #                               return unless defined($l);  #                               return unless defined($l);
291  #                               return $l unless ($rec_regex && $f_nr);  #                               return $l unless ($rec_regex && $f_nr);
292    
293                                    return unless ( defined($l) && defined($f_nr) );
294    
295                                    warn "-=> $f_nr ## |$l|\n" if ($debug);
296                                  $log->debug("-=> $f_nr ## $l");                                  $log->debug("-=> $f_nr ## $l");
297    
298                                  # codepage conversion and recode_regex                                  # codepage conversion and recode_regex
# Line 307  sub open { Line 305  sub open {
305                                          my $c = 0;                                          my $c = 0;
306                                          foreach my $r (@{ $rec_regex->{$f_nr} }) {                                          foreach my $r (@{ $rec_regex->{$f_nr} }) {
307                                                  my $old_l = $l;                                                  my $old_l = $l;
308                                                  eval '$l =~ ' . $r;                                                  $log->logconfess("expected regex in ", dump( $r )) unless defined($r->{regex});
309                                                    eval '$l =~ ' . $r->{regex};
310                                                  if ($old_l ne $l) {                                                  if ($old_l ne $l) {
311                                                          $log->debug("REGEX on $f_nr eval \$l =~ $r\n## old l: [$old_l]\n## new l: [$l]");                                                          my $d = "|$old_l| -> |$l| "; # . $r->{regex};
312                                                            $d .= ' +' . $r->{line} . ' ' . $r->{file} if defined($r->{line});
313                                                            $d .= ' ' . $r->{debug} if defined($r->{debug});
314                                                            $log->debug("MODIFY $d");
315                                                            warn "*** $d\n" if ($debug);
316    
317                                                  }                                                  }
318                                                  $log->error("error applying regex: $r") if ($@);                                                  $log->error("error applying regex: $r") if ($@);
319                                          }                                          }
320                                  }                                  }
321    
322                                  $log->debug("<=- $f_nr ## $l");                                  $log->debug("<=- $f_nr ## |$l|");
323                                    warn "<=- $f_nr ## $l\n" if ($debug);
324                                  return $l;                                  return $l;
325                  });                  });
326    
327                  $log->debug(sub { Dumper($rec) });                  $log->debug(sub { dump($rec) });
328    
329                  if (! $rec) {                  if (! $rec) {
330                          $log->warn("record $pos empty? skipping...");                          $log->warn("record $pos empty? skipping...");
# Line 327  sub open { Line 332  sub open {
332                  }                  }
333    
334                  # store                  # store
335                  if ($self->{low_mem}) {                  if ($self->{save_row}) {
336                          $self->{db}->put($pos, $rec);                          $self->{save_row}->({
337                                    id => $pos,
338                                    row => $rec,
339                            });
340                  } else {                  } else {
341                          $self->{data}->{$pos} = $rec;                          $self->{data}->{$pos} = $rec;
342                  }                  }
# Line 419  sub fetch { Line 427  sub fetch {
427    
428          my $rec;          my $rec;
429    
430          if ($self->{low_mem}) {          if ($self->{load_row}) {
431                  $rec = $self->{db}->get($mfn);                  $rec = $self->{load_row}->({ id => $mfn });
432          } else {          } else {
433                  $rec = $self->{data}->{$mfn};                  $rec = $self->{data}->{$mfn};
434          }          }
# Line 475  First record in database has position 1. Line 483  First record in database has position 1.
483    
484  sub seek {  sub seek {
485          my $self = shift;          my $self = shift;
486          my $pos = shift || return;          my $pos = shift;
487    
488          my $log = $self->_get_logger();          my $log = $self->_get_logger();
489    
490            $log->logconfess("called without pos") unless defined($pos);
491    
492          if ($pos < 1) {          if ($pos < 1) {
493                  $log->warn("seek before first record");                  $log->warn("seek before first record");
494                  $pos = 1;                  $pos = 1;
# Line 513  sub stats { Line 523  sub stats {
523    
524          my $out = join("\n",          my $out = join("\n",
525                  map {                  map {
526                          my $f = $_ || die "no field";                          my $f = $_;
527                            die "no field in ", dump( $s->{fld} ) unless defined( $f );
528                          my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";                          my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
529                          $max_fld = $v if ($v > $max_fld);                          $max_fld = $v if ($v > $max_fld);
530    
531                          my $o = sprintf("%4s %d ~", $f, $v);                          my $o = sprintf("%4s %d ~", $f, $v);
532    
533                          if (defined($s->{sf}->{$f})) {                          if (defined($s->{sf}->{$f})) {
534                                    my @subfields = keys %{ $s->{sf}->{$f} };
535                                  map {                                  map {
536                                          $o .= sprintf(" %s:%d%s", $_,                                          $o .= sprintf(" %s:%d%s", $_,
537                                                  $s->{sf}->{$f}->{$_}->{count},                                                  $s->{sf}->{$f}->{$_}->{count},
538                                                  $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',                                                  $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
539                                          );                                          );
540                                  } sort keys %{ $s->{sf}->{$f} };                                  } (
541                                            # first indicators and other special subfields
542                                            sort( grep { length($_)  > 1 } @subfields ),
543                                            # then subfileds (single char)
544                                            sort( grep { length($_) == 1 } @subfields ),
545                                    );
546                          }                          }
547    
548                          if (my $v_r = $s->{repeatable}->{$f}) {                          if (my $v_r = $s->{repeatable}->{$f}) {
# Line 533  sub stats { Line 550  sub stats {
550                          }                          }
551    
552                          $o;                          $o;
553                  } sort { $a cmp $b } keys %{ $s->{fld} }                  } sort { $a <=> $b } keys %{ $s->{fld} }
554          );          );
555    
556          $log->debug( sub { Dumper($s) } );          $log->debug( sub { dump($s) } );
557    
558          return $out;          return $out;
559  }  }
560    
561  =head2 dump  =head2 dump_ascii
562    
563  Display humanly readable dump of record  Display humanly readable dump of record
564    
565  =cut  =cut
566    
567  sub dump {  sub dump_ascii {
568          my $self = shift;          my $self = shift;
569    
570          return $self->{ll_db}->dump_rec( $self->{pos} );          return unless $self->{ll_db};
571    
572            if ($self->{ll_db}->can('dump_ascii')) {
573                    return $self->{ll_db}->dump_ascii( $self->{pos} );
574            } else {
575                    return dump( $self->{ll_db}->fetch_rec( $self->{pos} ) );
576            }
577  }  }
578    
579  =head2 modify_record_regexps  =head2 _get_regex
580    
581  Generate hash with regexpes to be applied using l<filter>.  Helper function called which create regexps to be execute on code.
582    
583    my $regexpes = $input->modify_record_regexps(    _get_regex( 900, 'regex:[0-9]+' ,'numbers' );
584                  900 => { '^a' => { ' : ' => '^b' } },    _get_regex( 900, '^b', ' : ^b' );
585                  901 => { '*' => { '^b' => ' ; ' } },  
586    );  It supports perl regexps with C<regex:> prefix to from value and has
587    additional logic to skip empty subfields.
588    
589  =cut  =cut
590    
591  sub _get_regex {  sub _get_regex {
592          my ($sf,$from,$to) = @_;          my ($sf,$from,$to) = @_;
593    
594            # protect /
595            $from =~ s!/!\\/!gs;
596            $to =~ s!/!\\/!gs;
597    
598            if ($from =~ m/^regex:(.+)$/) {
599                    $from = $1;
600            } else {
601                    $from = '\Q' . $from . '\E';
602            }
603          if ($sf =~ /^\^/) {          if ($sf =~ /^\^/) {
604                    my $need_subfield_data = '*';   # no
605                    # if from is also subfield, require some data in between
606                    # to correctly skip empty subfields
607                    $need_subfield_data = '+' if ($from =~ m/^\\Q\^/);
608                  return                  return
609                          's/\Q'. $sf .'\E([^\^]*?)\Q'. $from .'\E([^\^]*?)/'. $sf .'$1'. $to .'$2/';                          's/\Q'. $sf .'\E([^\^]' . $need_subfield_data . '?)'. $from .'([^\^]*?)/'. $sf .'$1'. $to .'$2/';
610          } else {          } else {
611                  return                  return
612                          's/\Q'. $from .'\E/'. $to .'/g';                          's/'. $from .'/'. $to .'/g';
613          }          }
614  }  }
615    
616    
617    =head2 modify_record_regexps
618    
619    Generate hash with regexpes to be applied using L<filter>.
620    
621      my $regexpes = $input->modify_record_regexps(
622                    900 => { '^a' => { ' : ' => '^b' } },
623                    901 => { '*' => { '^b' => ' ; ' } },
624      );
625    
626    =cut
627    
628  sub modify_record_regexps {  sub modify_record_regexps {
629          my $self = shift;          my $self = shift;
630          my $modify_record = {@_};          my $modify_record = {@_};
# Line 593  sub modify_record_regexps { Line 642  sub modify_record_regexps {
642                          foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {                          foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
643                                  my $to = $modify_record->{$f}->{$sf}->{$from};                                  my $to = $modify_record->{$f}->{$sf}->{$from};
644                                  #die "no field?" unless defined($to);                                  #die "no field?" unless defined($to);
645                                  $log->debug("transform: |$from| -> |$to|");                                  my $d = "|$from| -> |$to|";
646                                    $log->debug("transform: $d");
647    
648                                  my $regex = _get_regex($sf,$from,$to);                                  my $regex = _get_regex($sf,$from,$to);
649                                  push @{ $regexpes->{$f} }, $regex;                                  push @{ $regexpes->{$f} }, { regex => $regex, debug => $d };
650                                  $log->debug("regex: $regex");                                  $log->debug("regex: $regex");
651                          }                          }
652                  }                  }
# Line 607  sub modify_record_regexps { Line 657  sub modify_record_regexps {
657    
658  =head2 modify_file_regexps  =head2 modify_file_regexps
659    
660  Generate hash with regexpes to be applied using l<filter> from  Generate hash with regexpes to be applied using L<filter> from
661  pseudo hash/yaml format for regex mappings.  pseudo hash/yaml format for regex mappings.
662    
663  It should be obvious:  It should be obvious:
# Line 657  sub modify_file_regexps { Line 707  sub modify_file_regexps {
707                          $log->debug("transform: |$from| -> |$to|");                          $log->debug("transform: |$from| -> |$to|");
708    
709                          my $regex = _get_regex($sf,$from,$to);                          my $regex = _get_regex($sf,$from,$to);
710                          push @{ $regexpes->{$f} }, $regex;                          push @{ $regexpes->{$f} }, {
711                                    regex => $regex,
712                                    file => $modify_path,
713                                    line => $.,
714                            };
715                          $log->debug("regex: $regex");                          $log->debug("regex: $regex");
716                  }                  }
717          }          }
# Line 665  sub modify_file_regexps { Line 719  sub modify_file_regexps {
719          return $regexpes;          return $regexpes;
720  }  }
721    
 =head1 MEMORY USAGE  
   
 C<low_mem> options is double-edged sword. If enabled, WebPAC  
 will run on memory constraint machines (which doesn't have enough  
 physical RAM to create memory structure for whole source database).  
   
 If your machine has 512Mb or more of RAM and database is around 10000 records,  
 memory shouldn't be an issue. If you don't have enough physical RAM, you  
 might consider using virtual memory (if your operating system is handling it  
 well, like on FreeBSD or Linux) instead of dropping to L<DBM::Deep> to handle  
 parsed structure of ISIS database (this is what C<low_mem> option does).  
   
 Hitting swap at end of reading source database is probably o.k. However,  
 hitting swap before 90% will dramatically decrease performance and you will  
 be better off with C<low_mem> and using rest of availble memory for  
 operating system disk cache (Linux is particuallary good about this).  
 However, every access to database record will require disk access, so  
 generation phase will be slower 10-100 times.  
   
 Parsed structures are essential - you just have option to trade RAM memory  
 (which is fast) for disk space (which is slow). Be sure to have planty of  
 disk space if you are using C<low_mem> and thus L<DBM::Deep>.  
   
 However, when WebPAC is running on desktop machines (or laptops :-), it's  
 highly undesireable for system to start swapping. Using C<low_mem> option can  
 reduce WecPAC memory usage to around 64Mb for same database with lookup  
 fields and sorted indexes which stay in RAM. Performance will suffer, but  
 memory usage will really be minimal. It might be also more confortable to  
 run WebPAC reniced on those machines.  
   
   
722  =head1 AUTHOR  =head1 AUTHOR
723    
724  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
Legend:
Removed from v.757  
changed lines
  Added in v.910
  ViewVC Help
Powered by ViewVC 1.1.26