/[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 593 by dpavlin, Sun Jul 9 15:22:39 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 39  C<fetch_rec> and optional C<init> functi Line 39  C<fetch_rec> and optional C<init> functi
39    
40  Perhaps a little code snippet.  Perhaps a little code snippet.
41    
42      use WebPAC::Input;          use WebPAC::Input;
43    
44      my $db = WebPAC::Input->new(          my $db = WebPAC::Input->new(
45          module => 'WebPAC::Input::ISIS',                  module => 'WebPAC::Input::ISIS',
                 config => $config,  
46                  low_mem => 1,                  low_mem => 1,
47      );          );
48    
49      $db->open('/path/to/database');          $db->open( path => '/path/to/database' );
50          print "database size: ",$db->size,"\n";          print "database size: ",$db->size,"\n";
51          while (my $rec = $db->fetch) {          while (my $rec = $db->fetch) {
52                  # do something with $rec                  # do something with $rec
# Line 69  Create new input database object. Line 68  Create new input database object.
68          no_progress_bar => 1,          no_progress_bar => 1,
69    );    );
70    
71  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
72  L<WebPAC::Input::MARC>.  L<WebPAC::Input::MARC>.
73    
74  Optional parametar C<encoding> specify application code page (which will be  Optional parametar C<encoding> specify application code page (which will be
# Line 99  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 160  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 => {
133                    900 => { '^a' => { ' : ' => '^b' } },
134                    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 179  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 key => $value combinations to  C<lookup_coderef> is closure to called to save data into lookups
148  lookup.  
149    C<modify_records> specify mapping from subfields to delimiters or from
150    delimiters to subfields, as well as oprations on fields (if subfield is
151    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>.
# Line 197  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 206  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;
185            my $recode_map;
186    
187          if ($self->{recode}) {          if ($self->{recode}) {
188                  my @r = split(/\s/, $self->{recode});                  my @r = split(/\s/, $self->{recode});
189                  if ($#r % 2 != 1) {                  if ($#r % 2 != 1) {
190                          $log->logwarn("recode needs even number of elements (some number of valid pairs)");                          $log->logwarn("recode needs even number of elements (some number of valid pairs)");
191                  } else {                  } else {
                         my $recode;  
192                          while (@r) {                          while (@r) {
193                                  my $from = shift @r;                                  my $from = shift @r;
194                                  my $to = shift @r;                                  my $to = shift @r;
195                                  $recode->{$from} = $to;                                  $recode_map->{$from} = $to;
196                          }                          }
197    
198                          my $regex = join '|' => keys %{ $recode };                          $recode_regex = join '|' => keys %{ $recode_map };
   
                         $log->debug("using recode regex: $regex");  
                           
                         $filter_ref = sub {  
                                 my $t = shift;  
                                 $t =~ s/($regex)/$recode->{$1}/g;  
                                 return $t;  
                         };  
199    
200                            $log->debug("using recode regex: $recode_regex");
201                  }                  }
202    
203          }          }
204    
205          my ($db, $size) = $self->{open_db}->( $self,          my $rec_regex;
206            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 $ll_db = $class->new(
218                  path => $arg->{path},                  path => $arg->{path},
219                  filter => $filter_ref,  #               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 274  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 301  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 312  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 335  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 496  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
564    
565    Generate hash with regexpes to be applied using l<filter>.
566    
567      my $regexpes = $input->modify_record_regexps(
568                    900 => { '^a' => { ' : ' => '^b' } },
569                    901 => { '*' => { '^b' => ' ; ' } },
570      );
571    
572    =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 {
586            my $self = shift;
587            my $modify_record = {@_};
588    
589            my $regexpes;
590    
591            my $log = $self->_get_logger();
592    
593            foreach my $f (keys %$modify_record) {
594                    $log->debug("field: $f");
595    
596                    foreach my $sf (keys %{ $modify_record->{$f} }) {
597                            $log->debug("subfield: $sf");
598    
599                            foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
600                                    my $to = $modify_record->{$f}->{$sf}->{$from};
601                                    #die "no field?" unless defined($to);
602                                    $log->debug("transform: |$from| -> |$to|");
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;
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 533  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.593  
changed lines
  Added in v.760
  ViewVC Help
Powered by ViewVC 1.1.26