/[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 307 by dpavlin, Tue Dec 20 00:03:04 2005 UTC revision 523 by dpavlin, Sun May 21 19:29:26 2006 UTC
# Line 3  package WebPAC::Input; Line 3  package WebPAC::Input;
3  use warnings;  use warnings;
4  use strict;  use strict;
5    
6    use blib;
7    
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 13  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.05
20    
21  =cut  =cut
22    
23  our $VERSION = '0.03';  our $VERSION = '0.05';
24    
25  =head1 SYNOPSIS  =head1 SYNOPSIS
26    
# Line 46  Perhaps a little code snippet. Line 49  Perhaps a little code snippet.
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 $rec = $db->fetch) {          while (my $rec = $db->fetch) {
54      }                  # do something with $rec
55            }
56    
57    
58    
# Line 62  Create new input database object. Line 66  Create new input database object.
66          module => 'WebPAC::Input::MARC',          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  C<module> is low-level file format module. See L<WebPAC::Input::Isis> and
# Line 73  default, it C<ISO-8859-2>. Line 79  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 151  This function will read whole database i Line 162  This function will read whole database i
162          limit => 500,          limit => 500,
163          offset => 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>.
# Line 159  C<offset> is optional parametar to posit Line 171  C<offset> is optional parametar to posit
171    
172  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
173    
174    C<stats> create optional report about usage of fields and subfields
175    
176  Returns size of database, regardless of C<offset> and C<limit>  Returns size of database, regardless of C<offset> and C<limit>
177  parametars, see also C<size>.  parametars, see also C<size>.
178    
# Line 182  sub open { Line 196  sub open {
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 $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,          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 196  sub open { Line 240  sub open {
240                  return;                  return;
241          }          }
242    
243          my $offset = 1;          my $from_rec = 1;
244          my $limit = $size;          my $to_rec = $size;
245    
246          if (my $s = $self->{offset}) {          if (my $s = $self->{offset}) {
247                  $log->info("skipping to MFN $s");                  $log->debug("skipping to MFN $s");
248                  $offset = $s;                  $from_rec = $s;
249          } else {          } else {
250                  $self->{offset} = $offset;                  $self->{offset} = $from_rec;
251          }          }
252    
253          if ($self->{limit}) {          if ($self->{limit}) {
254                  $log->debug("limiting to ",$self->{limit}," records");                  $log->debug("limiting to ",$self->{limit}," records");
255                  $limit = $offset + $self->{limit} - 1;                  $to_rec = $from_rec + $self->{limit} - 1;
256                  $limit = $size if ($limit > $size);                  $to_rec = $size if ($to_rec > $size);
257          }          }
258    
259          # store size for later          # store size for later
260          $self->{size} = ($limit - $offset) ? ($limit - $offset + 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 $pos = $offset; $pos <= $limit; $pos++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
266    
267                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
268    
269                  my $rec = $self->{fetch_rec}->($self, $db, $pos );                  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 $pos empty? skipping...");                          $log->warn("record $pos empty? skipping...");
275                          next;                          next;
# Line 239  sub open { Line 285  sub open {
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($pos,$limit);                  # 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          }          }
310    
# Line 247  sub open { Line 312  sub open {
312          $self->{last_pcnt} = 0;          $self->{last_pcnt} = 0;
313    
314          # store max mfn and return it.          # store max mfn and return it.
315          $self->{max_pos} = $limit;          $self->{max_pos} = $to_rec;
316          $log->debug("max_pos: $limit");          $log->debug("max_pos: $to_rec");
317    
318          return $size;          return $size;
319  }  }
# Line 285  sub fetch { Line 350  sub fetch {
350                  return;                  return;
351          }          }
352    
353          $self->progress_bar($mfn,$self->{max_pos});          $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
354    
355          my $rec;          my $rec;
356    
# Line 360  sub seek { Line 425  sub seek {
425          return $self->{pos} = (($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.307  
changed lines
  Added in v.523
  ViewVC Help
Powered by ViewVC 1.1.26