/[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 286 by dpavlin, Sun Dec 18 21:06:46 2005 UTC revision 626 by dpavlin, Mon Sep 4 16:15:07 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/;
10  use Text::Iconv;  use Data::Dumper;
11    use Encode qw/from_to/;
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 146  This function will read whole database i Line 159  This function will read whole database i
159    
160   $input->open(   $input->open(
161          path => '/path/to/database/file',          path => '/path/to/database/file',
162          code_page => '852',          code_page => 'cp852',
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<cp852>.
178    
179  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.
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'} || 'cp852';
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          my $filter_ref;
217          $self->{iconv} = Text::Iconv->new($code_page,$self->{'code_page'});          my $recode_regex;
218            my $recode_map;
219    
220            if ($self->{recode}) {
221                    my @r = split(/\s/, $self->{recode});
222                    if ($#r % 2 != 1) {
223                            $log->logwarn("recode needs even number of elements (some number of valid pairs)");
224                    } else {
225                            while (@r) {
226                                    my $from = shift @r;
227                                    my $to = shift @r;
228                                    $recode_map->{$from} = $to;
229                            }
230    
231                            $recode_regex = join '|' => keys %{ $recode_map };
232    
233                            $log->debug("using recode regex: $recode_regex");
234                    }
235    
236            }
237    
238            my $rec_regex = $self->modify_record_regexps(%{ $arg->{modify_records} });
239            $log->debug("rec_regex: ", Dumper($rec_regex));
240    
241          my ($db, $size) = $self->open_db(          my ($db, $size) = $self->{open_db}->( $self,
242                  path => $arg->{path},                  path => $arg->{path},
243    #               filter => sub {
244    #                       my ($l,$f_nr) = @_;
245    #                       return unless defined($l);
246    #                       from_to($l, $code_page, $self->{'encoding'});
247    #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
248    #                       return $l;
249    #               },
250                    %{ $arg },
251          );          );
252    
253          unless ($db) {          unless (defined($db)) {
254                  $log->logwarn("can't open database $arg->{path}, skipping...");                  $log->logwarn("can't open database $arg->{path}, skipping...");
255                  return;                  return;
256          }          }
# Line 195  sub open { Line 260  sub open {
260                  return;                  return;
261          }          }
262    
263          my $offset = 1;          my $from_rec = 1;
264          my $limit = $size;          my $to_rec = $size;
265    
266          if (my $s = $self->{offset}) {          if (my $s = $self->{offset}) {
267                  $log->info("skipping to MFN $s");                  $log->debug("skipping to MFN $s");
268                  $offset = $s;                  $from_rec = $s;
269          } else {          } else {
270                  $self->{offset} = $offset;                  $self->{offset} = $from_rec;
271          }          }
272    
273          if ($self->{limit}) {          if ($self->{limit}) {
274                  $log->info("limiting to ",$self->{limit}," records");                  $log->debug("limiting to ",$self->{limit}," records");
275                  $limit = $offset + $self->{limit} - 1;                  $to_rec = $from_rec + $self->{limit} - 1;
276                  $limit = $size if ($limit > $size);                  $to_rec = $size if ($to_rec > $size);
277          }          }
278    
279          # store size for later          # store size for later
280          $self->{size} = ($limit - $offset) ? ($limit - $offset + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
281    
282          $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]' : '');
283    
284          # read database          # read database
285          for (my $pos = $offset; $pos <= $limit; $mfn++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
286    
287                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
288    
289                  my $rec = $self->fetch_rec( $db, $pos );                  my $rec = $self->{fetch_rec}->($self, $db, $pos, sub {
290                                    my ($l,$f_nr) = @_;
291    #                               return unless defined($l);
292    #                               return $l unless ($rec_regex && $f_nr);
293    
294                                    $log->debug("-=> $f_nr ## $l");
295    
296                                    # codepage conversion and recode_regex
297                                    from_to($l, $code_page, $self->{'encoding'});
298                                    $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
299    
300                                    # apply regexps
301                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
302                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
303                                            my $c = 0;
304                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
305                                                    my $old_l = $l;
306                                                    eval '$l =~ ' . $r;
307                                                    if ($old_l ne $l) {
308                                                            $log->debug("REGEX on $f_nr eval \$l =~ $r\n## old l: [$old_l]\n## new l: [$l]");
309                                                    }
310                                                    $log->error("error applying regex: $r") if ($@);
311                                            }
312                                    }
313    
314                                    $log->debug("<=- $f_nr ## $l");
315                                    return $l;
316                    });
317    
318                    $log->debug(sub { Dumper($rec) });
319    
320                  if (! $rec) {                  if (! $rec) {
321                          $log->warn("record $pos empty? skipping...");                          $log->warn("record $pos empty? skipping...");
# Line 236  sub open { Line 330  sub open {
330                  }                  }
331    
332                  # create lookup                  # create lookup
333                  $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});                  $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
334    
335                    # update counters for statistics
336                    if ($self->{stats}) {
337    
338                            # fetch clean record with regexpes applied for statistics
339                            my $rec = $self->{fetch_rec}->($self, $db, $pos);
340    
341                            foreach my $fld (keys %{ $rec }) {
342                                    $self->{_stats}->{fld}->{ $fld }++;
343    
344                                    $log->logdie("invalid record fild $fld, not ARRAY")
345                                            unless (ref($rec->{ $fld }) eq 'ARRAY');
346            
347                                    foreach my $row (@{ $rec->{$fld} }) {
348    
349                                            if (ref($row) eq 'HASH') {
350    
351                                                    foreach my $sf (keys %{ $row }) {
352                                                            next if ($sf eq 'subfields');
353                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
354                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
355                                                                            if (ref($row->{$sf}) eq 'ARRAY');
356                                                    }
357    
358                                            } else {
359                                                    $self->{_stats}->{repeatable}->{ $fld }++;
360                                            }
361                                    }
362                            }
363                    }
364    
365                  $self->progress_bar($pos,$limit);                  $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
366    
367          }          }
368    
# Line 246  sub open { Line 370  sub open {
370          $self->{last_pcnt} = 0;          $self->{last_pcnt} = 0;
371    
372          # store max mfn and return it.          # store max mfn and return it.
373          $self->{max_pos} = $limit;          $self->{max_pos} = $to_rec;
374          $log->debug("max_pos: $limit");          $log->debug("max_pos: $to_rec");
375    
376          return $size;          return $size;
377  }  }
# Line 284  sub fetch { Line 408  sub fetch {
408                  return;                  return;
409          }          }
410    
411          $self->progress_bar($mfn,$self->{max_pos});          $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
412    
413          my $rec;          my $rec;
414    
# Line 359  sub seek { Line 483  sub seek {
483          return $self->{pos} = (($pos - 1) || -1);          return $self->{pos} = (($pos - 1) || -1);
484  }  }
485    
486    =head2 stats
487    
488    Dump statistics about field and subfield usage
489    
490      print $input->stats;
491    
492    =cut
493    
494    sub stats {
495            my $self = shift;
496    
497            my $log = $self->_get_logger();
498    
499            my $s = $self->{_stats};
500            if (! $s) {
501                    $log->warn("called stats, but there is no statistics collected");
502                    return;
503            }
504    
505            my $max_fld = 0;
506    
507            my $out = join("\n",
508                    map {
509                            my $f = $_ || die "no field";
510                            my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
511                            $max_fld = $v if ($v > $max_fld);
512    
513                            my $o = sprintf("%4s %d ~", $f, $v);
514    
515                            if (defined($s->{sf}->{$f})) {
516                                    map {
517                                            $o .= sprintf(" %s:%d%s", $_,
518                                                    $s->{sf}->{$f}->{$_}->{count},
519                                                    $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
520                                            );
521                                    } sort keys %{ $s->{sf}->{$f} };
522                            }
523    
524                            if (my $v_r = $s->{repeatable}->{$f}) {
525                                    $o .= " ($v_r)" if ($v_r != $v);
526                            }
527    
528                            $o;
529                    } sort { $a cmp $b } keys %{ $s->{fld} }
530            );
531    
532            $log->debug( sub { Dumper($s) } );
533    
534            return $out;
535    }
536    
537    =head2 modify_record_regexps
538    
539    Generate hash with regexpes to be applied using L<filter>.
540    
541      my $regexpes = $input->modify_record_regexps(
542                    900 => { '^a' => { ' : ' => '^b' } },
543                    901 => { '*' => { '^b' => ' ; ' } },
544      );
545    
546    =cut
547    
548    sub modify_record_regexps {
549            my $self = shift;
550            my $modify_record = {@_};
551    
552            my $regexpes;
553    
554            foreach my $f (keys %$modify_record) {
555    warn "--- f: $f\n";
556                    foreach my $sf (keys %{ $modify_record->{$f} }) {
557    warn "---- sf: $sf\n";
558                            foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
559                                    my $to = $modify_record->{$f}->{$sf}->{$from};
560                                    #die "no field?" unless defined($to);
561    warn "----- transform: |$from| -> |$to|\n";
562    
563                                    if ($sf =~ /^\^/) {
564                                            my $regex =
565                                                    's/\Q'. $sf .'\E([^\^]+)\Q'. $from .'\E([^\^]+)/'. $sf .'$1'. $to .'$2/g';
566                                            push @{ $regexpes->{$f} }, $regex;
567    warn ">>>>> $regex [sf]\n";
568                                    } else {
569                                            my $regex =
570                                                    's/\Q'. $from .'\E/'. $to .'/g';
571                                            push @{ $regexpes->{$f} }, $regex;
572    warn ">>>>> $regex [global]\n";
573                                    }
574    
575                            }
576                    }
577            }
578    
579            return $regexpes;
580    }
581    
582  =head1 MEMORY USAGE  =head1 MEMORY USAGE
583    
# Line 397  Dobrica Pavlinusic, C<< <dpavlin@rot13.o Line 616  Dobrica Pavlinusic, C<< <dpavlin@rot13.o
616    
617  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
618    
619  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
620    
621  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
622  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.286  
changed lines
  Added in v.626
  ViewVC Help
Powered by ViewVC 1.1.26