/[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 287 by dpavlin, Sun Dec 18 21:06:51 2005 UTC revision 619 by dpavlin, Fri Aug 25 12:31:06 2006 UTC
# Line 8  use blib; Line 8  use blib;
8  use WebPAC::Common;  use WebPAC::Common;
9  use base qw/WebPAC::Common/;  use base qw/WebPAC::Common/;
10  use Text::Iconv;  use Text::Iconv;
11    use Data::Dumper;
12    
13  =head1 NAME  =head1 NAME
14    
# Line 15  WebPAC::Input - read different file form Line 16  WebPAC::Input - read different file form
16    
17  =head1 VERSION  =head1 VERSION
18    
19  Version 0.03  Version 0.11
20    
21  =cut  =cut
22    
23  our $VERSION = '0.03';  our $VERSION = '0.11';
24    
25  =head1 SYNOPSIS  =head1 SYNOPSIS
26    
# Line 38  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
53            }
54    
55    
56    
# 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',
68            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    
78  Default is not to use C<low_mem> options (see L<MEMORY USAGE> below).  Default is not to use C<low_mem> options (see L<MEMORY USAGE> below).
79    
80    C<recode> is optional string constisting of character or words pairs that
81    should be replaced in input stream.
82    
83    C<no_progress_bar> disables progress bar output on C<STDOUT>
84    
85  This function will also call low-level C<init> if it exists with same  This function will also call low-level C<init> if it exists with same
86  parametars.  parametars.
87    
# Line 87  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 = $self->{module};
102          $module =~ s#::#/#g;          $module =~ s#::#/#g;
103          $module .= '.pm';          $module .= '.pm';
104          $log->debug("require low-level module $self->{module} from $module");          $log->debug("require low-level module $self->{module} from $module");
105    
106          require $module;          require $module;
107          eval $self->{module} .'->import';          #eval $self->{module} .'->import';
108    
109          # check if required subclasses are implemented          # check if required subclasses are implemented
110          foreach my $subclass (qw/open_db fetch_rec/) {          foreach my $subclass (qw/open_db fetch_rec init/) {
111                  if ( $self->can($subclass) ) {                  my $n = $self->{module} . '::' . $subclass;
112                          $log->debug("imported $subclass");                  if (! defined &{ $n }) {
113                            my $missing = "missing $subclass in $self->{module}";
114                            $self->{$subclass} = sub { $log->logwarn($missing) };
115                  } else {                  } else {
116                          $log->warn("missing $subclass in $self->{module}");                          $self->{$subclass} = \&{ $n };
117                  }                  }
118          }          }
119    
120          if ($self->can('init')) {          if ($self->{init}) {
121                  $log->debug("calling init");                  $log->debug("calling init");
122                  $self->init(@_);                  $self->{init}->($self, @_);
123          }          }
124    
125          $self->{'code_page'} ||= 'ISO-8859-2';          $self->{'encoding'} ||= 'ISO-8859-2';
126    
127          # running with low_mem flag? well, use DBM::Deep then.          # running with low_mem flag? well, use DBM::Deep then.
128          if ($self->{'low_mem'}) {          if ($self->{'low_mem'}) {
# Line 150  This function will read whole database i Line 163  This function will read whole database i
163          limit => 500,          limit => 500,
164          offset => 6000,          offset => 6000,
165          lookup => $lookup_obj,          lookup => $lookup_obj,
166            stats => 1,
167            lookup_ref => sub {
168                    my ($k,$v) = @_;
169                    # store lookup $k => $v
170            },
171            modify_records => {
172                    900 => { '^a' => { ' : ' => '^b' } },
173                    901 => { '*' => { '^b' => ' ; ' } },
174            },
175   );   );
176    
177  By default, C<code_page> is assumed to be C<852>.  By default, C<code_page> is assumed to be C<852>.
# Line 158  C<offset> is optional parametar to posit Line 180  C<offset> is optional parametar to posit
180    
181  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
182    
183    C<stats> create optional report about usage of fields and subfields
184    
185    C<lookup_coderef> is closure to call when adding C<< key => 'value' >> combinations to
186    lookup.
187    
188    C<modify_records> specify mapping from subfields to delimiters or from
189    delimiters to subfields, as well as oprations on fields (if subfield is
190    defined as C<*>.
191    
192  Returns size of database, regardless of C<offset> and C<limit>  Returns size of database, regardless of C<offset> and C<limit>
193  parametars, see also C<size>.  parametars, see also C<size>.
194    
# Line 169  sub open { Line 200  sub open {
200    
201          my $log = $self->_get_logger();          my $log = $self->_get_logger();
202    
203            $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_coderef") if ($arg->{lookup});
204            $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
205                    if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
206    
207          $log->logcroak("need path") if (! $arg->{'path'});          $log->logcroak("need path") if (! $arg->{'path'});
208          my $code_page = $arg->{'code_page'} || '852';          my $code_page = $arg->{'code_page'} || '852';
209    
210          # store data in object          # store data in object
211          $self->{'code_page'} = $code_page;          $self->{'input_code_page'} = $code_page;
212          foreach my $v (qw/path offset limit/) {          foreach my $v (qw/path offset limit/) {
213                  $self->{$v} = $arg->{$v} if ($arg->{$v});                  $self->{$v} = $arg->{$v} if ($arg->{$v});
214          }          }
215    
216          # create Text::Iconv object          # create Text::Iconv object
217          $self->{iconv} = Text::Iconv->new($code_page,$self->{'code_page'});          $self->{iconv} = Text::Iconv->new($code_page,$self->{'encoding'});      ## FIXME remove!
218    
219            my $filter_ref;
220            my $recode_regex;
221            my $recode_map;
222    
223            if ($self->{recode}) {
224                    my @r = split(/\s/, $self->{recode});
225                    if ($#r % 2 != 1) {
226                            $log->logwarn("recode needs even number of elements (some number of valid pairs)");
227                    } else {
228                            while (@r) {
229                                    my $from = shift @r;
230                                    my $to = shift @r;
231                                    $recode_map->{$from} = $to;
232                            }
233    
234                            $recode_regex = join '|' => keys %{ $recode_map };
235    
236                            $log->debug("using recode regex: $recode_regex");
237                    }
238    
239          my ($db, $size) = $self->open_db(          }
240    
241            my $rec_regex = $self->modify_record_regexps(%{ $arg->{modify_records} });
242            $log->debug("rec_regex: ", Dumper($rec_regex));
243    
244            my ($db, $size) = $self->{open_db}->( $self,
245                  path => $arg->{path},                  path => $arg->{path},
246                    filter => sub {
247                                    my ($l,$f_nr) = @_;
248                                    return unless defined($l);
249    
250                                    ## FIXME remove iconv!
251                                    $l = $self->{iconv}->convert($l) if ($self->{iconv});
252            
253                                    $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
254    
255                                    ## FIXME remove this warning when we are sure that none of API is calling
256                                    ## this wrongly
257                                    warn "filter called without field number" unless ($f_nr);
258    
259                                    return $l;
260                    },
261                    %{ $arg },
262          );          );
263    
264          unless ($db) {          unless (defined($db)) {
265                  $log->logwarn("can't open database $arg->{path}, skipping...");                  $log->logwarn("can't open database $arg->{path}, skipping...");
266                  return;                  return;
267          }          }
# Line 195  sub open { Line 271  sub open {
271                  return;                  return;
272          }          }
273    
274          my $offset = 1;          my $from_rec = 1;
275          my $limit = $size;          my $to_rec = $size;
276    
277          if (my $s = $self->{offset}) {          if (my $s = $self->{offset}) {
278                  $log->info("skipping to MFN $s");                  $log->debug("skipping to MFN $s");
279                  $offset = $s;                  $from_rec = $s;
280          } else {          } else {
281                  $self->{offset} = $offset;                  $self->{offset} = $from_rec;
282          }          }
283    
284          if ($self->{limit}) {          if ($self->{limit}) {
285                  $log->info("limiting to ",$self->{limit}," records");                  $log->debug("limiting to ",$self->{limit}," records");
286                  $limit = $offset + $self->{limit} - 1;                  $to_rec = $from_rec + $self->{limit} - 1;
287                  $limit = $size if ($limit > $size);                  $to_rec = $size if ($to_rec > $size);
288          }          }
289    
290          # store size for later          # store size for later
291          $self->{size} = ($limit - $offset) ? ($limit - $offset + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
292    
293          $log->info("processing $self->{size} records in $code_page, convert to $self->{code_page}");          $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{encoding}", $self->{stats} ? ' [stats]' : '');
294    
295          # read database          # read database
296          for (my $pos = $offset; $pos <= $limit; $pos++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
297    
298                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
299    
300                  my $rec = $self->fetch_rec( $db, $pos );                  my $rec = $self->{fetch_rec}->($self, $db, $pos, sub {
301                                    my ($l,$f_nr) = @_;
302                                    return unless defined($l);
303                                    return $l unless ($rec_regex && $f_nr);
304    
305                                    # apply regexps
306                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
307                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
308                                            my $c = 0;
309                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
310                                                    #$log->debug("\$l = $l\neval \$l =~ $r");
311                                                    eval '$l =~ ' . $r;
312                                                    $log->error("error applying regex: $r") if ($@);
313                                            }
314                                    }
315    
316                                    return $l;
317                    });
318    
319                    $log->debug(sub { Dumper($rec) });
320    
321                  if (! $rec) {                  if (! $rec) {
322                          $log->warn("record $pos empty? skipping...");                          $log->warn("record $pos empty? skipping...");
# Line 236  sub open { Line 331  sub open {
331                  }                  }
332    
333                  # create lookup                  # create lookup
334                  $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});                  $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
335    
336                    # update counters for statistics
337                    if ($self->{stats}) {
338    
339                            # fetch clean record with regexpes applied for statistics
340                            my $rec = $self->{fetch_rec}->($self, $db, $pos);
341    
342                  $self->progress_bar($pos,$limit);                          foreach my $fld (keys %{ $rec }) {
343                                    $self->{_stats}->{fld}->{ $fld }++;
344    
345                                    $log->logdie("invalid record fild $fld, not ARRAY")
346                                            unless (ref($rec->{ $fld }) eq 'ARRAY');
347            
348                                    foreach my $row (@{ $rec->{$fld} }) {
349    
350                                            if (ref($row) eq 'HASH') {
351    
352                                                    foreach my $sf (keys %{ $row }) {
353                                                            next if ($sf eq 'subfields');
354                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
355                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
356                                                                            if (ref($row->{$sf}) eq 'ARRAY');
357                                                    }
358    
359                                            } else {
360                                                    $self->{_stats}->{repeatable}->{ $fld }++;
361                                            }
362                                    }
363                            }
364                    }
365    
366                    $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
367    
368          }          }
369    
# Line 246  sub open { Line 371  sub open {
371          $self->{last_pcnt} = 0;          $self->{last_pcnt} = 0;
372    
373          # store max mfn and return it.          # store max mfn and return it.
374          $self->{max_pos} = $limit;          $self->{max_pos} = $to_rec;
375          $log->debug("max_pos: $limit");          $log->debug("max_pos: $to_rec");
376    
377          return $size;          return $size;
378  }  }
# Line 284  sub fetch { Line 409  sub fetch {
409                  return;                  return;
410          }          }
411    
412          $self->progress_bar($mfn,$self->{max_pos});          $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
413    
414          my $rec;          my $rec;
415    
# Line 359  sub seek { Line 484  sub seek {
484          return $self->{pos} = (($pos - 1) || -1);          return $self->{pos} = (($pos - 1) || -1);
485  }  }
486    
487    =head2 stats
488    
489    Dump statistics about field and subfield usage
490    
491      print $input->stats;
492    
493    =cut
494    
495    sub stats {
496            my $self = shift;
497    
498            my $log = $self->_get_logger();
499    
500            my $s = $self->{_stats};
501            if (! $s) {
502                    $log->warn("called stats, but there is no statistics collected");
503                    return;
504            }
505    
506            my $max_fld = 0;
507    
508            my $out = join("\n",
509                    map {
510                            my $f = $_ || die "no field";
511                            my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
512                            $max_fld = $v if ($v > $max_fld);
513    
514                            my $o = sprintf("%4s %d ~", $f, $v);
515    
516                            if (defined($s->{sf}->{$f})) {
517                                    map {
518                                            $o .= sprintf(" %s:%d%s", $_,
519                                                    $s->{sf}->{$f}->{$_}->{count},
520                                                    $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
521                                            );
522                                    } sort keys %{ $s->{sf}->{$f} };
523                            }
524    
525                            if (my $v_r = $s->{repeatable}->{$f}) {
526                                    $o .= " ($v_r)" if ($v_r != $v);
527                            }
528    
529                            $o;
530                    } sort { $a cmp $b } keys %{ $s->{fld} }
531            );
532    
533            $log->debug( sub { Dumper($s) } );
534    
535            return $out;
536    }
537    
538    =head2 modify_record_regexps
539    
540    Generate hash with regexpes to be applied using L<filter>.
541    
542      my $regexpes = $input->modify_record_regexps(
543                    900 => { '^a' => { ' : ' => '^b' } },
544                    901 => { '*' => { '^b' => ' ; ' } },
545      );
546    
547    =cut
548    
549    sub modify_record_regexps {
550            my $self = shift;
551            my $modify_record = {@_};
552    
553            my $regexpes;
554    
555            foreach my $f (keys %$modify_record) {
556    warn "--- f: $f\n";
557                    foreach my $sf (keys %{ $modify_record->{$f} }) {
558    warn "---- sf: $sf\n";
559                            foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
560                                    my $to = $modify_record->{$f}->{$sf}->{$from};
561                                    #die "no field?" unless defined($to);
562    warn "----- transform: |$from| -> |$to|\n";
563    
564                                    if ($sf =~ /^\^/) {
565                                            my $regex =
566                                                    's/\Q'. $sf .'\E([^\^]+)\Q'. $from .'\E([^\^]+)/'. $sf .'$1'. $to .'$2/g';
567                                            push @{ $regexpes->{$f} }, $regex;
568    warn ">>>>> $regex [sf]\n";
569                                    } else {
570                                            my $regex =
571                                                    's/\Q'. $from .'\E/'. $to .'/g';
572                                            push @{ $regexpes->{$f} }, $regex;
573    warn ">>>>> $regex [global]\n";
574                                    }
575    
576                            }
577                    }
578            }
579    
580            return $regexpes;
581    }
582    
583  =head1 MEMORY USAGE  =head1 MEMORY USAGE
584    
# Line 397  Dobrica Pavlinusic, C<< <dpavlin@rot13.o Line 617  Dobrica Pavlinusic, C<< <dpavlin@rot13.o
617    
618  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
619    
620  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
621    
622  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
623  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.287  
changed lines
  Added in v.619
  ViewVC Help
Powered by ViewVC 1.1.26