/[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 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;
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                    %{ $arg },
231            );
232    
233            unless (defined($db)) {
234                    $log->logwarn("can't open database $arg->{path}, skipping...");
235                    return;
236            }
237    
238            unless ($size) {
239                    $log->logwarn("no records in database $arg->{path}, skipping...");
240                    return;
241            }
242    
243            my $from_rec = 1;
244            my $to_rec = $size;
245    
246            if (my $s = $self->{offset}) {
247                    $log->debug("skipping to MFN $s");
248                    $from_rec = $s;
249            } else {
250                    $self->{offset} = $from_rec;
251            }
252    
253            if ($self->{limit}) {
254                    $log->debug("limiting to ",$self->{limit}," records");
255                    $to_rec = $from_rec + $self->{limit} - 1;
256                    $to_rec = $size if ($to_rec > $size);
257            }
258    
259            # store size for later
260            $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
261    
262            $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{code_page}", $self->{stats} ? ' [stats]' : '');
263    
264            # read database
265            for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
266    
267                    $log->debug("position: $pos\n");
268    
269                    my $rec = $self->{fetch_rec}->($self, $db, $pos );
270    
271                    $log->debug(sub { Dumper($rec) });
272    
273                    if (! $rec) {
274                            $log->warn("record $pos empty? skipping...");
275                            next;
276                    }
277    
278                    # store
279                    if ($self->{low_mem}) {
280                            $self->{db}->put($pos, $rec);
281                    } else {
282                            $self->{data}->{$pos} = $rec;
283                    }
284    
285                    # create lookup
286                    $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});
287    
288                    # 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    
311            $self->{pos} = -1;
312            $self->{last_pcnt} = 0;
313    
314            # store max mfn and return it.
315            $self->{max_pos} = $to_rec;
316            $log->debug("max_pos: $to_rec");
317    
318            return $size;
319    }
320    
321    =head2 fetch
322    
323    Fetch next record from database. It will also displays progress bar.
324    
325     my $rec = $isis->fetch;
326    
327    Record from this function should probably go to C<data_structure> for
328    normalisation.
329    
330    =cut
331    
332    sub fetch {
333            my $self = shift;
334    
335            my $log = $self->_get_logger();
336    
337            $log->logconfess("it seems that you didn't load database!") unless ($self->{pos});
338    
339            if ($self->{pos} == -1) {
340                    $self->{pos} = $self->{offset};
341            } else {
342                    $self->{pos}++;
343            }
344    
345            my $mfn = $self->{pos};
346    
347            if ($mfn > $self->{max_pos}) {
348                    $self->{pos} = $self->{max_pos};
349                    $log->debug("at EOF");
350                    return;
351            }
352    
353            $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
354    
355            my $rec;
356    
357            if ($self->{low_mem}) {
358                    $rec = $self->{db}->get($mfn);
359            } else {
360                    $rec = $self->{data}->{$mfn};
361            }
362    
363            $rec ||= 0E0;
364    }
365    
366    =head2 pos
367    
368    Returns current record number (MFN).
369    
370     print $isis->pos;
371    
372    First record in database has position 1.
373    
374    =cut
375    
376    sub pos {
377            my $self = shift;
378            return $self->{pos};
379    }
380    
381    
382    =head2 size
383    
384    Returns number of records in database
385    
386     print $isis->size;
387    
388    Result from this function can be used to loop through all records
389    
390     foreach my $mfn ( 1 ... $isis->size ) { ... }
391    
392    because it takes into account C<offset> and C<limit>.
393    
394    =cut
395    
396    sub size {
397            my $self = shift;
398            return $self->{size};
399    }
400    
401    =head2 seek
402    
403    Seek to specified MFN in file.
404    
405     $isis->seek(42);
406    
407    First record in database has position 1.
408    
409    =cut
410    
411    sub seek {
412            my $self = shift;
413            my $pos = shift || return;
414    
415            my $log = $self->_get_logger();
416    
417            if ($pos < 1) {
418                    $log->warn("seek before first record");
419                    $pos = 1;
420            } elsif ($pos > $self->{max_pos}) {
421                    $log->warn("seek beyond last record");
422                    $pos = $self->{max_pos};
423            }
424    
425            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    
478  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.523
  ViewVC Help
Powered by ViewVC 1.1.26