/[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 634 by dpavlin, Wed Sep 6 18:08:30 2006 UTC revision 774 by dpavlin, Fri Nov 3 20:56:21 2006 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.11  Version 0.16
20    
21  =cut  =cut
22    
23  our $VERSION = '0.11';  our $VERSION = '0.16';
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 = $self->{module};          my $module_path = $self->{module};
99          $module =~ s#::#/#g;          $module_path =~ s#::#/#g;
100          $module .= '.pm';          $module_path .= '.pm';
101          $log->debug("require low-level module $self->{module} from $module");          $log->debug("require low-level module $self->{module} from $module_path");
   
         require $module;  
         #eval $self->{module} .'->import';  
   
         # check if required subclasses are implemented  
         foreach my $subclass (qw/open_db fetch_rec init/) {  
                 my $n = $self->{module} . '::' . $subclass;  
                 if (! defined &{ $n }) {  
                         my $missing = "missing $subclass in $self->{module}";  
                         $self->{$subclass} = sub { $log->logwarn($missing) };  
                 } else {  
                         $self->{$subclass} = \&{ $n };  
                 }  
         }  
102    
103          if ($self->{init}) {          require $module_path;
                 $log->debug("calling init");  
                 $self->{init}->($self, @_);  
         }  
104    
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 157  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',
119          limit => 500,          limit => 500,
120          offset => 6000,          offset => 6000,
         lookup => $lookup_obj,  
121          stats => 1,          stats => 1,
122          lookup_ref => sub {          lookup_coderef => sub {
123                  my ($k,$v) = @_;                  my $rec = shift;
124                  # store lookup $k => $v                  # store lookups
125          },          },
126          modify_records => {          modify_records => {
127                  900 => { '^a' => { ' : ' => '^b' } },                  900 => { '^a' => { ' : ' => '^b' } },
128                  901 => { '*' => { '^b' => ' ; ' } },                  901 => { '*' => { '^b' => ' ; ' } },
129          },          },
130            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 182  C<limit> is optional parametar to read j Line 148  C<limit> is optional parametar to read j
148    
149  C<stats> create optional report about usage of fields and subfields  C<stats> create optional report about usage of fields and subfields
150    
151  C<lookup_coderef> is closure to call when adding C<< key => 'value' >> combinations to  C<lookup_coderef> is closure to called to save data into lookups
 lookup.  
152    
153  C<modify_records> specify mapping from subfields to delimiters or from  C<modify_records> specify mapping from subfields to delimiters or from
154  delimiters to subfields, as well as oprations on fields (if subfield is  delimiters to subfields, as well as oprations on fields (if subfield is
155  defined as C<*>.  defined as C<*>.
156    
157    C<modify_file> is alternative for C<modify_records> above which preserves order and offers
158    (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.
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 204  sub open { Line 176  sub open {
176          $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))          $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
177                  if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');                  if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
178    
179            $log->debug( $arg->{lookup_coderef} ? '' : 'not ', "using lookup_coderef");
180    
181          $log->logcroak("need path") if (! $arg->{'path'});          $log->logcroak("need path") if (! $arg->{'path'});
182          my $code_page = $arg->{'code_page'} || 'cp852';          my $code_page = $arg->{'code_page'} || 'cp852';
183    
# Line 213  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 235  sub open { Line 219  sub open {
219    
220          }          }
221    
222          my $rec_regex = $self->modify_record_regexps(%{ $arg->{modify_records} });          my $rec_regex;
223          $log->debug("rec_regex: ", Dumper($rec_regex));          if (my $p = $arg->{modify_file}) {
224                    $log->debug("using modify_file $p");
225                    $rec_regex = $self->modify_file_regexps( $p );
226            } elsif (my $h = $arg->{modify_records}) {
227                    $log->debug("using modify_records ", sub { dump( $h ) });
228                    $rec_regex = $self->modify_record_regexps(%{ $h });
229            }
230            $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!");
233    
234          my ($db, $size) = $self->{open_db}->( $self,          my $ll_db = $class->new(
235                  path => $arg->{path},                  path => $arg->{path},
236  #               filter => sub {  #               filter => sub {
237  #                       my ($l,$f_nr) = @_;  #                       my ($l,$f_nr) = @_;
# Line 250  sub open { Line 243  sub open {
243                  %{ $arg },                  %{ $arg },
244          );          );
245    
246          unless (defined($db)) {          unless (defined($ll_db)) {
247                  $log->logwarn("can't open database $arg->{path}, skipping...");                  $log->logwarn("can't open database $arg->{path}, skipping...");
248                  return;                  return;
249          }          }
250    
251            my $size = $ll_db->size;
252    
253          unless ($size) {          unless ($size) {
254                  $log->logwarn("no records in database $arg->{path}, skipping...");                  $log->logwarn("no records in database $arg->{path}, skipping...");
255                  return;                  return;
# Line 286  sub open { Line 281  sub open {
281    
282                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
283    
284                  my $rec = $self->{fetch_rec}->($self, $db, $pos, sub {                  my $rec = $ll_db->fetch_rec($pos, sub {
285                                  my ($l,$f_nr) = @_;                                  my ($l,$f_nr) = @_;
286  #                               return unless defined($l);  #                               return unless defined($l);
287  #                               return $l unless ($rec_regex && $f_nr);  #                               return $l unless ($rec_regex && $f_nr);
# Line 315  sub open { Line 310  sub open {
310                                  return $l;                                  return $l;
311                  });                  });
312    
313                  $log->debug(sub { Dumper($rec) });                  $log->debug(sub { dump($rec) });
314    
315                  if (! $rec) {                  if (! $rec) {
316                          $log->warn("record $pos empty? skipping...");                          $log->warn("record $pos empty? skipping...");
# Line 323  sub open { Line 318  sub open {
318                  }                  }
319    
320                  # store                  # store
321                  if ($self->{low_mem}) {                  if ($self->{save_row}) {
322                          $self->{db}->put($pos, $rec);                          $self->{save_row}->({
323                                    id => $pos,
324                                    row => $rec,
325                            });
326                  } else {                  } else {
327                          $self->{data}->{$pos} = $rec;                          $self->{data}->{$pos} = $rec;
328                  }                  }
# Line 336  sub open { Line 334  sub open {
334                  if ($self->{stats}) {                  if ($self->{stats}) {
335    
336                          # fetch clean record with regexpes applied for statistics                          # fetch clean record with regexpes applied for statistics
337                          my $rec = $self->{fetch_rec}->($self, $db, $pos);                          my $rec = $ll_db->fetch_rec($pos);
338    
339                          foreach my $fld (keys %{ $rec }) {                          foreach my $fld (keys %{ $rec }) {
340                                  $self->{_stats}->{fld}->{ $fld }++;                                  $self->{_stats}->{fld}->{ $fld }++;
# Line 373  sub open { Line 371  sub open {
371          $self->{max_pos} = $to_rec;          $self->{max_pos} = $to_rec;
372          $log->debug("max_pos: $to_rec");          $log->debug("max_pos: $to_rec");
373    
374            # save for dump
375            $self->{ll_db} = $ll_db;
376    
377          return $size;          return $size;
378  }  }
379    
# Line 412  sub fetch { Line 413  sub fetch {
413    
414          my $rec;          my $rec;
415    
416          if ($self->{low_mem}) {          if ($self->{load_row}) {
417                  $rec = $self->{db}->get($mfn);                  $rec = $self->{load_row}->({ id => $mfn });
418          } else {          } else {
419                  $rec = $self->{data}->{$mfn};                  $rec = $self->{data}->{$mfn};
420          }          }
# Line 529  sub stats { Line 530  sub stats {
530                  } sort { $a cmp $b } keys %{ $s->{fld} }                  } sort { $a cmp $b } keys %{ $s->{fld} }
531          );          );
532    
533          $log->debug( sub { Dumper($s) } );          $log->debug( sub { dump($s) } );
534    
535          return $out;          return $out;
536  }  }
537    
538    =head2 dump_ascii
539    
540    Display humanly readable dump of record
541    
542    =cut
543    
544    sub dump_ascii {
545            my $self = shift;
546    
547            return unless $self->{ll_db};
548    
549            if ($self->{ll_db}->can('dump_rec')) {
550                    return $self->{ll_db}->dump_ascii( $self->{pos} );
551            } else {
552                    return dump( $self->{ll_db}->fetch_rec( $self->{pos} ) );
553            }
554    }
555    
556  =head2 modify_record_regexps  =head2 modify_record_regexps
557    
558  Generate hash with regexpes to be applied using L<filter>.  Generate hash with regexpes to be applied using l<filter>.
559    
560    my $regexpes = $input->modify_record_regexps(    my $regexpes = $input->modify_record_regexps(
561                  900 => { '^a' => { ' : ' => '^b' } },                  900 => { '^a' => { ' : ' => '^b' } },
# Line 545  Generate hash with regexpes to be applie Line 564  Generate hash with regexpes to be applie
564    
565  =cut  =cut
566    
567    sub _get_regex {
568            my ($sf,$from,$to) = @_;
569            if ($sf =~ /^\^/) {
570                    return
571                            's/\Q'. $sf .'\E([^\^]*?)\Q'. $from .'\E([^\^]*?)/'. $sf .'$1'. $to .'$2/';
572            } else {
573                    return
574                            's/\Q'. $from .'\E/'. $to .'/g';
575            }
576    }
577    
578  sub modify_record_regexps {  sub modify_record_regexps {
579          my $self = shift;          my $self = shift;
580          my $modify_record = {@_};          my $modify_record = {@_};
# Line 564  sub modify_record_regexps { Line 594  sub modify_record_regexps {
594                                  #die "no field?" unless defined($to);                                  #die "no field?" unless defined($to);
595                                  $log->debug("transform: |$from| -> |$to|");                                  $log->debug("transform: |$from| -> |$to|");
596    
597                                  if ($sf =~ /^\^/) {                                  my $regex = _get_regex($sf,$from,$to);
598                                          my $regex =                                  push @{ $regexpes->{$f} }, $regex;
599                                                  's/\Q'. $sf .'\E(.*?)\Q'. $from .'\E(.*?)/'. $sf .'$1'. $to .'$2/g';                                  $log->debug("regex: $regex");
                                         push @{ $regexpes->{$f} }, $regex;  
                                         $log->debug(">>>>> $regex [sf]");  
                                 } else {  
                                         my $regex =  
                                                 's/\Q'. $from .'\E/'. $to .'/g';  
                                         push @{ $regexpes->{$f} }, $regex;  
                                         $log->debug(">>>>> $regex [global]");  
                                 }  
   
600                          }                          }
601                  }                  }
602          }          }
# Line 583  sub modify_record_regexps { Line 604  sub modify_record_regexps {
604          return $regexpes;          return $regexpes;
605  }  }
606    
607  =head1 MEMORY USAGE  =head2 modify_file_regexps
608    
609  C<low_mem> options is double-edged sword. If enabled, WebPAC  Generate hash with regexpes to be applied using l<filter> from
610  will run on memory constraint machines (which doesn't have enough  pseudo hash/yaml format for regex mappings.
611  physical RAM to create memory structure for whole source database).  
612    It should be obvious:
613  If your machine has 512Mb or more of RAM and database is around 10000 records,  
614  memory shouldn't be an issue. If you don't have enough physical RAM, you          200
615  might consider using virtual memory (if your operating system is handling it            '^a'
616  well, like on FreeBSD or Linux) instead of dropping to L<DBM::Deep> to handle              ' : ' => '^e'
617  parsed structure of ISIS database (this is what C<low_mem> option does).              ' = ' => '^d'
618    
619  Hitting swap at end of reading source database is probably o.k. However,  In field I<200> find C<'^a'> and then C<' : '>, and replace it with C<'^e'>.
620  hitting swap before 90% will dramatically decrease performance and you will  In field I<200> find C<'^a'> and then C<' = '>, and replace it with C<'^d'>.
621  be better off with C<low_mem> and using rest of availble memory for  
622  operating system disk cache (Linux is particuallary good about this).    my $regexpes = $input->modify_file_regexps( 'conf/modify/common.pl' );
623  However, every access to database record will require disk access, so  
624  generation phase will be slower 10-100 times.  On undef path it will just return.
625    
626  Parsed structures are essential - you just have option to trade RAM memory  =cut
627  (which is fast) for disk space (which is slow). Be sure to have planty of  
628  disk space if you are using C<low_mem> and thus L<DBM::Deep>.  sub modify_file_regexps {
629            my $self = shift;
 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.  
630    
631            my $modify_path = shift || return;
632    
633            my $log = $self->_get_logger();
634    
635            my $regexpes;
636    
637            CORE::open(my $fh, $modify_path) || $log->logdie("can't open modify file $modify_path: $!");
638    
639            my ($f,$sf);
640    
641            while(<$fh>) {
642                    chomp;
643                    next if (/^#/ || /^\s*$/);
644    
645                    if (/^\s*(\d+)\s*$/) {
646                            $f = $1;
647                            $log->debug("field: $f");
648                            next;
649                    } elsif (/^\s*'([^']*)'\s*$/) {
650                            $sf = $1;
651                            $log->die("can't define subfiled before field in: $_") unless ($f);
652                            $log->debug("subfield: $sf");
653                    } elsif (/^\s*'([^']*)'\s*=>\s*'([^']*)'\s*$/) {
654                            my ($from,$to) = ($1, $2);
655    
656                            $log->debug("transform: |$from| -> |$to|");
657    
658                            my $regex = _get_regex($sf,$from,$to);
659                            push @{ $regexpes->{$f} }, $regex;
660                            $log->debug("regex: $regex");
661                    }
662            }
663    
664            return $regexpes;
665    }
666    
667  =head1 AUTHOR  =head1 AUTHOR
668    
Legend:
Removed from v.634  
changed lines
  Added in v.774
  ViewVC Help
Powered by ViewVC 1.1.26