/[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 506 by dpavlin, Mon May 15 09:59:05 2006 UTC
# Line 3  package WebPAC::Input; Line 3  package WebPAC::Input;
3  use warnings;  use warnings;
4  use strict;  use strict;
5    
 use blib;  
   
6  use WebPAC::Common;  use WebPAC::Common;
7  use base qw/WebPAC::Common/;  use base qw/WebPAC::Common/;
8  use Text::Iconv;  use Text::Iconv;
9    use Data::Dumper;
10    
11  =head1 NAME  =head1 NAME
12    
13  WebPAC::Input - core module for input file format  WebPAC::Input - read different file formats into WebPAC
14    
15  =head1 VERSION  =head1 VERSION
16    
17  Version 0.02  Version 0.05
18    
19  =cut  =cut
20    
21  our $VERSION = '0.02';  our $VERSION = '0.05';
22    
23  =head1 SYNOPSIS  =head1 SYNOPSIS
24    
25  This module is used as base class for all database specific modules  This module implements input as database which have fixed and known
26  (basically, files which have one handle, fixed size while indexing and some  I<size> while indexing and single unique numeric identifier for database
27  kind of numeric idefinirier which goes from 1 to filesize).  position ranging from 1 to I<size>.
28    
29    Simply, something that is indexed by unmber from 1 .. I<size>.
30    
31    Examples of such databases are CDS/ISIS files, MARC files, lines in
32    text file, and so on.
33    
34    Specific file formats are implemented using low-level interface modules,
35    located in C<WebPAC::Input::*> namespace which export C<open_db>,
36    C<fetch_rec> and optional C<init> functions.
37    
38  Perhaps a little code snippet.  Perhaps a little code snippet.
39    
40      use WebPAC::Input;      use WebPAC::Input;
41    
42      my $db = WebPAC::Input->new(      my $db = WebPAC::Input->new(
43          format => 'NULL',          module => 'WebPAC::Input::ISIS',
44          config => $config,                  config => $config,
45          lookup => $lookup_obj,                  lookup => $lookup_obj,
46          low_mem => 1,                  low_mem => 1,
47      );      );
48    
49      $db->open('/path/to/database');      $db->open('/path/to/database');
50      print "database size: ",$db->size,"\n";          print "database size: ",$db->size,"\n";
51      while (my $row = $db->fetch) {          while (my $rec = $db->fetch) {
52          ...                  # do something with $rec
53      }          }
54    
55    
56    
57  =head1 FUNCTIONS  =head1 FUNCTIONS
58    
# Line 51  Perhaps a little code snippet. Line 61  Perhaps a little code snippet.
61  Create new input database object.  Create new input database object.
62    
63    my $db = new WebPAC::Input(    my $db = new WebPAC::Input(
64          format => 'NULL'          module => 'WebPAC::Input::MARC',
65          code_page => 'ISO-8859-2',          code_page => '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
72    L<WebPAC::Input::MARC>.
73    
74  Optional parametar C<code_page> specify application code page (which will be  Optional parametar C<code_page> 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 74  sub new { Line 94  sub new {
94    
95          my $log = $self->_get_logger;          my $log = $self->_get_logger;
96    
97            $log->logconfess("specify low-level file format module") unless ($self->{module});
98            my $module = $self->{module};
99            $module =~ s#::#/#g;
100            $module .= '.pm';
101            $log->debug("require low-level module $self->{module} from $module");
102    
103            require $module;
104            #eval $self->{module} .'->import';
105    
106          # check if required subclasses are implemented          # check if required subclasses are implemented
107          foreach my $subclass (qw/open_db fetch_rec/) {          foreach my $subclass (qw/open_db fetch_rec init/) {
108                  $log->logdie("missing implementation of $subclass") unless ($self->SUPER::can($subclass));                  my $n = $self->{module} . '::' . $subclass;
109                    if (! defined &{ $n }) {
110                            my $missing = "missing $subclass in $self->{module}";
111                            $self->{$subclass} = sub { $log->logwarn($missing) };
112                    } else {
113                            $self->{$subclass} = \&{ $n };
114                    }
115          }          }
116    
117          if ($self->can('init')) {          if ($self->{init}) {
118                  $log->debug("calling init");                  $log->debug("calling init");
119                  $self->init(@_);                  $self->{init}->($self, @_);
120          }          }
121    
122          $self->{'code_page'} ||= 'ISO-8859-2';          $self->{'code_page'} ||= 'ISO-8859-2';
# Line 119  sub new { Line 154  sub new {
154    
155  This function will read whole database in memory and produce lookups.  This function will read whole database in memory and produce lookups.
156    
157   $isis->open(   $input->open(
158          path => '/path/to/database/file',          path => '/path/to/database/file',
159          code_page => '852',          code_page => '852',
160          limit_mfn => 500,          limit => 500,
161          start_mfn => 6000,          offset => 6000,
162          lookup => $lookup_obj,          lookup => $lookup_obj,
163            stats => 1,
164   );   );
165    
166  By default, C<code_page> is assumed to be C<852>.  By default, C<code_page> is assumed to be C<852>.
167    
168  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.
 from database (so you can skip beginning of your database if you need to).  
169    
170  If optional parametar C<limit_mfn> is set, it will read just 500 records  C<limit> is optional parametar to read just C<limit> records from database
 from database in example above.  
171    
172  Returns size of database, regardless of C<start_mfn> and C<limit_mfn>  C<stats> create optional report about usage of fields and subfields
173  parametars, see also C<$isis->size>.  
174    Returns size of database, regardless of C<offset> and C<limit>
175    parametars, see also C<size>.
176    
177  =cut  =cut
178    
# Line 150  sub open { Line 186  sub open {
186          my $code_page = $arg->{'code_page'} || '852';          my $code_page = $arg->{'code_page'} || '852';
187    
188          # store data in object          # store data in object
189          $self->{'code_page'} = $code_page;          $self->{'input_code_page'} = $code_page;
190          foreach my $v (qw/path start_mfn limit_mfn/) {          foreach my $v (qw/path offset limit/) {
191                  $self->{$v} = $arg->{$v} if ($arg->{$v});                  $self->{$v} = $arg->{$v} if ($arg->{$v});
192          }          }
193    
194          # create Text::Iconv object          # create Text::Iconv object
195          $self->{iconv} = Text::Iconv->new($code_page,$self->{'code_page'});          $self->{iconv} = Text::Iconv->new($code_page,$self->{'code_page'});
196    
197          my ($db, $size) = $self->open_db(          my $filter_ref;
198    
199            if ($self->{recode}) {
200                    my @r = split(/\s/, $self->{recode});
201                    if ($#r % 2 != 1) {
202                            $log->logwarn("recode needs even number of elements (some number of valid pairs)");
203                    } else {
204                            my $recode;
205                            while (@r) {
206                                    my $from = shift @r;
207                                    my $to = shift @r;
208                                    $recode->{$from} = $to;
209                            }
210    
211                            my $regex = join '|' => keys %{ $recode };
212    
213                            $log->debug("using recode regex: $regex");
214                            
215                            $filter_ref = sub {
216                                    my $t = shift;
217                                    $t =~ s/($regex)/$recode->{$1}/g;
218                                    return $t;
219                            };
220    
221                    }
222    
223            }
224    
225            my ($db, $size) = $self->{open_db}->( $self,
226                  path => $arg->{path},                  path => $arg->{path},
227                    filter => $filter_ref,
228          );          );
229    
230          unless ($db) {          unless (defined($db)) {
231                  $log->logwarn("can't open database $arg->{path}, skipping...");                  $log->logwarn("can't open database $arg->{path}, skipping...");
232                  return;                  return;
233          }          }
# Line 172  sub open { Line 237  sub open {
237                  return;                  return;
238          }          }
239    
240          my $startmfn = 1;          my $from_rec = 1;
241          my $maxmfn = $size;          my $to_rec = $size;
242    
243          if (my $s = $self->{start_mfn}) {          if (my $s = $self->{offset}) {
244                  $log->info("skipping to MFN $s");                  $log->info("skipping to MFN $s");
245                  $startmfn = $s;                  $from_rec = $s;
246          } else {          } else {
247                  $self->{start_mfn} = $startmfn;                  $self->{offset} = $from_rec;
248          }          }
249    
250          if ($self->{limit_mfn}) {          if ($self->{limit}) {
251                  $log->info("limiting to ",$self->{limit_mfn}," records");                  $log->debug("limiting to ",$self->{limit}," records");
252                  $maxmfn = $startmfn + $self->{limit_mfn} - 1;                  $to_rec = $from_rec + $self->{limit} - 1;
253                  $maxmfn = $size if ($maxmfn > $size);                  $to_rec = $size if ($to_rec > $size);
254          }          }
255    
256          # store size for later          # store size for later
257          $self->{size} = ($maxmfn - $startmfn) ? ($maxmfn - $startmfn + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
258    
259          $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]' : '');
260    
261          # read database          # read database
262          for (my $mfn = $startmfn; $mfn <= $maxmfn; $mfn++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
263    
264                  $log->debug("mfn: $mfn\n");                  $log->debug("position: $pos\n");
265    
266                  my $rec = $self->fetch_rec( $db, $mfn );                  my $rec = $self->{fetch_rec}->($self, $db, $pos );
267    
268                    $log->debug(sub { Dumper($rec) });
269    
270                  if (! $rec) {                  if (! $rec) {
271                          $log->warn("record $mfn empty? skipping...");                          $log->warn("record $pos empty? skipping...");
272                          next;                          next;
273                  }                  }
274    
275                  # store                  # store
276                  if ($self->{'low_mem'}) {                  if ($self->{low_mem}) {
277                          $self->{'db'}->put($mfn, $rec);                          $self->{db}->put($pos, $rec);
278                  } else {                  } else {
279                          $self->{'data'}->{$mfn} = $rec;                          $self->{data}->{$pos} = $rec;
280                  }                  }
281    
282                  # create lookup                  # create lookup
283                  $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});                  $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});
284    
285                  $self->progress_bar($mfn,$maxmfn);                  # update counters for statistics
286                    if ($self->{stats}) {
287                            map {
288                                    my $fld = $_;
289                                    $self->{_stats}->{fld}->{ $fld }++;
290                                    if (ref($rec->{ $fld }) eq 'ARRAY') {
291                                            map {
292                                                    if (ref($_) eq 'HASH') {
293                                                            map {
294                                                                    $self->{_stats}->{sf}->{ $fld }->{ $_ }++;
295                                                            } keys %{ $_ };
296                                                    } else {
297                                                            $self->{_stats}->{repeatable}->{ $fld }++;
298                                                    }
299                                            } @{ $rec->{$fld} };
300                                    }
301                            } keys %{ $rec };
302                    }
303    
304                    $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
305    
306          }          }
307    
308          $self->{'current_mfn'} = -1;          $self->{pos} = -1;
309          $self->{'last_pcnt'} = 0;          $self->{last_pcnt} = 0;
   
         $log->debug("max mfn: $maxmfn");  
310    
311          # store max mfn and return it.          # store max mfn and return it.
312          $self->{'max_mfn'} = $maxmfn;          $self->{max_pos} = $to_rec;
313            $log->debug("max_pos: $to_rec");
314    
315          return $size;          return $size;
316  }  }
# Line 246  sub fetch { Line 331  sub fetch {
331    
332          my $log = $self->_get_logger();          my $log = $self->_get_logger();
333    
334          $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});
335    
336          if ($self->{'current_mfn'} == -1) {          if ($self->{pos} == -1) {
337                  $self->{'current_mfn'} = $self->{'start_mfn'};                  $self->{pos} = $self->{offset};
338          } else {          } else {
339                  $self->{'current_mfn'}++;                  $self->{pos}++;
340          }          }
341    
342          my $mfn = $self->{'current_mfn'};          my $mfn = $self->{pos};
343    
344          if ($mfn > $self->{'max_mfn'}) {          if ($mfn > $self->{max_pos}) {
345                  $self->{'current_mfn'} = $self->{'max_mfn'};                  $self->{pos} = $self->{max_pos};
346                  $log->debug("at EOF");                  $log->debug("at EOF");
347                  return;                  return;
348          }          }
349    
350          $self->progress_bar($mfn,$self->{'max_mfn'});          $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
351    
352          my $rec;          my $rec;
353    
354          if ($self->{'low_mem'}) {          if ($self->{low_mem}) {
355                  $rec = $self->{'db'}->get($mfn);                  $rec = $self->{db}->get($mfn);
356          } else {          } else {
357                  $rec = $self->{'data'}->{$mfn};                  $rec = $self->{data}->{$mfn};
358          }          }
359    
360          $rec ||= 0E0;          $rec ||= 0E0;
# Line 287  First record in database has position 1. Line 372  First record in database has position 1.
372    
373  sub pos {  sub pos {
374          my $self = shift;          my $self = shift;
375          return $self->{'current_mfn'};          return $self->{pos};
376  }  }
377    
378    
# Line 301  Result from this function can be used to Line 386  Result from this function can be used to
386    
387   foreach my $mfn ( 1 ... $isis->size ) { ... }   foreach my $mfn ( 1 ... $isis->size ) { ... }
388    
389  because it takes into account C<start_mfn> and C<limit_mfn>.  because it takes into account C<offset> and C<limit>.
390    
391  =cut  =cut
392    
393  sub size {  sub size {
394          my $self = shift;          my $self = shift;
395          return $self->{'size'};          return $self->{size};
396  }  }
397    
398  =head2 seek  =head2 seek
# Line 329  sub seek { Line 414  sub seek {
414          if ($pos < 1) {          if ($pos < 1) {
415                  $log->warn("seek before first record");                  $log->warn("seek before first record");
416                  $pos = 1;                  $pos = 1;
417          } elsif ($pos > $self->{'max_mfn'}) {          } elsif ($pos > $self->{max_pos}) {
418                  $log->warn("seek beyond last record");                  $log->warn("seek beyond last record");
419                  $pos = $self->{'max_mfn'};                  $pos = $self->{max_pos};
420          }          }
421    
422          return $self->{'current_mfn'} = (($pos - 1) || -1);          return $self->{pos} = (($pos - 1) || -1);
423  }  }
424    
425    =head2 stats
426    
427    Dump statistics about field and subfield usage
428    
429      print Dumper( $input->stats );
430    
431    =cut
432    
433    sub stats {
434            my $self = shift;
435            return $self->{_stats};
436    }
437    
438  =head1 MEMORY USAGE  =head1 MEMORY USAGE
439    
Legend:
Removed from v.285  
changed lines
  Added in v.506
  ViewVC Help
Powered by ViewVC 1.1.26