/[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 338 by dpavlin, Sat Dec 31 16:50:06 2005 UTC revision 598 by dpavlin, Thu Jul 13 13:55:15 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/;
10  use Text::Iconv;  use Text::Iconv;
# 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.03  Version 0.08
20    
21  =cut  =cut
22    
23  our $VERSION = '0.03';  our $VERSION = '0.08';
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
53            }
54    
55    
56    
# Line 61  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 86  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;
# Line 111  sub new { Line 122  sub new {
122                  $self->{init}->($self, @_);                  $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 152  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 160  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 171  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    
# Line 181  sub open { Line 214  sub open {
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            }
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,          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                                    return $l unless ($rec_regex);
256    
257                                    # apply regexps
258                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
259                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
260                                            my $c = 0;
261                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
262                                                    while ( eval '$l =~ ' . $r ) { $c++ };
263                                            }
264                                            warn "## field $f_nr triggered $c regexpes\n" if ($c && $self->{debug});
265                                    }
266    
267                                    return $l;
268                    },
269                    %{ $arg },
270          );          );
271    
272          unless ($db) {          unless (defined($db)) {
273                  $log->logwarn("can't open database $arg->{path}, skipping...");                  $log->logwarn("can't open database $arg->{path}, skipping...");
274                  return;                  return;
275          }          }
# Line 197  sub open { Line 279  sub open {
279                  return;                  return;
280          }          }
281    
282          my $offset = 1;          my $from_rec = 1;
283          my $limit = $size;          my $to_rec = $size;
284    
285          if (my $s = $self->{offset}) {          if (my $s = $self->{offset}) {
286                  $log->info("skipping to MFN $s");                  $log->debug("skipping to MFN $s");
287                  $offset = $s;                  $from_rec = $s;
288          } else {          } else {
289                  $self->{offset} = $offset;                  $self->{offset} = $from_rec;
290          }          }
291    
292          if ($self->{limit}) {          if ($self->{limit}) {
293                  $log->debug("limiting to ",$self->{limit}," records");                  $log->debug("limiting to ",$self->{limit}," records");
294                  $limit = $offset + $self->{limit} - 1;                  $to_rec = $from_rec + $self->{limit} - 1;
295                  $limit = $size if ($limit > $size);                  $to_rec = $size if ($to_rec > $size);
296          }          }
297    
298          # store size for later          # store size for later
299          $self->{size} = ($limit - $offset) ? ($limit - $offset + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
300    
301          $log->info("processing $self->{size}/$size records [$offset-$limit] 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]' : '');
302    
303          # read database          # read database
304          for (my $pos = $offset; $pos <= $limit; $pos++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
305    
306                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
307    
# Line 240  sub open { Line 322  sub open {
322                  }                  }
323    
324                  # create lookup                  # create lookup
325                  $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});                  $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
326    
327                    # update counters for statistics
328                    if ($self->{stats}) {
329    
330                            foreach my $fld (keys %{ $rec }) {
331                                    $self->{_stats}->{fld}->{ $fld }++;
332    
333                                    $log->logdie("invalid record fild $fld, not ARRAY")
334                                            unless (ref($rec->{ $fld }) eq 'ARRAY');
335            
336                                    foreach my $row (@{ $rec->{$fld} }) {
337    
338                                            if (ref($row) eq 'HASH') {
339    
340                                                    foreach my $sf (keys %{ $row }) {
341                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
342                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
343                                                                            if (ref($row->{$sf}) eq 'ARRAY');
344                                                    }
345    
346                                            } else {
347                                                    $self->{_stats}->{repeatable}->{ $fld }++;
348                                            }
349                                    }
350                            }
351                    }
352    
353                  $self->progress_bar($pos,$limit);                  $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
354    
355          }          }
356    
# Line 250  sub open { Line 358  sub open {
358          $self->{last_pcnt} = 0;          $self->{last_pcnt} = 0;
359    
360          # store max mfn and return it.          # store max mfn and return it.
361          $self->{max_pos} = $limit;          $self->{max_pos} = $to_rec;
362          $log->debug("max_pos: $limit");          $log->debug("max_pos: $to_rec");
363    
364          return $size;          return $size;
365  }  }
# Line 288  sub fetch { Line 396  sub fetch {
396                  return;                  return;
397          }          }
398    
399          $self->progress_bar($mfn,$self->{max_pos});          $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
400    
401          my $rec;          my $rec;
402    
# Line 363  sub seek { Line 471  sub seek {
471          return $self->{pos} = (($pos - 1) || -1);          return $self->{pos} = (($pos - 1) || -1);
472  }  }
473    
474    =head2 stats
475    
476    Dump statistics about field and subfield usage
477    
478      print $input->stats;
479    
480    =cut
481    
482    sub stats {
483            my $self = shift;
484    
485            my $log = $self->_get_logger();
486    
487            my $s = $self->{_stats};
488            if (! $s) {
489                    $log->warn("called stats, but there is no statistics collected");
490                    return;
491            }
492    
493            my $max_fld = 0;
494    
495            my $out = join("\n",
496                    map {
497                            my $f = $_ || die "no field";
498                            my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
499                            $max_fld = $v if ($v > $max_fld);
500    
501                            my $o = sprintf("%4s %d ~", $f, $v);
502    
503                            if (defined($s->{sf}->{$f})) {
504                                    map {
505                                            $o .= sprintf(" %s:%d%s", $_,
506                                                    $s->{sf}->{$f}->{$_}->{count},
507                                                    $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
508                                            );
509                                    } sort keys %{ $s->{sf}->{$f} };
510                            }
511    
512                            if (my $v_r = $s->{repeatable}->{$f}) {
513                                    $o .= " ($v_r)" if ($v_r != $v);
514                            }
515    
516                            $o;
517                    } sort { $a cmp $b } keys %{ $s->{fld} }
518            );
519    
520            $log->debug( sub { Dumper($s) } );
521    
522            return $out;
523    }
524    
525    =head2 modify_record_regexps
526    
527    Generate hash with regexpes to be applied using L<filter>.
528    
529      my $regexpes = $input->modify_record_regexps(
530                    900 => { '^a' => { ' : ' => '^b' } },
531                    901 => { '*' => { '^b' => ' ; ' } },
532      );
533    
534    =cut
535    
536    sub modify_record_regexps {
537            my $self = shift;
538            my $modify_record = {@_};
539    
540            my $regexpes;
541    
542            foreach my $f (keys %$modify_record) {
543    warn "--- f: $f\n";
544                    foreach my $sf (keys %{ $modify_record->{$f} }) {
545    warn "---- sf: $sf\n";
546                            foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
547                                    my $to = $modify_record->{$f}->{$sf}->{$from};
548                                    #die "no field?" unless defined($to);
549    warn "----- transform: |$from| -> |$to|\n";
550    
551                                    if ($sf =~ /^\^/) {
552                                            my $regex =
553                                                    's/\Q'. $sf .'\E([^\^]+)\Q'. $from .'\E([^\^]+)/'. $sf .'$1'. $to .'$2/g';
554                                            push @{ $regexpes->{$f} }, $regex;
555    warn ">>>>> $regex [sf]\n";
556                                    } else {
557                                            my $regex =
558                                                    's/\Q'. $from .'\E/'. $to .'/g';
559                                            push @{ $regexpes->{$f} }, $regex;
560    warn ">>>>> $regex [global]\n";
561                                    }
562    
563                            }
564                    }
565            }
566    
567            return $regexpes;
568    }
569    
570  =head1 MEMORY USAGE  =head1 MEMORY USAGE
571    
Legend:
Removed from v.338  
changed lines
  Added in v.598
  ViewVC Help
Powered by ViewVC 1.1.26