/[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 523 by dpavlin, Sun May 21 19:29:26 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.05
20    
21  =cut  =cut
22    
23  our $VERSION = '0.02';  our $VERSION = '0.05';
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,                  lookup => $lookup_obj,
48          low_mem => 1,                  low_mem => 1,
49      );      );
50    
51      $db->open('/path/to/database');      $db->open('/path/to/database');
52      print "database size: ",$db->size,"\n";          print "database size: ",$db->size,"\n";
53      while (my $row = $db->fetch) {          while (my $rec = $db->fetch) {
54          ...                  # do something with $rec
55      }          }
56    
57    
58    
59  =head1 FUNCTIONS  =head1 FUNCTIONS
60    
# Line 51  Perhaps a little code snippet. Line 63  Perhaps a little code snippet.
63  Create new input database object.  Create new input database object.
64    
65    my $db = new WebPAC::Input(    my $db = new WebPAC::Input(
66          format => 'NULL'          module => 'WebPAC::Input::MARC',
67          code_page => 'ISO-8859-2',          code_page => 'ISO-8859-2',
68          low_mem => 1,          low_mem => 1,
69            recode => 'char pairs',
70            no_progress_bar => 1,
71    );    );
72    
73    C<module> is low-level file format module. See L<WebPAC::Input::Isis> and
74    L<WebPAC::Input::MARC>.
75    
76  Optional parametar C<code_page> specify application code page (which will be  Optional parametar C<code_page> specify application code page (which will be
77  used internally). This should probably be your terminal encoding, and by  used internally). This should probably be your terminal encoding, and by
78  default, it C<ISO-8859-2>.  default, it C<ISO-8859-2>.
79    
80  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).
81    
82    C<recode> is optional string constisting of character or words pairs that
83    should be replaced in input stream.
84    
85    C<no_progress_bar> disables progress bar output on C<STDOUT>
86    
87  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
88  parametars.  parametars.
89    
# Line 74  sub new { Line 96  sub new {
96    
97          my $log = $self->_get_logger;          my $log = $self->_get_logger;
98    
99            $log->logconfess("specify low-level file format module") unless ($self->{module});
100            my $module = $self->{module};
101            $module =~ s#::#/#g;
102            $module .= '.pm';
103            $log->debug("require low-level module $self->{module} from $module");
104    
105            require $module;
106            #eval $self->{module} .'->import';
107    
108          # check if required subclasses are implemented          # check if required subclasses are implemented
109          foreach my $subclass (qw/open_db fetch_rec/) {          foreach my $subclass (qw/open_db fetch_rec init/) {
110                  $log->logdie("missing implementation of $subclass") unless ($self->SUPER::can($subclass));                  my $n = $self->{module} . '::' . $subclass;
111                    if (! defined &{ $n }) {
112                            my $missing = "missing $subclass in $self->{module}";
113                            $self->{$subclass} = sub { $log->logwarn($missing) };
114                    } else {
115                            $self->{$subclass} = \&{ $n };
116                    }
117          }          }
118    
119          if ($self->can('init')) {          if ($self->{init}) {
120                  $log->debug("calling init");                  $log->debug("calling init");
121                  $self->init(@_);                  $self->{init}->($self, @_);
122          }          }
123    
124          $self->{'code_page'} ||= 'ISO-8859-2';          $self->{'code_page'} ||= 'ISO-8859-2';
# Line 119  sub new { Line 156  sub new {
156    
157  This function will read whole database in memory and produce lookups.  This function will read whole database in memory and produce lookups.
158    
159   $isis->open(   $input->open(
160          path => '/path/to/database/file',          path => '/path/to/database/file',
161          code_page => '852',          code_page => '852',
162          limit_mfn => 500,          limit => 500,
163          start_mfn => 6000,          offset => 6000,
164          lookup => $lookup_obj,          lookup => $lookup_obj,
165            stats => 1,
166   );   );
167    
168  By default, C<code_page> is assumed to be C<852>.  By default, C<code_page> is assumed to be C<852>.
169    
170  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.
171  from database (so you can skip beginning of your database if you need to).  
172    C<limit> is optional parametar to read just C<limit> records from database
173    
174  If optional parametar C<limit_mfn> is set, it will read just 500 records  C<stats> create optional report about usage of fields and subfields
 from database in example above.  
175    
176  Returns size of database, regardless of C<start_mfn> and C<limit_mfn>  Returns size of database, regardless of C<offset> and C<limit>
177  parametars, see also C<$isis->size>.  parametars, see also C<size>.
178    
179  =cut  =cut
180    
# Line 150  sub open { Line 188  sub open {
188          my $code_page = $arg->{'code_page'} || '852';          my $code_page = $arg->{'code_page'} || '852';
189    
190          # store data in object          # store data in object
191          $self->{'code_page'} = $code_page;          $self->{'input_code_page'} = $code_page;
192          foreach my $v (qw/path start_mfn limit_mfn/) {          foreach my $v (qw/path offset limit/) {
193                  $self->{$v} = $arg->{$v} if ($arg->{$v});                  $self->{$v} = $arg->{$v} if ($arg->{$v});
194          }          }
195    
196          # create Text::Iconv object          # create Text::Iconv object
197          $self->{iconv} = Text::Iconv->new($code_page,$self->{'code_page'});          $self->{iconv} = Text::Iconv->new($code_page,$self->{'code_page'});
198    
199          my ($db, $size) = $self->open_db(          my $filter_ref;
200    
201            if ($self->{recode}) {
202                    my @r = split(/\s/, $self->{recode});
203                    if ($#r % 2 != 1) {
204                            $log->logwarn("recode needs even number of elements (some number of valid pairs)");
205                    } else {
206                            my $recode;
207                            while (@r) {
208                                    my $from = shift @r;
209                                    my $to = shift @r;
210                                    $recode->{$from} = $to;
211                            }
212    
213                            my $regex = join '|' => keys %{ $recode };
214    
215                            $log->debug("using recode regex: $regex");
216                            
217                            $filter_ref = sub {
218                                    my $t = shift;
219                                    $t =~ s/($regex)/$recode->{$1}/g;
220                                    return $t;
221                            };
222    
223                    }
224    
225            }
226    
227            my ($db, $size) = $self->{open_db}->( $self,
228                  path => $arg->{path},                  path => $arg->{path},
229                    filter => $filter_ref,
230                    %{ $arg },
231          );          );
232    
233          unless ($db) {          unless (defined($db)) {
234                  $log->logwarn("can't open database $arg->{path}, skipping...");                  $log->logwarn("can't open database $arg->{path}, skipping...");
235                  return;                  return;
236          }          }
# Line 172  sub open { Line 240  sub open {
240                  return;                  return;
241          }          }
242    
243          my $startmfn = 1;          my $from_rec = 1;
244          my $maxmfn = $size;          my $to_rec = $size;
245    
246          if (my $s = $self->{start_mfn}) {          if (my $s = $self->{offset}) {
247                  $log->info("skipping to MFN $s");                  $log->debug("skipping to MFN $s");
248                  $startmfn = $s;                  $from_rec = $s;
249          } else {          } else {
250                  $self->{start_mfn} = $startmfn;                  $self->{offset} = $from_rec;
251          }          }
252    
253          if ($self->{limit_mfn}) {          if ($self->{limit}) {
254                  $log->info("limiting to ",$self->{limit_mfn}," records");                  $log->debug("limiting to ",$self->{limit}," records");
255                  $maxmfn = $startmfn + $self->{limit_mfn} - 1;                  $to_rec = $from_rec + $self->{limit} - 1;
256                  $maxmfn = $size if ($maxmfn > $size);                  $to_rec = $size if ($to_rec > $size);
257          }          }
258    
259          # store size for later          # store size for later
260          $self->{size} = ($maxmfn - $startmfn) ? ($maxmfn - $startmfn + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
261    
262          $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->{code_page}", $self->{stats} ? ' [stats]' : '');
263    
264          # read database          # read database
265          for (my $mfn = $startmfn; $mfn <= $maxmfn; $mfn++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
266    
267                  $log->debug("mfn: $mfn\n");                  $log->debug("position: $pos\n");
268    
269                  my $rec = $self->fetch_rec( $db, $mfn );                  my $rec = $self->{fetch_rec}->($self, $db, $pos );
270    
271                    $log->debug(sub { Dumper($rec) });
272    
273                  if (! $rec) {                  if (! $rec) {
274                          $log->warn("record $mfn empty? skipping...");                          $log->warn("record $pos empty? skipping...");
275                          next;                          next;
276                  }                  }
277    
278                  # store                  # store
279                  if ($self->{'low_mem'}) {                  if ($self->{low_mem}) {
280                          $self->{'db'}->put($mfn, $rec);                          $self->{db}->put($pos, $rec);
281                  } else {                  } else {
282                          $self->{'data'}->{$mfn} = $rec;                          $self->{data}->{$pos} = $rec;
283                  }                  }
284    
285                  # create lookup                  # create lookup
286                  $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});                  $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});
287    
288                  $self->progress_bar($mfn,$maxmfn);                  # update counters for statistics
289                    if ($self->{stats}) {
290                            map {
291                                    my $fld = $_;
292                                    $self->{_stats}->{fld}->{ $fld }++;
293                                    if (ref($rec->{ $fld }) eq 'ARRAY') {
294                                            map {
295                                                    if (ref($_) eq 'HASH') {
296                                                            map {
297                                                                    $self->{_stats}->{sf}->{ $fld }->{ $_ }++;
298                                                            } keys %{ $_ };
299                                                    } else {
300                                                            $self->{_stats}->{repeatable}->{ $fld }++;
301                                                    }
302                                            } @{ $rec->{$fld} };
303                                    }
304                            } keys %{ $rec };
305                    }
306    
307          }                  $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
308    
309          $self->{'current_mfn'} = -1;          }
         $self->{'last_pcnt'} = 0;  
310    
311          $log->debug("max mfn: $maxmfn");          $self->{pos} = -1;
312            $self->{last_pcnt} = 0;
313    
314          # store max mfn and return it.          # store max mfn and return it.
315          $self->{'max_mfn'} = $maxmfn;          $self->{max_pos} = $to_rec;
316            $log->debug("max_pos: $to_rec");
317    
318          return $size;          return $size;
319  }  }
# Line 246  sub fetch { Line 334  sub fetch {
334    
335          my $log = $self->_get_logger();          my $log = $self->_get_logger();
336    
337          $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});
338    
339          if ($self->{'current_mfn'} == -1) {          if ($self->{pos} == -1) {
340                  $self->{'current_mfn'} = $self->{'start_mfn'};                  $self->{pos} = $self->{offset};
341          } else {          } else {
342                  $self->{'current_mfn'}++;                  $self->{pos}++;
343          }          }
344    
345          my $mfn = $self->{'current_mfn'};          my $mfn = $self->{pos};
346    
347          if ($mfn > $self->{'max_mfn'}) {          if ($mfn > $self->{max_pos}) {
348                  $self->{'current_mfn'} = $self->{'max_mfn'};                  $self->{pos} = $self->{max_pos};
349                  $log->debug("at EOF");                  $log->debug("at EOF");
350                  return;                  return;
351          }          }
352    
353          $self->progress_bar($mfn,$self->{'max_mfn'});          $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
354    
355          my $rec;          my $rec;
356    
357          if ($self->{'low_mem'}) {          if ($self->{low_mem}) {
358                  $rec = $self->{'db'}->get($mfn);                  $rec = $self->{db}->get($mfn);
359          } else {          } else {
360                  $rec = $self->{'data'}->{$mfn};                  $rec = $self->{data}->{$mfn};
361          }          }
362    
363          $rec ||= 0E0;          $rec ||= 0E0;
# Line 287  First record in database has position 1. Line 375  First record in database has position 1.
375    
376  sub pos {  sub pos {
377          my $self = shift;          my $self = shift;
378          return $self->{'current_mfn'};          return $self->{pos};
379  }  }
380    
381    
# Line 301  Result from this function can be used to Line 389  Result from this function can be used to
389    
390   foreach my $mfn ( 1 ... $isis->size ) { ... }   foreach my $mfn ( 1 ... $isis->size ) { ... }
391    
392  because it takes into account C<start_mfn> and C<limit_mfn>.  because it takes into account C<offset> and C<limit>.
393    
394  =cut  =cut
395    
396  sub size {  sub size {
397          my $self = shift;          my $self = shift;
398          return $self->{'size'};          return $self->{size};
399  }  }
400    
401  =head2 seek  =head2 seek
# Line 329  sub seek { Line 417  sub seek {
417          if ($pos < 1) {          if ($pos < 1) {
418                  $log->warn("seek before first record");                  $log->warn("seek before first record");
419                  $pos = 1;                  $pos = 1;
420          } elsif ($pos > $self->{'max_mfn'}) {          } elsif ($pos > $self->{max_pos}) {
421                  $log->warn("seek beyond last record");                  $log->warn("seek beyond last record");
422                  $pos = $self->{'max_mfn'};                  $pos = $self->{max_pos};
423          }          }
424    
425          return $self->{'current_mfn'} = (($pos - 1) || -1);          return $self->{pos} = (($pos - 1) || -1);
426  }  }
427    
428    =head2 stats
429    
430    Dump statistics about field and subfield usage
431    
432      print $input->stats;
433    
434    =cut
435    
436    sub stats {
437            my $self = shift;
438    
439            my $log = $self->_get_logger();
440    
441            my $s = $self->{_stats};
442            if (! $s) {
443                    $log->warn("called stats, but there is no statistics collected");
444                    return;
445            }
446    
447            my $max_fld = 0;
448    
449            my $out = join("\n",
450                    map {
451                            my $f = $_ || die "no field";
452                            my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
453                            $max_fld = $v if ($v > $max_fld);
454    
455                            my $o = sprintf("%4s %d ~", $f, $v);
456    
457                            if (defined($s->{sf}->{$f})) {
458                                    map {
459                                            $o .= sprintf(" %s:%d", $_, $s->{sf}->{$f}->{$_});
460                                    } sort keys %{ $s->{sf}->{$f} };
461                            }
462    
463                            if (my $v_r = $s->{repeatable}->{$f}) {
464                                    $o .= " ($v_r)" if ($v_r != $v);
465                            }
466    
467                            $o;
468                    } sort { $a cmp $b } keys %{ $s->{fld} }
469            );
470    
471            $log->debug( sub { Dumper($s) } );
472    
473            return $out;
474    }
475    
476  =head1 MEMORY USAGE  =head1 MEMORY USAGE
477    
Legend:
Removed from v.285  
changed lines
  Added in v.523
  ViewVC Help
Powered by ViewVC 1.1.26