/[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 507 by dpavlin, Mon May 15 13:15:01 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          );          );
231    
232          unless ($db) {          unless (defined($db)) {
233                  $log->logwarn("can't open database $arg->{path}, skipping...");                  $log->logwarn("can't open database $arg->{path}, skipping...");
234                  return;                  return;
235          }          }
# Line 172  sub open { Line 239  sub open {
239                  return;                  return;
240          }          }
241    
242          my $startmfn = 1;          my $from_rec = 1;
243          my $maxmfn = $size;          my $to_rec = $size;
244    
245          if (my $s = $self->{start_mfn}) {          if (my $s = $self->{offset}) {
246                  $log->info("skipping to MFN $s");                  $log->info("skipping to MFN $s");
247                  $startmfn = $s;                  $from_rec = $s;
248          } else {          } else {
249                  $self->{start_mfn} = $startmfn;                  $self->{offset} = $from_rec;
250          }          }
251    
252          if ($self->{limit_mfn}) {          if ($self->{limit}) {
253                  $log->info("limiting to ",$self->{limit_mfn}," records");                  $log->debug("limiting to ",$self->{limit}," records");
254                  $maxmfn = $startmfn + $self->{limit_mfn} - 1;                  $to_rec = $from_rec + $self->{limit} - 1;
255                  $maxmfn = $size if ($maxmfn > $size);                  $to_rec = $size if ($to_rec > $size);
256          }          }
257    
258          # store size for later          # store size for later
259          $self->{size} = ($maxmfn - $startmfn) ? ($maxmfn - $startmfn + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
260    
261          $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]' : '');
262    
263          # read database          # read database
264          for (my $mfn = $startmfn; $mfn <= $maxmfn; $mfn++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
265    
266                  $log->debug("mfn: $mfn\n");                  $log->debug("position: $pos\n");
267    
268                  my $rec = $self->fetch_rec( $db, $mfn );                  my $rec = $self->{fetch_rec}->($self, $db, $pos );
269    
270                    $log->debug(sub { Dumper($rec) });
271    
272                  if (! $rec) {                  if (! $rec) {
273                          $log->warn("record $mfn empty? skipping...");                          $log->warn("record $pos empty? skipping...");
274                          next;                          next;
275                  }                  }
276    
277                  # store                  # store
278                  if ($self->{'low_mem'}) {                  if ($self->{low_mem}) {
279                          $self->{'db'}->put($mfn, $rec);                          $self->{db}->put($pos, $rec);
280                  } else {                  } else {
281                          $self->{'data'}->{$mfn} = $rec;                          $self->{data}->{$pos} = $rec;
282                  }                  }
283    
284                  # create lookup                  # create lookup
285                  $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});                  $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});
286    
287                  $self->progress_bar($mfn,$maxmfn);                  # update counters for statistics
288                    if ($self->{stats}) {
289                            map {
290                                    my $fld = $_;
291                                    $self->{_stats}->{fld}->{ $fld }++;
292                                    if (ref($rec->{ $fld }) eq 'ARRAY') {
293                                            map {
294                                                    if (ref($_) eq 'HASH') {
295                                                            map {
296                                                                    $self->{_stats}->{sf}->{ $fld }->{ $_ }++;
297                                                            } keys %{ $_ };
298                                                    } else {
299                                                            $self->{_stats}->{repeatable}->{ $fld }++;
300                                                    }
301                                            } @{ $rec->{$fld} };
302                                    }
303                            } keys %{ $rec };
304                    }
305    
306          }                  $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
307    
308          $self->{'current_mfn'} = -1;          }
         $self->{'last_pcnt'} = 0;  
309    
310          $log->debug("max mfn: $maxmfn");          $self->{pos} = -1;
311            $self->{last_pcnt} = 0;
312    
313          # store max mfn and return it.          # store max mfn and return it.
314          $self->{'max_mfn'} = $maxmfn;          $self->{max_pos} = $to_rec;
315            $log->debug("max_pos: $to_rec");
316    
317          return $size;          return $size;
318  }  }
# Line 246  sub fetch { Line 333  sub fetch {
333    
334          my $log = $self->_get_logger();          my $log = $self->_get_logger();
335    
336          $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});
337    
338          if ($self->{'current_mfn'} == -1) {          if ($self->{pos} == -1) {
339                  $self->{'current_mfn'} = $self->{'start_mfn'};                  $self->{pos} = $self->{offset};
340          } else {          } else {
341                  $self->{'current_mfn'}++;                  $self->{pos}++;
342          }          }
343    
344          my $mfn = $self->{'current_mfn'};          my $mfn = $self->{pos};
345    
346          if ($mfn > $self->{'max_mfn'}) {          if ($mfn > $self->{max_pos}) {
347                  $self->{'current_mfn'} = $self->{'max_mfn'};                  $self->{pos} = $self->{max_pos};
348                  $log->debug("at EOF");                  $log->debug("at EOF");
349                  return;                  return;
350          }          }
351    
352          $self->progress_bar($mfn,$self->{'max_mfn'});          $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
353    
354          my $rec;          my $rec;
355    
356          if ($self->{'low_mem'}) {          if ($self->{low_mem}) {
357                  $rec = $self->{'db'}->get($mfn);                  $rec = $self->{db}->get($mfn);
358          } else {          } else {
359                  $rec = $self->{'data'}->{$mfn};                  $rec = $self->{data}->{$mfn};
360          }          }
361    
362          $rec ||= 0E0;          $rec ||= 0E0;
# Line 287  First record in database has position 1. Line 374  First record in database has position 1.
374    
375  sub pos {  sub pos {
376          my $self = shift;          my $self = shift;
377          return $self->{'current_mfn'};          return $self->{pos};
378  }  }
379    
380    
# Line 301  Result from this function can be used to Line 388  Result from this function can be used to
388    
389   foreach my $mfn ( 1 ... $isis->size ) { ... }   foreach my $mfn ( 1 ... $isis->size ) { ... }
390    
391  because it takes into account C<start_mfn> and C<limit_mfn>.  because it takes into account C<offset> and C<limit>.
392    
393  =cut  =cut
394    
395  sub size {  sub size {
396          my $self = shift;          my $self = shift;
397          return $self->{'size'};          return $self->{size};
398  }  }
399    
400  =head2 seek  =head2 seek
# Line 329  sub seek { Line 416  sub seek {
416          if ($pos < 1) {          if ($pos < 1) {
417                  $log->warn("seek before first record");                  $log->warn("seek before first record");
418                  $pos = 1;                  $pos = 1;
419          } elsif ($pos > $self->{'max_mfn'}) {          } elsif ($pos > $self->{max_pos}) {
420                  $log->warn("seek beyond last record");                  $log->warn("seek beyond last record");
421                  $pos = $self->{'max_mfn'};                  $pos = $self->{max_pos};
422          }          }
423    
424          return $self->{'current_mfn'} = (($pos - 1) || -1);          return $self->{pos} = (($pos - 1) || -1);
425  }  }
426    
427    =head2 stats
428    
429    Dump statistics about field and subfield usage
430    
431      print $input->stats;
432    
433    =cut
434    
435    sub stats {
436            my $self = shift;
437    
438            my $log = $self->_get_logger();
439    
440            my $s = $self->{_stats};
441            if (! $s) {
442                    $log->warn("called stats, but there is no statistics collected");
443                    return;
444            }
445    
446            my $max_fld = 0;
447    
448            my $out = join("\n",
449                    map {
450                            my $f = $_ || die "no field";
451                            my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
452                            $max_fld = $v if ($v > $max_fld);
453    
454                            my $o = sprintf("%4d %d ~", $f, $v);
455    
456                            if (defined($s->{sf}->{$f})) {
457                                    map {
458                                            $o .= sprintf(" %s:%d", $_, $s->{sf}->{$f}->{$_});
459                                    } sort keys %{ $s->{sf}->{$f} };
460                            }
461    
462                            if (my $v_r = $s->{repeatable}->{$f}) {
463                                    $o .= " ($v_r)" if ($v_r != $v);
464                            }
465    
466                            $o;
467                    } sort { $a <=> $b } keys %{ $s->{fld} }
468            );
469    
470            $log->debug( sub { Dumper($s) } );
471    
472            return $out;
473    }
474    
475  =head1 MEMORY USAGE  =head1 MEMORY USAGE
476    
Legend:
Removed from v.285  
changed lines
  Added in v.507
  ViewVC Help
Powered by ViewVC 1.1.26