/[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 10 by dpavlin, Sat Jul 16 20:35:30 2005 UTC revision 593 by dpavlin, Sun Jul 9 15:22:39 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;
9    use base qw/WebPAC::Common/;
10    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.01  Version 0.08
20    
21  =cut  =cut
22    
23  our $VERSION = '0.01';  our $VERSION = '0.08';
24    
25  =head1 SYNOPSIS  =head1 SYNOPSIS
26    
27  This module will load particular loader module and execute it's functions.  This module implements input as database which have fixed and known
28    I<size> while indexing and single unique numeric identifier for database
29    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      $db->close;  
56    
57    
58  =head1 FUNCTIONS  =head1 FUNCTIONS
59    
# Line 44  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
87    parametars.
88    
89  =cut  =cut
90    
91  sub new {  sub new {
92          my $class = shift;          my $class = shift;
93          my $self = {@_};          my $self = {@_};
94          bless($self, $class);          bless($self, $class);
95    
         $self->{'code_page'} ||= 'ISO-8859-2';  
   
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
111            foreach my $subclass (qw/open_db fetch_rec init/) {
112                    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->{init}) {
122                    $log->debug("calling init");
123                    $self->{init}->($self, @_);
124            }
125    
126            $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'}) {
130                  $log->info("running with low_mem which impacts performance (<32 Mb memory usage)");                  $log->info("running with low_mem which impacts performance (<32 Mb memory usage)");
# Line 95  sub new { Line 154  sub new {
154          $self ? return $self : return undef;          $self ? return $self : return undef;
155  }  }
156    
157    =head2 open
158    
159    This function will read whole database in memory and produce lookups.
160    
161     $input->open(
162            path => '/path/to/database/file',
163            code_page => '852',
164            limit => 500,
165            offset => 6000,
166            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>.
175    
176    C<offset> is optional parametar to position at some offset before reading from database.
177    
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    C<lookup_coderef> is closure to call when adding key => $value combinations to
183    lookup.
184    
185    Returns size of database, regardless of C<offset> and C<limit>
186    parametars, see also C<size>.
187    
188    =cut
189    
190    sub open {
191            my $self = shift;
192            my $arg = {@_};
193    
194            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'});
201            my $code_page = $arg->{'code_page'} || '852';
202    
203            # store data in object
204            $self->{'input_code_page'} = $code_page;
205            foreach my $v (qw/path offset limit/) {
206                    $self->{$v} = $arg->{$v} if ($arg->{$v});
207            }
208    
209            # create Text::Iconv object
210            $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            }
239    
240            my ($db, $size) = $self->{open_db}->( $self,
241                    path => $arg->{path},
242                    filter => $filter_ref,
243                    %{ $arg },
244            );
245    
246            unless (defined($db)) {
247                    $log->logwarn("can't open database $arg->{path}, skipping...");
248                    return;
249            }
250    
251            unless ($size) {
252                    $log->logwarn("no records in database $arg->{path}, skipping...");
253                    return;
254            }
255    
256            my $from_rec = 1;
257            my $to_rec = $size;
258    
259            if (my $s = $self->{offset}) {
260                    $log->debug("skipping to MFN $s");
261                    $from_rec = $s;
262            } else {
263                    $self->{offset} = $from_rec;
264            }
265    
266            if ($self->{limit}) {
267                    $log->debug("limiting to ",$self->{limit}," records");
268                    $to_rec = $from_rec + $self->{limit} - 1;
269                    $to_rec = $size if ($to_rec > $size);
270            }
271    
272            # store size for later
273            $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
274    
275            $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{encoding}", $self->{stats} ? ' [stats]' : '');
276    
277            # read database
278            for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
279    
280                    $log->debug("position: $pos\n");
281    
282                    my $rec = $self->{fetch_rec}->($self, $db, $pos );
283    
284                    $log->debug(sub { Dumper($rec) });
285    
286                    if (! $rec) {
287                            $log->warn("record $pos empty? skipping...");
288                            next;
289                    }
290    
291                    # store
292                    if ($self->{low_mem}) {
293                            $self->{db}->put($pos, $rec);
294                    } else {
295                            $self->{data}->{$pos} = $rec;
296                    }
297    
298                    # create lookup
299                    $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
300    
301                    # 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->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
328    
329            }
330    
331            $self->{pos} = -1;
332            $self->{last_pcnt} = 0;
333    
334            # store max mfn and return it.
335            $self->{max_pos} = $to_rec;
336            $log->debug("max_pos: $to_rec");
337    
338            return $size;
339    }
340    
341    =head2 fetch
342    
343    Fetch next record from database. It will also displays progress bar.
344    
345     my $rec = $isis->fetch;
346    
347    Record from this function should probably go to C<data_structure> for
348    normalisation.
349    
350    =cut
351    
352    sub fetch {
353            my $self = shift;
354    
355            my $log = $self->_get_logger();
356    
357            $log->logconfess("it seems that you didn't load database!") unless ($self->{pos});
358    
359            if ($self->{pos} == -1) {
360                    $self->{pos} = $self->{offset};
361            } else {
362                    $self->{pos}++;
363            }
364    
365            my $mfn = $self->{pos};
366    
367            if ($mfn > $self->{max_pos}) {
368                    $self->{pos} = $self->{max_pos};
369                    $log->debug("at EOF");
370                    return;
371            }
372    
373            $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
374    
375            my $rec;
376    
377            if ($self->{low_mem}) {
378                    $rec = $self->{db}->get($mfn);
379            } else {
380                    $rec = $self->{data}->{$mfn};
381            }
382    
383            $rec ||= 0E0;
384    }
385    
386    =head2 pos
387    
388    Returns current record number (MFN).
389    
390     print $isis->pos;
391    
392    First record in database has position 1.
393    
394    =cut
395    
396    sub pos {
397            my $self = shift;
398            return $self->{pos};
399    }
400    
401    
402    =head2 size
403    
404    Returns number of records in database
405    
406     print $isis->size;
407    
408    Result from this function can be used to loop through all records
409    
410     foreach my $mfn ( 1 ... $isis->size ) { ... }
411    
412    because it takes into account C<offset> and C<limit>.
413    
414    =cut
415    
416    sub size {
417            my $self = shift;
418            return $self->{size};
419    }
420    
421    =head2 seek
422    
423    Seek to specified MFN in file.
424    
425     $isis->seek(42);
426    
427    First record in database has position 1.
428    
429    =cut
430    
431    sub seek {
432            my $self = shift;
433            my $pos = shift || return;
434    
435            my $log = $self->_get_logger();
436    
437            if ($pos < 1) {
438                    $log->warn("seek before first record");
439                    $pos = 1;
440            } elsif ($pos > $self->{max_pos}) {
441                    $log->warn("seek beyond last record");
442                    $pos = $self->{max_pos};
443            }
444    
445            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    
501  C<low_mem> options is double-edged sword. If enabled, WebPAC  C<low_mem> options is double-edged sword. If enabled, WebPAC
Legend:
Removed from v.10  
changed lines
  Added in v.593
  ViewVC Help
Powered by ViewVC 1.1.26