/[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 496 by dpavlin, Sun May 14 19:45:26 2006 UTC revision 760 by dpavlin, Wed Oct 25 15:56:44 2006 UTC
# Line 3  package WebPAC::Input; Line 3  package WebPAC::Input;
3  use warnings;  use warnings;
4  use strict;  use strict;
5    
6    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 14  WebPAC::Input - read different file form Line 16  WebPAC::Input - read different file form
16    
17  =head1 VERSION  =head1 VERSION
18    
19  Version 0.04  Version 0.13
20    
21  =cut  =cut
22    
23  our $VERSION = '0.04';  our $VERSION = '0.13';
24    
25  =head1 SYNOPSIS  =head1 SYNOPSIS
26    
# Line 37  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,  
                 lookup => $lookup_obj,  
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 62  Create new input database object. Line 62  Create new input database object.
62    
63    my $db = new WebPAC::Input(    my $db = new WebPAC::Input(
64          module => 'WebPAC::Input::MARC',          module => 'WebPAC::Input::MARC',
65          code_page => 'ISO-8859-2',          encoding => 'ISO-8859-2',
66          low_mem => 1,          low_mem => 1,
67          recode => 'char pairs',          recode => 'char pairs',
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<code_page> specify application code page (which will be  Optional parametar C<encoding> specify application code page (which will be
75  used internally). This should probably be your terminal encoding, and by  used internally). This should probably be your terminal encoding, and by
76  default, it C<ISO-8859-2>.  default, it C<ISO-8859-2>.
77    
# Line 94  sub new { Line 94  sub new {
94    
95          my $log = $self->_get_logger;          my $log = $self->_get_logger;
96    
97            $log->logconfess("code_page argument is not suppored any more. change it to encoding") if ($self->{lookup});
98            $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 };  
                 }  
111          }          }
112    
113          if ($self->{init}) {          $self->{'encoding'} ||= 'ISO-8859-2';
                 $log->debug("calling init");  
                 $self->{init}->($self, @_);  
         }  
   
         $self->{'code_page'} ||= 'ISO-8859-2';  
   
         # 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;  
         }  
114    
115          $self ? return $self : return undef;          $self ? return $self : return undef;
116  }  }
# Line 156  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,
127          lookup => $lookup_obj,          stats => 1,
128            lookup_coderef => sub {
129                    my $rec = shift;
130                    # 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    
143  C<limit> is optional parametar to read just C<limit> records from database  C<limit> is optional parametar to read just C<limit> records from database
144    
145    C<stats> create optional report about usage of fields and subfields
146    
147    C<lookup_coderef> is closure to called to save data into lookups
148    
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>.
159    
# Line 179  sub open { Line 165  sub open {
165    
166          my $log = $self->_get_logger();          my $log = $self->_get_logger();
167    
168            $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_coderef") if ($arg->{lookup});
169            $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
170                    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 188  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->{'code_page'});  
   
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 },
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 238  sub open { Line 242  sub open {
242          my $to_rec = $size;          my $to_rec = $size;
243    
244          if (my $s = $self->{offset}) {          if (my $s = $self->{offset}) {
245                  $log->info("skipping to MFN $s");                  $log->debug("skipping to MFN $s");
246                  $from_rec = $s;                  $from_rec = $s;
247          } else {          } else {
248                  $self->{offset} = $from_rec;                  $self->{offset} = $from_rec;
# Line 253  sub open { Line 257  sub open {
257          # store size for later          # store size for later
258          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
259    
260          $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{code_page}");          $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 277  sub open { Line 340  sub open {
340                  }                  }
341    
342                  # create lookup                  # create lookup
343                  $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});                  $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
344    
345                    # update counters for statistics
346                    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 }) {
352                                    $self->{_stats}->{fld}->{ $fld }++;
353    
354                                    $log->logdie("invalid record fild $fld, not ARRAY")
355                                            unless (ref($rec->{ $fld }) eq 'ARRAY');
356            
357                                    foreach my $row (@{ $rec->{$fld} }) {
358    
359                                            if (ref($row) eq 'HASH') {
360    
361                                                    foreach my $sf (keys %{ $row }) {
362                                                            next if ($sf eq 'subfields');
363                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
364                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
365                                                                            if (ref($row->{$sf}) eq 'ARRAY');
366                                                    }
367    
368                                            } else {
369                                                    $self->{_stats}->{repeatable}->{ $fld }++;
370                                            }
371                                    }
372                            }
373                    }
374    
375                  $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});                  $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
376    
# Line 290  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 400  sub seek { Line 496  sub seek {
496          return $self->{pos} = (($pos - 1) || -1);          return $self->{pos} = (($pos - 1) || -1);
497  }  }
498    
499    =head2 stats
500    
501    Dump statistics about field and subfield usage
502    
503      print $input->stats;
504    
505    =cut
506    
507    sub stats {
508            my $self = shift;
509    
510            my $log = $self->_get_logger();
511    
512            my $s = $self->{_stats};
513            if (! $s) {
514                    $log->warn("called stats, but there is no statistics collected");
515                    return;
516            }
517    
518            my $max_fld = 0;
519    
520            my $out = join("\n",
521                    map {
522                            my $f = $_ || die "no field";
523                            my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
524                            $max_fld = $v if ($v > $max_fld);
525    
526                            my $o = sprintf("%4s %d ~", $f, $v);
527    
528                            if (defined($s->{sf}->{$f})) {
529                                    map {
530                                            $o .= sprintf(" %s:%d%s", $_,
531                                                    $s->{sf}->{$f}->{$_}->{count},
532                                                    $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
533                                            );
534                                    } sort keys %{ $s->{sf}->{$f} };
535                            }
536    
537                            if (my $v_r = $s->{repeatable}->{$f}) {
538                                    $o .= " ($v_r)" if ($v_r != $v);
539                            }
540    
541                            $o;
542                    } sort { $a cmp $b } keys %{ $s->{fld} }
543            );
544    
545            $log->debug( sub { Dumper($s) } );
546    
547            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    
# Line 438  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.496  
changed lines
  Added in v.760
  ViewVC Help
Powered by ViewVC 1.1.26