/[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 726 by dpavlin, Fri Sep 29 19:52:17 2006 UTC revision 800 by dpavlin, Sun Feb 4 23:10:18 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.17
20    
21  =cut  =cut
22    
23  our $VERSION = '0.13';  our $VERSION = '0.17';
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    );    );
# Line 75  Optional parametar C<encoding> specify a Line 73  Optional parametar C<encoding> specify a
73  used internally). This should probably be your terminal encoding, and by  used internally). This should probably be your terminal encoding, and by
74  default, it C<ISO-8859-2>.  default, it C<ISO-8859-2>.
75    
 Default is not to use C<low_mem> options (see L<MEMORY USAGE> below).  
   
76  C<recode> is optional string constisting of character or words pairs that  C<recode> is optional string constisting of character or words pairs that
77  should be replaced in input stream.  should be replaced in input stream.
78    
# Line 96  sub new { Line 92  sub new {
92    
93          $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});
94          $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});
95            $log->logconfess("low_mem argument is not suppored any more. rewrite it to load_row and save_row") if ($self->{low_mem});
96    
97          $log->logconfess("specify low-level file format module") unless ($self->{module});          $log->logconfess("specify low-level file format module") unless ($self->{module});
98          my $module_path = $self->{module};          my $module_path = $self->{module};
# Line 105  sub new { Line 102  sub new {
102    
103          require $module_path;          require $module_path;
104    
         # check if required subclasses are implemented  
         foreach my $subclass (qw/open_db fetch_rec init dump_rec/) {  
                 # FIXME  
         }  
   
105          $self->{'encoding'} ||= 'ISO-8859-2';          $self->{'encoding'} ||= 'ISO-8859-2';
106    
         # 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;  
         }  
   
107          $self ? return $self : return undef;          $self ? return $self : return undef;
108  }  }
109    
# Line 145  sub new { Line 111  sub new {
111    
112  This function will read whole database in memory and produce lookups.  This function will read whole database in memory and produce lookups.
113    
114     my $store;     # simple in-memory hash
115    
116   $input->open(   $input->open(
117          path => '/path/to/database/file',          path => '/path/to/database/file',
118          code_page => 'cp852',          code_page => 'cp852',
# Line 160  This function will read whole database i Line 128  This function will read whole database i
128                  901 => { '*' => { '^b' => ' ; ' } },                  901 => { '*' => { '^b' => ' ; ' } },
129          },          },
130          modify_file => 'conf/modify/mapping.map',          modify_file => 'conf/modify/mapping.map',
131            save_row => sub {
132                    my $a = shift;
133                    $store->{ $a->{id} } = $a->{row};
134            },
135            load_row => sub {
136                    my $a = shift;
137                    return defined($store->{ $a->{id} }) &&
138                            $store->{ $a->{id} };
139            },
140    
141   );   );
142    
143  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 158  C<modify_file> is alternative for C<modi
158  (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
159  overrides C<modify_records> if both exists for same input.  overrides C<modify_records> if both exists for same input.
160    
161    C<save_row> and C<load_row> are low-level implementation of store engine. Calling convention
162    is documented in example above.
163    
164  Returns size of database, regardless of C<offset> and C<limit>  Returns size of database, regardless of C<offset> and C<limit>
165  parametars, see also C<size>.  parametars, see also C<size>.
166    
# Line 206  sub open { Line 187  sub open {
187                  $self->{$v} = $arg->{$v} if ($arg->{$v});                  $self->{$v} = $arg->{$v} if ($arg->{$v});
188          }          }
189    
190            if ($arg->{load_row} || $arg->{save_row}) {
191                    $log->logconfess("save_row and load_row must be defined in pair and be CODE") unless (
192                            ref($arg->{load_row}) eq 'CODE' &&
193                            ref($arg->{save_row}) eq 'CODE'
194                    );
195                    $self->{load_row} = $arg->{load_row};
196                    $self->{save_row} = $arg->{save_row};
197                    $log->debug("using load_row and save_row instead of in-memory hash");
198            }
199    
200          my $filter_ref;          my $filter_ref;
201          my $recode_regex;          my $recode_regex;
202          my $recode_map;          my $recode_map;
# Line 233  sub open { Line 224  sub open {
224                  $log->debug("using modify_file $p");                  $log->debug("using modify_file $p");
225                  $rec_regex = $self->modify_file_regexps( $p );                  $rec_regex = $self->modify_file_regexps( $p );
226          } elsif (my $h = $arg->{modify_records}) {          } elsif (my $h = $arg->{modify_records}) {
227                  $log->debug("using modify_records ", Dumper( $h ));                  $log->debug("using modify_records ", sub { dump( $h ) });
228                  $rec_regex = $self->modify_record_regexps(%{ $h });                  $rec_regex = $self->modify_record_regexps(%{ $h });
229          }          }
230          $log->debug("rec_regex: ", Dumper($rec_regex)) if ($rec_regex);          $log->debug("rec_regex: ", sub { dump($rec_regex) }) if ($rec_regex);
231    
232          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!");
233    
# Line 291  sub open { Line 282  sub open {
282                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
283    
284                  my $rec = $ll_db->fetch_rec($pos, sub {                  my $rec = $ll_db->fetch_rec($pos, sub {
285                                  my ($l,$f_nr) = @_;                                  my ($l,$f_nr,$debug) = @_;
286  #                               return unless defined($l);  #                               return unless defined($l);
287  #                               return $l unless ($rec_regex && $f_nr);  #                               return $l unless ($rec_regex && $f_nr);
288    
289                                    warn "-=> $f_nr ## |$l|\n" if ($debug);
290                                  $log->debug("-=> $f_nr ## $l");                                  $log->debug("-=> $f_nr ## $l");
291    
292                                  # codepage conversion and recode_regex                                  # codepage conversion and recode_regex
# Line 307  sub open { Line 299  sub open {
299                                          my $c = 0;                                          my $c = 0;
300                                          foreach my $r (@{ $rec_regex->{$f_nr} }) {                                          foreach my $r (@{ $rec_regex->{$f_nr} }) {
301                                                  my $old_l = $l;                                                  my $old_l = $l;
302                                                  eval '$l =~ ' . $r;                                                  $log->logconfess("expected regex in ", dump( $r )) unless defined($r->{regex});
303                                                    eval '$l =~ ' . $r->{regex};
304                                                  if ($old_l ne $l) {                                                  if ($old_l ne $l) {
305                                                          $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};
306                                                            $d .= ' +' . $r->{line} . ' ' . $r->{file} if defined($r->{line});
307                                                            $d .= ' ' . $r->{debug} if defined($r->{debug});
308                                                            $log->debug("MODIFY $d");
309                                                            warn "*** $d\n" if ($debug);
310    
311                                                  }                                                  }
312                                                  $log->error("error applying regex: $r") if ($@);                                                  $log->error("error applying regex: $r") if ($@);
313                                          }                                          }
314                                  }                                  }
315    
316                                  $log->debug("<=- $f_nr ## $l");                                  $log->debug("<=- $f_nr ## |$l|");
317                                    warn "<=- $f_nr ## $l\n" if ($debug);
318                                  return $l;                                  return $l;
319                  });                  });
320    
321                  $log->debug(sub { Dumper($rec) });                  $log->debug(sub { dump($rec) });
322    
323                  if (! $rec) {                  if (! $rec) {
324                          $log->warn("record $pos empty? skipping...");                          $log->warn("record $pos empty? skipping...");
# Line 327  sub open { Line 326  sub open {
326                  }                  }
327    
328                  # store                  # store
329                  if ($self->{low_mem}) {                  if ($self->{save_row}) {
330                          $self->{db}->put($pos, $rec);                          $self->{save_row}->({
331                                    id => $pos,
332                                    row => $rec,
333                            });
334                  } else {                  } else {
335                          $self->{data}->{$pos} = $rec;                          $self->{data}->{$pos} = $rec;
336                  }                  }
# Line 377  sub open { Line 379  sub open {
379          $self->{max_pos} = $to_rec;          $self->{max_pos} = $to_rec;
380          $log->debug("max_pos: $to_rec");          $log->debug("max_pos: $to_rec");
381    
382            # save for dump
383            $self->{ll_db} = $ll_db;
384    
385          return $size;          return $size;
386  }  }
387    
# Line 416  sub fetch { Line 421  sub fetch {
421    
422          my $rec;          my $rec;
423    
424          if ($self->{low_mem}) {          if ($self->{load_row}) {
425                  $rec = $self->{db}->get($mfn);                  $rec = $self->{load_row}->({ id => $mfn });
426          } else {          } else {
427                  $rec = $self->{data}->{$mfn};                  $rec = $self->{data}->{$mfn};
428          }          }
# Line 472  First record in database has position 1. Line 477  First record in database has position 1.
477    
478  sub seek {  sub seek {
479          my $self = shift;          my $self = shift;
480          my $pos = shift || return;          my $pos = shift;
481    
482          my $log = $self->_get_logger();          my $log = $self->_get_logger();
483    
484            $log->logconfess("called without pos") unless defined($pos);
485    
486          if ($pos < 1) {          if ($pos < 1) {
487                  $log->warn("seek before first record");                  $log->warn("seek before first record");
488                  $pos = 1;                  $pos = 1;
# Line 533  sub stats { Line 540  sub stats {
540                  } sort { $a cmp $b } keys %{ $s->{fld} }                  } sort { $a cmp $b } keys %{ $s->{fld} }
541          );          );
542    
543          $log->debug( sub { Dumper($s) } );          $log->debug( sub { dump($s) } );
544    
545          return $out;          return $out;
546  }  }
547    
548  =head2 dump  =head2 dump_ascii
549    
550  Display humanly readable dump of record  Display humanly readable dump of record
551    
552  =cut  =cut
553    
554  sub dump {  sub dump_ascii {
555          my $self = shift;          my $self = shift;
556    
557          return $self->{dump_rec}->($self, $self->{pos});          return unless $self->{ll_db};
558    
559            if ($self->{ll_db}->can('dump_rec')) {
560                    return $self->{ll_db}->dump_ascii( $self->{pos} );
561            } else {
562                    return dump( $self->{ll_db}->fetch_rec( $self->{pos} ) );
563            }
564  }  }
565    
566  =head2 modify_record_regexps  =head2 modify_record_regexps
567    
568  Generate hash with regexpes to be applied using l<filter>.  Generate hash with regexpes to be applied using L<filter>.
569    
570    my $regexpes = $input->modify_record_regexps(    my $regexpes = $input->modify_record_regexps(
571                  900 => { '^a' => { ' : ' => '^b' } },                  900 => { '^a' => { ' : ' => '^b' } },
# Line 564  Generate hash with regexpes to be applie Line 576  Generate hash with regexpes to be applie
576    
577  sub _get_regex {  sub _get_regex {
578          my ($sf,$from,$to) = @_;          my ($sf,$from,$to) = @_;
579    
580            # protect /
581            $from =~ s!/!\\/!gs;
582            $to =~ s!/!\\/!gs;
583    
584            if ($from =~ m/^regex:(.+)$/) {
585                    $from = $1;
586            } else {
587                    $from = '\Q' . $from . '\E';
588            }
589          if ($sf =~ /^\^/) {          if ($sf =~ /^\^/) {
590                  return                  return
591                          's/\Q'. $sf .'\E([^\^]*?)\Q'. $from .'\E([^\^]*?)/'. $sf .'$1'. $to .'$2/';                          's/\Q'. $sf .'\E([^\^]*?)'. $from .'([^\^]*?)/'. $sf .'$1'. $to .'$2/';
592          } else {          } else {
593                  return                  return
594                          's/\Q'. $from .'\E/'. $to .'/g';                          's/'. $from .'/'. $to .'/g';
595          }          }
596  }  }
597    
# Line 590  sub modify_record_regexps { Line 612  sub modify_record_regexps {
612                          foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {                          foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
613                                  my $to = $modify_record->{$f}->{$sf}->{$from};                                  my $to = $modify_record->{$f}->{$sf}->{$from};
614                                  #die "no field?" unless defined($to);                                  #die "no field?" unless defined($to);
615                                  $log->debug("transform: |$from| -> |$to|");                                  my $d = "|$from| -> |$to|";
616                                    $log->debug("transform: $d");
617    
618                                  my $regex = _get_regex($sf,$from,$to);                                  my $regex = _get_regex($sf,$from,$to);
619                                  push @{ $regexpes->{$f} }, $regex;                                  push @{ $regexpes->{$f} }, { regex => $regex, debug => $d };
620                                  $log->debug("regex: $regex");                                  $log->debug("regex: $regex");
621                          }                          }
622                  }                  }
# Line 604  sub modify_record_regexps { Line 627  sub modify_record_regexps {
627    
628  =head2 modify_file_regexps  =head2 modify_file_regexps
629    
630  Generate hash with regexpes to be applied using l<filter> from  Generate hash with regexpes to be applied using L<filter> from
631  pseudo hash/yaml format for regex mappings.  pseudo hash/yaml format for regex mappings.
632    
633  It should be obvious:  It should be obvious:
# Line 654  sub modify_file_regexps { Line 677  sub modify_file_regexps {
677                          $log->debug("transform: |$from| -> |$to|");                          $log->debug("transform: |$from| -> |$to|");
678    
679                          my $regex = _get_regex($sf,$from,$to);                          my $regex = _get_regex($sf,$from,$to);
680                          push @{ $regexpes->{$f} }, $regex;                          push @{ $regexpes->{$f} }, {
681                                    regex => $regex,
682                                    file => $modify_path,
683                                    line => $.,
684                            };
685                          $log->debug("regex: $regex");                          $log->debug("regex: $regex");
686                  }                  }
687          }          }
# Line 662  sub modify_file_regexps { Line 689  sub modify_file_regexps {
689          return $regexpes;          return $regexpes;
690  }  }
691    
 =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.  
   
   
692  =head1 AUTHOR  =head1 AUTHOR
693    
694  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
Legend:
Removed from v.726  
changed lines
  Added in v.800
  ViewVC Help
Powered by ViewVC 1.1.26