/[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 624 by dpavlin, Sat Aug 26 12:00:31 2006 UTC revision 760 by dpavlin, Wed Oct 25 15:56:44 2006 UTC
# 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.13
20    
21  =cut  =cut
22    
23  our $VERSION = '0.11';  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 162  This function will read whole database i Line 124  This function will read whole database i
124          code_page => 'cp852',          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<cp852>.  By default, C<code_page> is assumed to be C<cp852>.
# 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'} || 'cp852';          my $code_page = $arg->{'code_page'} || 'cp852';
176    
# Line 235  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                    $rec_regex = $self->modify_file_regexps( $p );
209            } elsif (my $h = $arg->{modify_records}) {
210                    $log->debug("using modify_records ", Dumper( $h ));
211                    $rec_regex = $self->modify_record_regexps(%{ $h });
212            }
213            $log->debug("rec_regex: ", Dumper($rec_regex)) if ($rec_regex);
214    
215            my $class = $self->{module} || $log->logconfess("can't get low-level module name!");
216    
217          my ($db, $size) = $self->{open_db}->( $self,          my $ll_db = $class->new(
218                  path => $arg->{path},                  path => $arg->{path},
219  #               filter => sub {  #               filter => sub {
220  #                       my ($l,$f_nr) = @_;  #                       my ($l,$f_nr) = @_;
# Line 250  sub open { Line 226  sub open {
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 281  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, sub {                  my $rec = $ll_db->fetch_rec($pos, sub {
300                                  my ($l,$f_nr) = @_;                                  my ($l,$f_nr) = @_;
301  #                               return unless defined($l);  #                               return unless defined($l);
302  #                               return $l unless ($rec_regex && $f_nr);  #                               return $l unless ($rec_regex && $f_nr);
303    
304  warn "## --> $f_nr ## $l\n";                                  $log->debug("-=> $f_nr ## $l");
305    
306                                  # codepage conversion and recode_regex                                  # codepage conversion and recode_regex
307  #                               from_to($l, $code_page, $self->{'encoding'});                                  from_to($l, $code_page, $self->{'encoding'});
                                 from_to($l, $code_page, 'utf-8');  
308                                  $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);                                  $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
309    
310                                  # apply regexps                                  # apply regexps
# Line 302  warn "## --> $f_nr ## $l\n"; Line 312  warn "## --> $f_nr ## $l\n";
312                                          $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');                                          $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
313                                          my $c = 0;                                          my $c = 0;
314                                          foreach my $r (@{ $rec_regex->{$f_nr} }) {                                          foreach my $r (@{ $rec_regex->{$f_nr} }) {
315                                                  #$log->debug("\$l = $l\neval \$l =~ $r");                                                  my $old_l = $l;
316                                                  eval '$l =~ ' . $r;                                                  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 ($@);                                                  $log->error("error applying regex: $r") if ($@);
321                                          }                                          }
322                                  }                                  }
323    
324  warn "## <-- $f_nr ## $l\n";                                  $log->debug("<=- $f_nr ## $l");
325                                  return $l;                                  return $l;
326                  });                  });
327    
# Line 333  warn "## <-- $f_nr ## $l\n"; Line 346  warn "## <-- $f_nr ## $l\n";
346                  if ($self->{stats}) {                  if ($self->{stats}) {
347    
348                          # fetch clean record with regexpes applied for statistics                          # fetch clean record with regexpes applied for statistics
349                          my $rec = $self->{fetch_rec}->($self, $db, $pos);                          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 }++;
# Line 370  warn "## <-- $f_nr ## $l\n"; Line 383  warn "## <-- $f_nr ## $l\n";
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 531  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 542  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          }          }
610    
611            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;          return $regexpes;
672  }  }
673    
Legend:
Removed from v.624  
changed lines
  Added in v.760
  ViewVC Help
Powered by ViewVC 1.1.26