/[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 290 by dpavlin, Sun Dec 18 23:10:02 2005 UTC revision 593 by dpavlin, Sun Jul 9 15:22:39 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.08
20    
21  =cut  =cut
22    
23  our $VERSION = '0.03';  our $VERSION = '0.08';
24    
25  =head1 SYNOPSIS  =head1 SYNOPSIS
26    
# Line 43  Perhaps a little code snippet. Line 44  Perhaps a little code snippet.
44      my $db = WebPAC::Input->new(      my $db = WebPAC::Input->new(
45          module => 'WebPAC::Input::ISIS',          module => 'WebPAC::Input::ISIS',
46                  config => $config,                  config => $config,
                 lookup => $lookup_obj,  
47                  low_mem => 1,                  low_mem => 1,
48      );      );
49    
50      $db->open('/path/to/database');      $db->open('/path/to/database');
51      print "database size: ",$db->size,"\n";          print "database size: ",$db->size,"\n";
52      while (my $rec = $db->fetch) {          while (my $rec = $db->fetch) {
53      }                  # do something with $rec
54            }
55    
56    
57    
# Line 62  Create new input database object. Line 63  Create new input database object.
63    
64    my $db = new WebPAC::Input(    my $db = new WebPAC::Input(
65          module => 'WebPAC::Input::MARC',          module => 'WebPAC::Input::MARC',
66          code_page => 'ISO-8859-2',          encoding => 'ISO-8859-2',
67          low_mem => 1,          low_mem => 1,
68            recode => 'char pairs',
69            no_progress_bar => 1,
70    );    );
71    
72  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
73  L<WebPAC::Input::MARC>.  L<WebPAC::Input::MARC>.
74    
75  Optional parametar C<code_page> specify application code page (which will be  Optional parametar C<encoding> specify application code page (which will be
76  used internally). This should probably be your terminal encoding, and by  used internally). This should probably be your terminal encoding, and by
77  default, it C<ISO-8859-2>.  default, it C<ISO-8859-2>.
78    
79  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).
80    
81    C<recode> is optional string constisting of character or words pairs that
82    should be replaced in input stream.
83    
84    C<no_progress_bar> disables progress bar output on C<STDOUT>
85    
86  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
87  parametars.  parametars.
88    
# Line 87  sub new { Line 95  sub new {
95    
96          my $log = $self->_get_logger;          my $log = $self->_get_logger;
97    
98            $log->logconfess("code_page argument is not suppored any more. change it to encoding") if ($self->{lookup});
99            $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if ($self->{lookup});
100    
101          $log->logconfess("specify low-level file format module") unless ($self->{module});          $log->logconfess("specify low-level file format module") unless ($self->{module});
102          my $module = $self->{module};          my $module = $self->{module};
103          $module =~ s#::#/#g;          $module =~ s#::#/#g;
# Line 101  sub new { Line 112  sub new {
112                  my $n = $self->{module} . '::' . $subclass;                  my $n = $self->{module} . '::' . $subclass;
113                  if (! defined &{ $n }) {                  if (! defined &{ $n }) {
114                          my $missing = "missing $subclass in $self->{module}";                          my $missing = "missing $subclass in $self->{module}";
115                          $log->logwarn($missing);                          $self->{$subclass} = sub { $log->logwarn($missing) };
                         $self->{$subclass} = sub { warn "$missing\n" };  
116                  } else {                  } else {
117                          $self->{$subclass} = \&{ $n };                          $self->{$subclass} = \&{ $n };
118                  }                  }
# Line 113  sub new { Line 123  sub new {
123                  $self->{init}->($self, @_);                  $self->{init}->($self, @_);
124          }          }
125    
126          $self->{'code_page'} ||= 'ISO-8859-2';          $self->{'encoding'} ||= 'ISO-8859-2';
127    
128          # running with low_mem flag? well, use DBM::Deep then.          # running with low_mem flag? well, use DBM::Deep then.
129          if ($self->{'low_mem'}) {          if ($self->{'low_mem'}) {
# Line 154  This function will read whole database i Line 164  This function will read whole database i
164          limit => 500,          limit => 500,
165          offset => 6000,          offset => 6000,
166          lookup => $lookup_obj,          lookup => $lookup_obj,
167            stats => 1,
168            lookup_ref => sub {
169                    my ($k,$v) = @_;
170                    # store lookup $k => $v
171            },
172   );   );
173    
174  By default, C<code_page> is assumed to be C<852>.  By default, C<code_page> is assumed to be C<852>.
# Line 162  C<offset> is optional parametar to posit Line 177  C<offset> is optional parametar to posit
177    
178  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
179    
180    C<stats> create optional report about usage of fields and subfields
181    
182    C<lookup_coderef> is closure to call when adding key => $value combinations to
183    lookup.
184    
185  Returns size of database, regardless of C<offset> and C<limit>  Returns size of database, regardless of C<offset> and C<limit>
186  parametars, see also C<size>.  parametars, see also C<size>.
187    
# Line 173  sub open { Line 193  sub open {
193    
194          my $log = $self->_get_logger();          my $log = $self->_get_logger();
195    
196            $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_coderef") if ($arg->{lookup});
197            $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
198                    if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
199    
200          $log->logcroak("need path") if (! $arg->{'path'});          $log->logcroak("need path") if (! $arg->{'path'});
201          my $code_page = $arg->{'code_page'} || '852';          my $code_page = $arg->{'code_page'} || '852';
202    
203          # store data in object          # store data in object
204          $self->{'code_page'} = $code_page;          $self->{'input_code_page'} = $code_page;
205          foreach my $v (qw/path offset limit/) {          foreach my $v (qw/path offset limit/) {
206                  $self->{$v} = $arg->{$v} if ($arg->{$v});                  $self->{$v} = $arg->{$v} if ($arg->{$v});
207          }          }
208    
209          # create Text::Iconv object          # create Text::Iconv object
210          $self->{iconv} = Text::Iconv->new($code_page,$self->{'code_page'});          $self->{iconv} = Text::Iconv->new($code_page,$self->{'encoding'});      ## FIXME remove!
211    
212            my $filter_ref;
213    
214            if ($self->{recode}) {
215                    my @r = split(/\s/, $self->{recode});
216                    if ($#r % 2 != 1) {
217                            $log->logwarn("recode needs even number of elements (some number of valid pairs)");
218                    } else {
219                            my $recode;
220                            while (@r) {
221                                    my $from = shift @r;
222                                    my $to = shift @r;
223                                    $recode->{$from} = $to;
224                            }
225    
226                            my $regex = join '|' => keys %{ $recode };
227    
228                            $log->debug("using recode regex: $regex");
229                            
230                            $filter_ref = sub {
231                                    my $t = shift;
232                                    $t =~ s/($regex)/$recode->{$1}/g;
233                                    return $t;
234                            };
235    
236                    }
237    
238            }
239    
240          my ($db, $size) = $self->{open_db}->( $self,          my ($db, $size) = $self->{open_db}->( $self,
241                  path => $arg->{path},                  path => $arg->{path},
242                    filter => $filter_ref,
243                    %{ $arg },
244          );          );
245    
246          unless ($db) {          unless (defined($db)) {
247                  $log->logwarn("can't open database $arg->{path}, skipping...");                  $log->logwarn("can't open database $arg->{path}, skipping...");
248                  return;                  return;
249          }          }
# Line 199  sub open { Line 253  sub open {
253                  return;                  return;
254          }          }
255    
256          my $offset = 1;          my $from_rec = 1;
257          my $limit = $size;          my $to_rec = $size;
258    
259          if (my $s = $self->{offset}) {          if (my $s = $self->{offset}) {
260                  $log->info("skipping to MFN $s");                  $log->debug("skipping to MFN $s");
261                  $offset = $s;                  $from_rec = $s;
262          } else {          } else {
263                  $self->{offset} = $offset;                  $self->{offset} = $from_rec;
264          }          }
265    
266          if ($self->{limit}) {          if ($self->{limit}) {
267                  $log->info("limiting to ",$self->{limit}," records");                  $log->debug("limiting to ",$self->{limit}," records");
268                  $limit = $offset + $self->{limit} - 1;                  $to_rec = $from_rec + $self->{limit} - 1;
269                  $limit = $size if ($limit > $size);                  $to_rec = $size if ($to_rec > $size);
270          }          }
271    
272          # store size for later          # store size for later
273          $self->{size} = ($limit - $offset) ? ($limit - $offset + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
274    
275          $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]' : '');
276    
277          # read database          # read database
278          for (my $pos = $offset; $pos <= $limit; $pos++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
279    
280                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
281    
282                  my $rec = $self->{fetch_rec}->($self, $db, $pos );                  my $rec = $self->{fetch_rec}->($self, $db, $pos );
283    
284                    $log->debug(sub { Dumper($rec) });
285    
286                  if (! $rec) {                  if (! $rec) {
287                          $log->warn("record $pos empty? skipping...");                          $log->warn("record $pos empty? skipping...");
288                          next;                          next;
# Line 240  sub open { Line 296  sub open {
296                  }                  }
297    
298                  # create lookup                  # create lookup
299                  $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});                  $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
300    
301                    # update counters for statistics
302                    if ($self->{stats}) {
303    
304                            foreach my $fld (keys %{ $rec }) {
305                                    $self->{_stats}->{fld}->{ $fld }++;
306    
307                                    $log->logdie("invalid record fild $fld, not ARRAY")
308                                            unless (ref($rec->{ $fld }) eq 'ARRAY');
309            
310                                    foreach my $row (@{ $rec->{$fld} }) {
311    
312                                            if (ref($row) eq 'HASH') {
313    
314                                                    foreach my $sf (keys %{ $row }) {
315                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
316                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
317                                                                            if (ref($row->{$sf}) eq 'ARRAY');
318                                                    }
319    
320                                            } else {
321                                                    $self->{_stats}->{repeatable}->{ $fld }++;
322                                            }
323                                    }
324                            }
325                    }
326    
327                  $self->progress_bar($pos,$limit);                  $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
328    
329          }          }
330    
# Line 250  sub open { Line 332  sub open {
332          $self->{last_pcnt} = 0;          $self->{last_pcnt} = 0;
333    
334          # store max mfn and return it.          # store max mfn and return it.
335          $self->{max_pos} = $limit;          $self->{max_pos} = $to_rec;
336          $log->debug("max_pos: $limit");          $log->debug("max_pos: $to_rec");
337    
338          return $size;          return $size;
339  }  }
# Line 288  sub fetch { Line 370  sub fetch {
370                  return;                  return;
371          }          }
372    
373          $self->progress_bar($mfn,$self->{max_pos});          $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
374    
375          my $rec;          my $rec;
376    
# Line 363  sub seek { Line 445  sub seek {
445          return $self->{pos} = (($pos - 1) || -1);          return $self->{pos} = (($pos - 1) || -1);
446  }  }
447    
448    =head2 stats
449    
450    Dump statistics about field and subfield usage
451    
452      print $input->stats;
453    
454    =cut
455    
456    sub stats {
457            my $self = shift;
458    
459            my $log = $self->_get_logger();
460    
461            my $s = $self->{_stats};
462            if (! $s) {
463                    $log->warn("called stats, but there is no statistics collected");
464                    return;
465            }
466    
467            my $max_fld = 0;
468    
469            my $out = join("\n",
470                    map {
471                            my $f = $_ || die "no field";
472                            my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
473                            $max_fld = $v if ($v > $max_fld);
474    
475                            my $o = sprintf("%4s %d ~", $f, $v);
476    
477                            if (defined($s->{sf}->{$f})) {
478                                    map {
479                                            $o .= sprintf(" %s:%d%s", $_,
480                                                    $s->{sf}->{$f}->{$_}->{count},
481                                                    $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
482                                            );
483                                    } sort keys %{ $s->{sf}->{$f} };
484                            }
485    
486                            if (my $v_r = $s->{repeatable}->{$f}) {
487                                    $o .= " ($v_r)" if ($v_r != $v);
488                            }
489    
490                            $o;
491                    } sort { $a cmp $b } keys %{ $s->{fld} }
492            );
493    
494            $log->debug( sub { Dumper($s) } );
495    
496            return $out;
497    }
498    
499  =head1 MEMORY USAGE  =head1 MEMORY USAGE
500    
Legend:
Removed from v.290  
changed lines
  Added in v.593
  ViewVC Help
Powered by ViewVC 1.1.26