/[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 6 by dpavlin, Sat Jul 16 14:44:38 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,
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 42  Perhaps a little code snippet. Line 62  Perhaps a little code snippet.
62    
63  Create new input database object.  Create new input database object.
64    
65    my $db = new WebPAC::Input( format => 'NULL' );    my $db = new WebPAC::Input(
66            module => 'WebPAC::Input::MARC',
67            code_page => 'ISO-8859-2',
68            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
77    used internally). This should probably be your terminal encoding, and by
78    default, it C<ISO-8859-2>.
79    
80    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    
97            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.
127            if ($self->{'low_mem'}) {
128                    $log->info("running with low_mem which impacts performance (<32 Mb memory usage)");
129    
130                    my $db_file = "data.db";
131    
132                    if (-e $db_file) {
133                            unlink $db_file or $log->logdie("can't remove '$db_file' from last run");
134                            $log->debug("removed '$db_file' from last run");
135                    }
136    
137                    require DBM::Deep;
138    
139                    my $db = new DBM::Deep $db_file;
140    
141                    $log->logdie("DBM::Deep error: $!") unless ($db);
142    
143                    if ($db->error()) {
144                            $log->logdie("can't open '$db_file' under low_mem: ",$db->error());
145                    } else {
146                            $log->debug("using file '$db_file' for DBM::Deep");
147                    }
148    
149                    $self->{'db'} = $db;
150            }
151    
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.6  
changed lines
  Added in v.519
  ViewVC Help
Powered by ViewVC 1.1.26