/[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 598 by dpavlin, Thu Jul 13 13:55:15 2006 UTC revision 760 by dpavlin, Wed Oct 25 15:56:44 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/;
 use Text::Iconv;  
10  use Data::Dumper;  use Data::Dumper;
11    use Encode qw/from_to/;
12    
13  =head1 NAME  =head1 NAME
14    
# 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.08  Version 0.13
20    
21  =cut  =cut
22    
23  our $VERSION = '0.08';  our $VERSION = '0.13';
24    
25  =head1 SYNOPSIS  =head1 SYNOPSIS
26    
# Line 98  sub new { Line 98  sub new {
98          $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});
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 = $self->{module};          my $module_path = $self->{module};
102          $module =~ s#::#/#g;          $module_path =~ s#::#/#g;
103          $module .= '.pm';          $module_path .= '.pm';
104          $log->debug("require low-level module $self->{module} from $module");          $log->debug("require low-level module $self->{module} from $module_path");
105    
106          require $module;          require $module_path;
         #eval $self->{module} .'->import';  
107    
108          # check if required subclasses are implemented          # check if required subclasses are implemented
109          foreach my $subclass (qw/open_db fetch_rec init/) {          foreach my $subclass (qw/open_db fetch_rec init dump_rec/) {
110                  my $n = $self->{module} . '::' . $subclass;                  # FIXME
                 if (! defined &{ $n }) {  
                         my $missing = "missing $subclass in $self->{module}";  
                         $self->{$subclass} = sub { $log->logwarn($missing) };  
                 } else {  
                         $self->{$subclass} = \&{ $n };  
                 }  
         }  
   
         if ($self->{init}) {  
                 $log->debug("calling init");  
                 $self->{init}->($self, @_);  
111          }          }
112    
113          $self->{'encoding'} ||= 'ISO-8859-2';          $self->{'encoding'} ||= 'ISO-8859-2';
114    
         # 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;  
         }  
   
115          $self ? return $self : return undef;          $self ? return $self : return undef;
116  }  }
117    
# Line 159  This function will read whole database i Line 121  This function will read whole database i
121    
122   $input->open(   $input->open(
123          path => '/path/to/database/file',          path => '/path/to/database/file',
124          code_page => '852',          code_page => 'cp852',
125          limit => 500,          limit => 500,
126          offset => 6000,          offset => 6000,
         lookup => $lookup_obj,  
127          stats => 1,          stats => 1,
128          lookup_ref => sub {          lookup_coderef => sub {
129                  my ($k,$v) = @_;                  my $rec = shift;
130                  # store lookup $k => $v                  # store lookups
131          },          },
132          modify_records => {          modify_records => {
133                  900 => { '^a' => { ' : ' => '^b' } },                  900 => { '^a' => { ' : ' => '^b' } },
134                  901 => { '*' => { '^b' => ' ; ' } },                  901 => { '*' => { '^b' => ' ; ' } },
135          },          },
136            modify_file => 'conf/modify/mapping.map',
137   );   );
138    
139  By default, C<code_page> is assumed to be C<852>.  By default, C<code_page> is assumed to be C<cp852>.
140    
141  C<offset> is optional parametar to position at some offset before reading from database.  C<offset> is optional parametar to position at some offset before reading from database.
142    
# Line 182  C<limit> is optional parametar to read j Line 144  C<limit> is optional parametar to read j
144    
145  C<stats> create optional report about usage of fields and subfields  C<stats> create optional report about usage of fields and subfields
146    
147  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.  
148    
149  C<modify_records> specify mapping from subfields to delimiters or from  C<modify_records> specify mapping from subfields to delimiters or from
150  delimiters to subfields, as well as oprations on fields (if subfield is  delimiters to subfields, as well as oprations on fields (if subfield is
151  defined as C<*>.  defined as C<*>.
152    
153    C<modify_file> is alternative for C<modify_records> above which preserves order and offers
154    (hopefully) simplier sintax than YAML or perl (see L</modify_file_regex>). This option
155    overrides C<modify_records> if both exists for same input.
156    
157  Returns size of database, regardless of C<offset> and C<limit>  Returns size of database, regardless of C<offset> and C<limit>
158  parametars, see also C<size>.  parametars, see also C<size>.
159    
# Line 204  sub open { Line 169  sub open {
169          $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))          $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
170                  if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');                  if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
171    
172            $log->debug( $arg->{lookup_coderef} ? '' : 'not ', "using lookup_coderef");
173    
174          $log->logcroak("need path") if (! $arg->{'path'});          $log->logcroak("need path") if (! $arg->{'path'});
175          my $code_page = $arg->{'code_page'} || '852';          my $code_page = $arg->{'code_page'} || 'cp852';
176    
177          # store data in object          # store data in object
178          $self->{'input_code_page'} = $code_page;          $self->{'input_code_page'} = $code_page;
# Line 213  sub open { Line 180  sub open {
180                  $self->{$v} = $arg->{$v} if ($arg->{$v});                  $self->{$v} = $arg->{$v} if ($arg->{$v});
181          }          }
182    
         # create Text::Iconv object  
         $self->{iconv} = Text::Iconv->new($code_page,$self->{'encoding'});      ## FIXME remove!  
   
183          my $filter_ref;          my $filter_ref;
184          my $recode_regex;          my $recode_regex;
185          my $recode_map;          my $recode_map;
# Line 238  sub open { Line 202  sub open {
202    
203          }          }
204    
205          my $rec_regex = $self->modify_record_regexps(%{ $arg->{modify_records} });          my $rec_regex;
206          $log->debug("rec_regex: ", Dumper($rec_regex));          if (my $p = $arg->{modify_file}) {
207                    $log->debug("using modify_file $p");
208          my ($db, $size) = $self->{open_db}->( $self,                  $rec_regex = $self->modify_file_regexps( $p );
209                  path => $arg->{path},          } elsif (my $h = $arg->{modify_records}) {
210                  filter => sub {                  $log->debug("using modify_records ", Dumper( $h ));
211                                  my ($l,$f_nr) = @_;                  $rec_regex = $self->modify_record_regexps(%{ $h });
212                                  return unless defined($l);          }
213            $log->debug("rec_regex: ", Dumper($rec_regex)) if ($rec_regex);
                                 ## FIXME remove iconv!  
                                 $l = $self->{iconv}->convert($l) if ($self->{iconv});  
           
                                 $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);  
   
                                 return $l unless ($rec_regex);  
214    
215                                  # apply regexps          my $class = $self->{module} || $log->logconfess("can't get low-level module name!");
                                 if ($rec_regex && defined($rec_regex->{$f_nr})) {  
                                         $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');  
                                         my $c = 0;  
                                         foreach my $r (@{ $rec_regex->{$f_nr} }) {  
                                                 while ( eval '$l =~ ' . $r ) { $c++ };  
                                         }  
                                         warn "## field $f_nr triggered $c regexpes\n" if ($c && $self->{debug});  
                                 }  
216    
217                                  return $l;          my $ll_db = $class->new(
218                  },                  path => $arg->{path},
219    #               filter => sub {
220    #                       my ($l,$f_nr) = @_;
221    #                       return unless defined($l);
222    #                       from_to($l, $code_page, $self->{'encoding'});
223    #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
224    #                       return $l;
225    #               },
226                  %{ $arg },                  %{ $arg },
227          );          );
228    
229          unless (defined($db)) {          unless (defined($ll_db)) {
230                  $log->logwarn("can't open database $arg->{path}, skipping...");                  $log->logwarn("can't open database $arg->{path}, skipping...");
231                  return;                  return;
232          }          }
233    
234            my $size = $ll_db->size;
235    
236          unless ($size) {          unless ($size) {
237                  $log->logwarn("no records in database $arg->{path}, skipping...");                  $log->logwarn("no records in database $arg->{path}, skipping...");
238                  return;                  return;
# Line 300  sub open { Line 259  sub open {
259    
260          $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{encoding}", $self->{stats} ? ' [stats]' : '');          $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{encoding}", $self->{stats} ? ' [stats]' : '');
261    
262            # turn on low_mem for databases with more than 100000 records!
263            if (! $self->{low_mem} && $size > 100000) {
264                    $log->warn("Using on-disk storage instead of memory for input data. This will affect performance.");
265                    $self->{low_mem}++;
266            }
267    
268            # running with low_mem flag? well, use DBM::Deep then.
269            if ($self->{'low_mem'}) {
270                    $log->info("running with low_mem which impacts performance (<32 Mb memory usage)");
271    
272                    my $db_file = "data.db";
273    
274                    if (-e $db_file) {
275                            unlink $db_file or $log->logdie("can't remove '$db_file' from last run");
276                            $log->debug("removed '$db_file' from last run");
277                    }
278    
279                    require DBM::Deep;
280    
281                    my $db = new DBM::Deep $db_file;
282    
283                    $log->logdie("DBM::Deep error: $!") unless ($db);
284    
285                    if ($db->error()) {
286                            $log->logdie("can't open '$db_file' under low_mem: ",$db->error());
287                    } else {
288                            $log->debug("using file '$db_file' for DBM::Deep");
289                    }
290    
291                    $self->{'db'} = $db;
292            }
293    
294          # read database          # read database
295          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
296    
297                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
298    
299                  my $rec = $self->{fetch_rec}->($self, $db, $pos );                  my $rec = $ll_db->fetch_rec($pos, sub {
300                                    my ($l,$f_nr) = @_;
301    #                               return unless defined($l);
302    #                               return $l unless ($rec_regex && $f_nr);
303    
304                                    $log->debug("-=> $f_nr ## $l");
305    
306                                    # codepage conversion and recode_regex
307                                    from_to($l, $code_page, $self->{'encoding'});
308                                    $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
309    
310                                    # apply regexps
311                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
312                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
313                                            my $c = 0;
314                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
315                                                    my $old_l = $l;
316                                                    eval '$l =~ ' . $r;
317                                                    if ($old_l ne $l) {
318                                                            $log->debug("REGEX on $f_nr eval \$l =~ $r\n## old l: [$old_l]\n## new l: [$l]");
319                                                    }
320                                                    $log->error("error applying regex: $r") if ($@);
321                                            }
322                                    }
323    
324                                    $log->debug("<=- $f_nr ## $l");
325                                    return $l;
326                    });
327    
328                  $log->debug(sub { Dumper($rec) });                  $log->debug(sub { Dumper($rec) });
329    
# Line 327  sub open { Line 345  sub open {
345                  # update counters for statistics                  # update counters for statistics
346                  if ($self->{stats}) {                  if ($self->{stats}) {
347    
348                            # fetch clean record with regexpes applied for statistics
349                            my $rec = $ll_db->fetch_rec($pos);
350    
351                          foreach my $fld (keys %{ $rec }) {                          foreach my $fld (keys %{ $rec }) {
352                                  $self->{_stats}->{fld}->{ $fld }++;                                  $self->{_stats}->{fld}->{ $fld }++;
353    
# Line 338  sub open { Line 359  sub open {
359                                          if (ref($row) eq 'HASH') {                                          if (ref($row) eq 'HASH') {
360    
361                                                  foreach my $sf (keys %{ $row }) {                                                  foreach my $sf (keys %{ $row }) {
362                                                            next if ($sf eq 'subfields');
363                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
364                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
365                                                                          if (ref($row->{$sf}) eq 'ARRAY');                                                                          if (ref($row->{$sf}) eq 'ARRAY');
# Line 361  sub open { Line 383  sub open {
383          $self->{max_pos} = $to_rec;          $self->{max_pos} = $to_rec;
384          $log->debug("max_pos: $to_rec");          $log->debug("max_pos: $to_rec");
385    
386            # save for dump
387            $self->{ll_db} = $ll_db;
388    
389          return $size;          return $size;
390  }  }
391    
# Line 522  sub stats { Line 547  sub stats {
547          return $out;          return $out;
548  }  }
549    
550    =head2 dump
551    
552    Display humanly readable dump of record
553    
554    =cut
555    
556    sub dump {
557            my $self = shift;
558    
559            return $self->{ll_db}->dump_rec( $self->{pos} );
560    
561    }
562    
563  =head2 modify_record_regexps  =head2 modify_record_regexps
564    
565  Generate hash with regexpes to be applied using L<filter>.  Generate hash with regexpes to be applied using l<filter>.
566    
567    my $regexpes = $input->modify_record_regexps(    my $regexpes = $input->modify_record_regexps(
568                  900 => { '^a' => { ' : ' => '^b' } },                  900 => { '^a' => { ' : ' => '^b' } },
# Line 533  Generate hash with regexpes to be applie Line 571  Generate hash with regexpes to be applie
571    
572  =cut  =cut
573    
574    sub _get_regex {
575            my ($sf,$from,$to) = @_;
576            if ($sf =~ /^\^/) {
577                    return
578                            's/\Q'. $sf .'\E([^\^]*?)\Q'. $from .'\E([^\^]*?)/'. $sf .'$1'. $to .'$2/';
579            } else {
580                    return
581                            's/\Q'. $from .'\E/'. $to .'/g';
582            }
583    }
584    
585  sub modify_record_regexps {  sub modify_record_regexps {
586          my $self = shift;          my $self = shift;
587          my $modify_record = {@_};          my $modify_record = {@_};
588    
589          my $regexpes;          my $regexpes;
590    
591            my $log = $self->_get_logger();
592    
593          foreach my $f (keys %$modify_record) {          foreach my $f (keys %$modify_record) {
594  warn "--- f: $f\n";                  $log->debug("field: $f");
595    
596                  foreach my $sf (keys %{ $modify_record->{$f} }) {                  foreach my $sf (keys %{ $modify_record->{$f} }) {
597  warn "---- sf: $sf\n";                          $log->debug("subfield: $sf");
598    
599                          foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {                          foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
600                                  my $to = $modify_record->{$f}->{$sf}->{$from};                                  my $to = $modify_record->{$f}->{$sf}->{$from};
601                                  #die "no field?" unless defined($to);                                  #die "no field?" unless defined($to);
602  warn "----- transform: |$from| -> |$to|\n";                                  $log->debug("transform: |$from| -> |$to|");
   
                                 if ($sf =~ /^\^/) {  
                                         my $regex =  
                                                 's/\Q'. $sf .'\E([^\^]+)\Q'. $from .'\E([^\^]+)/'. $sf .'$1'. $to .'$2/g';  
                                         push @{ $regexpes->{$f} }, $regex;  
 warn ">>>>> $regex [sf]\n";  
                                 } else {  
                                         my $regex =  
                                                 's/\Q'. $from .'\E/'. $to .'/g';  
                                         push @{ $regexpes->{$f} }, $regex;  
 warn ">>>>> $regex [global]\n";  
                                 }  
603    
604                                    my $regex = _get_regex($sf,$from,$to);
605                                    push @{ $regexpes->{$f} }, $regex;
606                                    $log->debug("regex: $regex");
607                          }                          }
608                  }                  }
609          }          }
# Line 567  warn ">>>>> $regex [global]\n"; Line 611  warn ">>>>> $regex [global]\n";
611          return $regexpes;          return $regexpes;
612  }  }
613    
614    =head2 modify_file_regexps
615    
616    Generate hash with regexpes to be applied using l<filter> from
617    pseudo hash/yaml format for regex mappings.
618    
619    It should be obvious:
620    
621            200
622              '^a'
623                ' : ' => '^e'
624                ' = ' => '^d'
625    
626    In field I<200> find C<'^a'> and then C<' : '>, and replace it with C<'^e'>.
627    In field I<200> find C<'^a'> and then C<' = '>, and replace it with C<'^d'>.
628    
629      my $regexpes = $input->modify_file_regexps( 'conf/modify/common.pl' );
630    
631    On undef path it will just return.
632    
633    =cut
634    
635    sub modify_file_regexps {
636            my $self = shift;
637    
638            my $modify_path = shift || return;
639    
640            my $log = $self->_get_logger();
641    
642            my $regexpes;
643    
644            CORE::open(my $fh, $modify_path) || $log->logdie("can't open modify file $modify_path: $!");
645    
646            my ($f,$sf);
647    
648            while(<$fh>) {
649                    chomp;
650                    next if (/^#/ || /^\s*$/);
651    
652                    if (/^\s*(\d+)\s*$/) {
653                            $f = $1;
654                            $log->debug("field: $f");
655                            next;
656                    } elsif (/^\s*'([^']*)'\s*$/) {
657                            $sf = $1;
658                            $log->die("can't define subfiled before field in: $_") unless ($f);
659                            $log->debug("subfield: $sf");
660                    } elsif (/^\s*'([^']*)'\s*=>\s*'([^']*)'\s*$/) {
661                            my ($from,$to) = ($1, $2);
662    
663                            $log->debug("transform: |$from| -> |$to|");
664    
665                            my $regex = _get_regex($sf,$from,$to);
666                            push @{ $regexpes->{$f} }, $regex;
667                            $log->debug("regex: $regex");
668                    }
669            }
670    
671            return $regexpes;
672    }
673    
674  =head1 MEMORY USAGE  =head1 MEMORY USAGE
675    
676  C<low_mem> options is double-edged sword. If enabled, WebPAC  C<low_mem> options is double-edged sword. If enabled, WebPAC
# Line 604  Dobrica Pavlinusic, C<< <dpavlin@rot13.o Line 708  Dobrica Pavlinusic, C<< <dpavlin@rot13.o
708    
709  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
710    
711  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
712    
713  This program is free software; you can redistribute it and/or modify it  This program is free software; you can redistribute it and/or modify it
714  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.598  
changed lines
  Added in v.760
  ViewVC Help
Powered by ViewVC 1.1.26