/[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 519 by dpavlin, Thu May 18 13:48:51 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.05
20    
21  =cut  =cut
22    
23  our $VERSION = '0.01';  our $VERSION = '0.05';
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,                  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      $db->close;  
57    
58    
59  =head1 FUNCTIONS  =head1 FUNCTIONS
60    
# Line 44  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
88    parametars.
89    
90  =cut  =cut
91    
92  sub new {  sub new {
93          my $class = shift;          my $class = shift;
94          my $self = {@_};          my $self = {@_};
95          bless($self, $class);          bless($self, $class);
96    
         $self->{'code_page'} ||= 'ISO-8859-2';  
   
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
109            foreach my $subclass (qw/open_db fetch_rec init/) {
110                    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->{init}) {
120                    $log->debug("calling init");
121                    $self->{init}->($self, @_);
122            }
123    
124            $self->{'code_page'} ||= 'ISO-8859-2';
125    
126          # running with low_mem flag? well, use DBM::Deep then.          # running with low_mem flag? well, use DBM::Deep then.
127          if ($self->{'low_mem'}) {          if ($self->{'low_mem'}) {
128                  $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 152  sub new {
152          $self ? return $self : return undef;          $self ? return $self : return undef;
153  }  }
154    
155    =head2 open
156    
157    This function will read whole database in memory and produce lookups.
158    
159     $input->open(
160            path => '/path/to/database/file',
161            code_page => '852',
162            limit => 500,
163            offset => 6000,
164            lookup => $lookup_obj,
165            stats => 1,
166     );
167    
168    By default, C<code_page> is assumed to be C<852>.
169    
170    C<offset> is optional parametar to position at some offset before reading from database.
171    
172    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>
177    parametars, see also C<size>.
178    
179    =cut
180    
181    sub open {
182            my $self = shift;
183            my $arg = {@_};
184    
185            my $log = $self->_get_logger();
186    
187            $log->logcroak("need path") if (! $arg->{'path'});
188            my $code_page = $arg->{'code_page'} || '852';
189    
190            # store data in object
191            $self->{'input_code_page'} = $code_page;
192            foreach my $v (qw/path offset limit/) {
193                    $self->{$v} = $arg->{$v} if ($arg->{$v});
194            }
195    
196            # create Text::Iconv object
197            $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,
228                    path => $arg->{path},
229                    filter => $filter_ref,
230            );
231    
232            unless (defined($db)) {
233                    $log->logwarn("can't open database $arg->{path}, skipping...");
234                    return;
235            }
236    
237            unless ($size) {
238                    $log->logwarn("no records in database $arg->{path}, skipping...");
239                    return;
240            }
241    
242            my $from_rec = 1;
243            my $to_rec = $size;
244    
245            if (my $s = $self->{offset}) {
246                    $log->debug("skipping to MFN $s");
247                    $from_rec = $s;
248            } else {
249                    $self->{offset} = $from_rec;
250            }
251    
252            if ($self->{limit}) {
253                    $log->debug("limiting to ",$self->{limit}," records");
254                    $to_rec = $from_rec + $self->{limit} - 1;
255                    $to_rec = $size if ($to_rec > $size);
256            }
257    
258            # store size for later
259            $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
260    
261            $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{code_page}", $self->{stats} ? ' [stats]' : '');
262    
263            # read database
264            for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
265    
266                    $log->debug("position: $pos\n");
267    
268                    my $rec = $self->{fetch_rec}->($self, $db, $pos );
269    
270                    $log->debug(sub { Dumper($rec) });
271    
272                    if (! $rec) {
273                            $log->warn("record $pos empty? skipping...");
274                            next;
275                    }
276    
277                    # store
278                    if ($self->{low_mem}) {
279                            $self->{db}->put($pos, $rec);
280                    } else {
281                            $self->{data}->{$pos} = $rec;
282                    }
283    
284                    # create lookup
285                    $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});
286    
287                    # 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            }
309    
310            $self->{pos} = -1;
311            $self->{last_pcnt} = 0;
312    
313            # store max mfn and return it.
314            $self->{max_pos} = $to_rec;
315            $log->debug("max_pos: $to_rec");
316    
317            return $size;
318    }
319    
320    =head2 fetch
321    
322    Fetch next record from database. It will also displays progress bar.
323    
324     my $rec = $isis->fetch;
325    
326    Record from this function should probably go to C<data_structure> for
327    normalisation.
328    
329    =cut
330    
331    sub fetch {
332            my $self = shift;
333    
334            my $log = $self->_get_logger();
335    
336            $log->logconfess("it seems that you didn't load database!") unless ($self->{pos});
337    
338            if ($self->{pos} == -1) {
339                    $self->{pos} = $self->{offset};
340            } else {
341                    $self->{pos}++;
342            }
343    
344            my $mfn = $self->{pos};
345    
346            if ($mfn > $self->{max_pos}) {
347                    $self->{pos} = $self->{max_pos};
348                    $log->debug("at EOF");
349                    return;
350            }
351    
352            $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
353    
354            my $rec;
355    
356            if ($self->{low_mem}) {
357                    $rec = $self->{db}->get($mfn);
358            } else {
359                    $rec = $self->{data}->{$mfn};
360            }
361    
362            $rec ||= 0E0;
363    }
364    
365    =head2 pos
366    
367    Returns current record number (MFN).
368    
369     print $isis->pos;
370    
371    First record in database has position 1.
372    
373    =cut
374    
375    sub pos {
376            my $self = shift;
377            return $self->{pos};
378    }
379    
380    
381    =head2 size
382    
383    Returns number of records in database
384    
385     print $isis->size;
386    
387    Result from this function can be used to loop through all records
388    
389     foreach my $mfn ( 1 ... $isis->size ) { ... }
390    
391    because it takes into account C<offset> and C<limit>.
392    
393    =cut
394    
395    sub size {
396            my $self = shift;
397            return $self->{size};
398    }
399    
400    =head2 seek
401    
402    Seek to specified MFN in file.
403    
404     $isis->seek(42);
405    
406    First record in database has position 1.
407    
408    =cut
409    
410    sub seek {
411            my $self = shift;
412            my $pos = shift || return;
413    
414            my $log = $self->_get_logger();
415    
416            if ($pos < 1) {
417                    $log->warn("seek before first record");
418                    $pos = 1;
419            } elsif ($pos > $self->{max_pos}) {
420                    $log->warn("seek beyond last record");
421                    $pos = $self->{max_pos};
422            }
423    
424            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("%4s %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 cmp $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    
477  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.519
  ViewVC Help
Powered by ViewVC 1.1.26