/[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 285 by dpavlin, Sun Dec 18 21:06:39 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    
15  WebPAC::Input - core module for input file format  WebPAC::Input - read different file formats into WebPAC
16    
17  =head1 VERSION  =head1 VERSION
18    
19  Version 0.02  Version 0.08
20    
21  =cut  =cut
22    
23  our $VERSION = '0.02';  our $VERSION = '0.08';
24    
25  =head1 SYNOPSIS  =head1 SYNOPSIS
26    
27  This module is used as base class for all database specific modules  This module implements input as database which have fixed and known
28  (basically, files which have one handle, fixed size while indexing and some  I<size> while indexing and single unique numeric identifier for database
29  kind of numeric idefinirier which goes from 1 to filesize).  position ranging from 1 to I<size>.
30    
31    Simply, something that is indexed by unmber from 1 .. I<size>.
32    
33    Examples of such databases are CDS/ISIS files, MARC files, lines in
34    text file, and so on.
35    
36    Specific file formats are implemented using low-level interface modules,
37    located in C<WebPAC::Input::*> namespace which export C<open_db>,
38    C<fetch_rec> and optional C<init> functions.
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          format => 'NULL',          module => 'WebPAC::Input::ISIS',
46          config => $config,                  config => $config,
47          lookup => $lookup_obj,                  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 $row = $db->fetch) {          while (my $rec = $db->fetch) {
53          ...                  # do something with $rec
54      }          }
55    
56    
57    
58  =head1 FUNCTIONS  =head1 FUNCTIONS
59    
# Line 51  Perhaps a little code snippet. Line 62  Perhaps a little code snippet.
62  Create new input database object.  Create new input database object.
63    
64    my $db = new WebPAC::Input(    my $db = new WebPAC::Input(
65          format => 'NULL'          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  Optional parametar C<code_page> specify application code page (which will be  C<module> is low-level file format module. See L<WebPAC::Input::Isis> and
73    L<WebPAC::Input::MARC>.
74    
75    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 74  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});
102            my $module = $self->{module};
103            $module =~ s#::#/#g;
104            $module .= '.pm';
105            $log->debug("require low-level module $self->{module} from $module");
106    
107            require $module;
108            #eval $self->{module} .'->import';
109    
110          # check if required subclasses are implemented          # check if required subclasses are implemented
111          foreach my $subclass (qw/open_db fetch_rec/) {          foreach my $subclass (qw/open_db fetch_rec init/) {
112                  $log->logdie("missing implementation of $subclass") unless ($self->SUPER::can($subclass));                  my $n = $self->{module} . '::' . $subclass;
113                    if (! defined &{ $n }) {
114                            my $missing = "missing $subclass in $self->{module}";
115                            $self->{$subclass} = sub { $log->logwarn($missing) };
116                    } else {
117                            $self->{$subclass} = \&{ $n };
118                    }
119          }          }
120    
121          if ($self->can('init')) {          if ($self->{init}) {
122                  $log->debug("calling init");                  $log->debug("calling init");
123                  $self->init(@_);                  $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 119  sub new { Line 158  sub new {
158    
159  This function will read whole database in memory and produce lookups.  This function will read whole database in memory and produce lookups.
160    
161   $isis->open(   $input->open(
162          path => '/path/to/database/file',          path => '/path/to/database/file',
163          code_page => '852',          code_page => '852',
164          limit_mfn => 500,          limit => 500,
165          start_mfn => 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>.
175    
176  If optional parametar C<start_mfn> is set, this will be first MFN to read  C<offset> is optional parametar to position at some offset before reading from database.
177  from database (so you can skip beginning of your database if you need to).  
178    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  If optional parametar C<limit_mfn> is set, it will read just 500 records  C<lookup_coderef> is closure to call when adding key => $value combinations to
183  from database in example above.  lookup.
184    
185  Returns size of database, regardless of C<start_mfn> and C<limit_mfn>  Returns size of database, regardless of C<offset> and C<limit>
186  parametars, see also C<$isis->size>.  parametars, see also C<size>.
187    
188  =cut  =cut
189    
# Line 146  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 start_mfn limit_mfn/) {          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          my ($db, $size) = $self->open_db(          }
239    
240            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 172  sub open { Line 253  sub open {
253                  return;                  return;
254          }          }
255    
256          my $startmfn = 1;          my $from_rec = 1;
257          my $maxmfn = $size;          my $to_rec = $size;
258    
259          if (my $s = $self->{start_mfn}) {          if (my $s = $self->{offset}) {
260                  $log->info("skipping to MFN $s");                  $log->debug("skipping to MFN $s");
261                  $startmfn = $s;                  $from_rec = $s;
262          } else {          } else {
263                  $self->{start_mfn} = $startmfn;                  $self->{offset} = $from_rec;
264          }          }
265    
266          if ($self->{limit_mfn}) {          if ($self->{limit}) {
267                  $log->info("limiting to ",$self->{limit_mfn}," records");                  $log->debug("limiting to ",$self->{limit}," records");
268                  $maxmfn = $startmfn + $self->{limit_mfn} - 1;                  $to_rec = $from_rec + $self->{limit} - 1;
269                  $maxmfn = $size if ($maxmfn > $size);                  $to_rec = $size if ($to_rec > $size);
270          }          }
271    
272          # store size for later          # store size for later
273          $self->{size} = ($maxmfn - $startmfn) ? ($maxmfn - $startmfn + 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 $mfn = $startmfn; $mfn <= $maxmfn; $mfn++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
279    
280                    $log->debug("position: $pos\n");
281    
282                  $log->debug("mfn: $mfn\n");                  my $rec = $self->{fetch_rec}->($self, $db, $pos );
283    
284                  my $rec = $self->fetch_rec( $db, $mfn );                  $log->debug(sub { Dumper($rec) });
285    
286                  if (! $rec) {                  if (! $rec) {
287                          $log->warn("record $mfn empty? skipping...");                          $log->warn("record $pos empty? skipping...");
288                          next;                          next;
289                  }                  }
290    
291                  # store                  # store
292                  if ($self->{'low_mem'}) {                  if ($self->{low_mem}) {
293                          $self->{'db'}->put($mfn, $rec);                          $self->{db}->put($pos, $rec);
294                  } else {                  } else {
295                          $self->{'data'}->{$mfn} = $rec;                          $self->{data}->{$pos} = $rec;
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                  $self->progress_bar($mfn,$maxmfn);                  # 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->{'current_mfn'} = -1;                  $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
         $self->{'last_pcnt'} = 0;  
328    
329          $log->debug("max mfn: $maxmfn");          }
330    
331            $self->{pos} = -1;
332            $self->{last_pcnt} = 0;
333    
334          # store max mfn and return it.          # store max mfn and return it.
335          $self->{'max_mfn'} = $maxmfn;          $self->{max_pos} = $to_rec;
336            $log->debug("max_pos: $to_rec");
337    
338          return $size;          return $size;
339  }  }
# Line 246  sub fetch { Line 354  sub fetch {
354    
355          my $log = $self->_get_logger();          my $log = $self->_get_logger();
356    
357          $log->logconfess("it seems that you didn't load database!") unless ($self->{'current_mfn'});          $log->logconfess("it seems that you didn't load database!") unless ($self->{pos});
358    
359          if ($self->{'current_mfn'} == -1) {          if ($self->{pos} == -1) {
360                  $self->{'current_mfn'} = $self->{'start_mfn'};                  $self->{pos} = $self->{offset};
361          } else {          } else {
362                  $self->{'current_mfn'}++;                  $self->{pos}++;
363          }          }
364    
365          my $mfn = $self->{'current_mfn'};          my $mfn = $self->{pos};
366    
367          if ($mfn > $self->{'max_mfn'}) {          if ($mfn > $self->{max_pos}) {
368                  $self->{'current_mfn'} = $self->{'max_mfn'};                  $self->{pos} = $self->{max_pos};
369                  $log->debug("at EOF");                  $log->debug("at EOF");
370                  return;                  return;
371          }          }
372    
373          $self->progress_bar($mfn,$self->{'max_mfn'});          $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
374    
375          my $rec;          my $rec;
376    
377          if ($self->{'low_mem'}) {          if ($self->{low_mem}) {
378                  $rec = $self->{'db'}->get($mfn);                  $rec = $self->{db}->get($mfn);
379          } else {          } else {
380                  $rec = $self->{'data'}->{$mfn};                  $rec = $self->{data}->{$mfn};
381          }          }
382    
383          $rec ||= 0E0;          $rec ||= 0E0;
# Line 287  First record in database has position 1. Line 395  First record in database has position 1.
395    
396  sub pos {  sub pos {
397          my $self = shift;          my $self = shift;
398          return $self->{'current_mfn'};          return $self->{pos};
399  }  }
400    
401    
# Line 301  Result from this function can be used to Line 409  Result from this function can be used to
409    
410   foreach my $mfn ( 1 ... $isis->size ) { ... }   foreach my $mfn ( 1 ... $isis->size ) { ... }
411    
412  because it takes into account C<start_mfn> and C<limit_mfn>.  because it takes into account C<offset> and C<limit>.
413    
414  =cut  =cut
415    
416  sub size {  sub size {
417          my $self = shift;          my $self = shift;
418          return $self->{'size'};          return $self->{size};
419  }  }
420    
421  =head2 seek  =head2 seek
# Line 329  sub seek { Line 437  sub seek {
437          if ($pos < 1) {          if ($pos < 1) {
438                  $log->warn("seek before first record");                  $log->warn("seek before first record");
439                  $pos = 1;                  $pos = 1;
440          } elsif ($pos > $self->{'max_mfn'}) {          } elsif ($pos > $self->{max_pos}) {
441                  $log->warn("seek beyond last record");                  $log->warn("seek beyond last record");
442                  $pos = $self->{'max_mfn'};                  $pos = $self->{max_pos};
443          }          }
444    
445          return $self->{'current_mfn'} = (($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.285  
changed lines
  Added in v.593
  ViewVC Help
Powered by ViewVC 1.1.26