/[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 506 by dpavlin, Mon May 15 09:59:05 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 WebPAC::Common;
7    use base qw/WebPAC::Common/;
8    use Text::Iconv;
9    use Data::Dumper;
10    
11  =head1 NAME  =head1 NAME
12    
13  WebPAC::Input - core module for input file format  WebPAC::Input - read different file formats into WebPAC
14    
15  =head1 VERSION  =head1 VERSION
16    
17  Version 0.01  Version 0.05
18    
19  =cut  =cut
20    
21  our $VERSION = '0.01';  our $VERSION = '0.05';
22    
23  =head1 SYNOPSIS  =head1 SYNOPSIS
24    
25  This module will load particular loader module and execute it's functions.  This module implements input as database which have fixed and known
26    I<size> while indexing and single unique numeric identifier for database
27    position ranging from 1 to I<size>.
28    
29    Simply, something that is indexed by unmber from 1 .. I<size>.
30    
31    Examples of such databases are CDS/ISIS files, MARC files, lines in
32    text file, and so on.
33    
34    Specific file formats are implemented using low-level interface modules,
35    located in C<WebPAC::Input::*> namespace which export C<open_db>,
36    C<fetch_rec> and optional C<init> functions.
37    
38  Perhaps a little code snippet.  Perhaps a little code snippet.
39    
40      use WebPAC::Input;      use WebPAC::Input;
41    
42      my $db = WebPAC::Input->new(      my $db = WebPAC::Input->new(
43          format => 'NULL',          module => 'WebPAC::Input::ISIS',
44          config => $config,                  config => $config,
45          lookup => $lookup_obj,                  lookup => $lookup_obj,
46          low_mem => 1,                  low_mem => 1,
47      );      );
48    
49      $db->open('/path/to/database');      $db->open('/path/to/database');
50      print "database size: ",$db->size,"\n";          print "database size: ",$db->size,"\n";
51      while (my $row = $db->fetch) {          while (my $rec = $db->fetch) {
52          ...                  # do something with $rec
53      }          }
54      $db->close;  
55    
56    
57  =head1 FUNCTIONS  =head1 FUNCTIONS
58    
# Line 44  Perhaps a little code snippet. Line 61  Perhaps a little code snippet.
61  Create new input database object.  Create new input database object.
62    
63    my $db = new WebPAC::Input(    my $db = new WebPAC::Input(
64          format => 'NULL'          module => 'WebPAC::Input::MARC',
65          code_page => 'ISO-8859-2',          code_page => 'ISO-8859-2',
66          low_mem => 1,          low_mem => 1,
67            recode => 'char pairs',
68            no_progress_bar => 1,
69    );    );
70    
71    C<module> is low-level file format module. See L<WebPAC::Input::Isis> and
72    L<WebPAC::Input::MARC>.
73    
74  Optional parametar C<code_page> specify application code page (which will be  Optional parametar C<code_page> specify application code page (which will be
75  used internally). This should probably be your terminal encoding, and by  used internally). This should probably be your terminal encoding, and by
76  default, it C<ISO-8859-2>.  default, it C<ISO-8859-2>.
77    
78  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).
79    
80    C<recode> is optional string constisting of character or words pairs that
81    should be replaced in input stream.
82    
83    C<no_progress_bar> disables progress bar output on C<STDOUT>
84    
85    This function will also call low-level C<init> if it exists with same
86    parametars.
87    
88  =cut  =cut
89    
90  sub new {  sub new {
91          my $class = shift;          my $class = shift;
92          my $self = {@_};          my $self = {@_};
93          bless($self, $class);          bless($self, $class);
94    
         $self->{'code_page'} ||= 'ISO-8859-2';  
   
95          my $log = $self->_get_logger;          my $log = $self->_get_logger;
96    
97            $log->logconfess("specify low-level file format module") unless ($self->{module});
98            my $module = $self->{module};
99            $module =~ s#::#/#g;
100            $module .= '.pm';
101            $log->debug("require low-level module $self->{module} from $module");
102    
103            require $module;
104            #eval $self->{module} .'->import';
105    
106            # check if required subclasses are implemented
107            foreach my $subclass (qw/open_db fetch_rec init/) {
108                    my $n = $self->{module} . '::' . $subclass;
109                    if (! defined &{ $n }) {
110                            my $missing = "missing $subclass in $self->{module}";
111                            $self->{$subclass} = sub { $log->logwarn($missing) };
112                    } else {
113                            $self->{$subclass} = \&{ $n };
114                    }
115            }
116    
117            if ($self->{init}) {
118                    $log->debug("calling init");
119                    $self->{init}->($self, @_);
120            }
121    
122            $self->{'code_page'} ||= 'ISO-8859-2';
123    
124          # running with low_mem flag? well, use DBM::Deep then.          # running with low_mem flag? well, use DBM::Deep then.
125          if ($self->{'low_mem'}) {          if ($self->{'low_mem'}) {
126                  $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 150  sub new {
150          $self ? return $self : return undef;          $self ? return $self : return undef;
151  }  }
152    
153    =head2 open
154    
155    This function will read whole database in memory and produce lookups.
156    
157     $input->open(
158            path => '/path/to/database/file',
159            code_page => '852',
160            limit => 500,
161            offset => 6000,
162            lookup => $lookup_obj,
163            stats => 1,
164     );
165    
166    By default, C<code_page> is assumed to be C<852>.
167    
168    C<offset> is optional parametar to position at some offset before reading from database.
169    
170    C<limit> is optional parametar to read just C<limit> records from database
171    
172    C<stats> create optional report about usage of fields and subfields
173    
174    Returns size of database, regardless of C<offset> and C<limit>
175    parametars, see also C<size>.
176    
177    =cut
178    
179    sub open {
180            my $self = shift;
181            my $arg = {@_};
182    
183            my $log = $self->_get_logger();
184    
185            $log->logcroak("need path") if (! $arg->{'path'});
186            my $code_page = $arg->{'code_page'} || '852';
187    
188            # store data in object
189            $self->{'input_code_page'} = $code_page;
190            foreach my $v (qw/path offset limit/) {
191                    $self->{$v} = $arg->{$v} if ($arg->{$v});
192            }
193    
194            # create Text::Iconv object
195            $self->{iconv} = Text::Iconv->new($code_page,$self->{'code_page'});
196    
197            my $filter_ref;
198    
199            if ($self->{recode}) {
200                    my @r = split(/\s/, $self->{recode});
201                    if ($#r % 2 != 1) {
202                            $log->logwarn("recode needs even number of elements (some number of valid pairs)");
203                    } else {
204                            my $recode;
205                            while (@r) {
206                                    my $from = shift @r;
207                                    my $to = shift @r;
208                                    $recode->{$from} = $to;
209                            }
210    
211                            my $regex = join '|' => keys %{ $recode };
212    
213                            $log->debug("using recode regex: $regex");
214                            
215                            $filter_ref = sub {
216                                    my $t = shift;
217                                    $t =~ s/($regex)/$recode->{$1}/g;
218                                    return $t;
219                            };
220    
221                    }
222    
223            }
224    
225            my ($db, $size) = $self->{open_db}->( $self,
226                    path => $arg->{path},
227                    filter => $filter_ref,
228            );
229    
230            unless (defined($db)) {
231                    $log->logwarn("can't open database $arg->{path}, skipping...");
232                    return;
233            }
234    
235            unless ($size) {
236                    $log->logwarn("no records in database $arg->{path}, skipping...");
237                    return;
238            }
239    
240            my $from_rec = 1;
241            my $to_rec = $size;
242    
243            if (my $s = $self->{offset}) {
244                    $log->info("skipping to MFN $s");
245                    $from_rec = $s;
246            } else {
247                    $self->{offset} = $from_rec;
248            }
249    
250            if ($self->{limit}) {
251                    $log->debug("limiting to ",$self->{limit}," records");
252                    $to_rec = $from_rec + $self->{limit} - 1;
253                    $to_rec = $size if ($to_rec > $size);
254            }
255    
256            # store size for later
257            $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
258    
259            $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{code_page}", $self->{stats} ? ' [stats]' : '');
260    
261            # read database
262            for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
263    
264                    $log->debug("position: $pos\n");
265    
266                    my $rec = $self->{fetch_rec}->($self, $db, $pos );
267    
268                    $log->debug(sub { Dumper($rec) });
269    
270                    if (! $rec) {
271                            $log->warn("record $pos empty? skipping...");
272                            next;
273                    }
274    
275                    # store
276                    if ($self->{low_mem}) {
277                            $self->{db}->put($pos, $rec);
278                    } else {
279                            $self->{data}->{$pos} = $rec;
280                    }
281    
282                    # create lookup
283                    $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});
284    
285                    # update counters for statistics
286                    if ($self->{stats}) {
287                            map {
288                                    my $fld = $_;
289                                    $self->{_stats}->{fld}->{ $fld }++;
290                                    if (ref($rec->{ $fld }) eq 'ARRAY') {
291                                            map {
292                                                    if (ref($_) eq 'HASH') {
293                                                            map {
294                                                                    $self->{_stats}->{sf}->{ $fld }->{ $_ }++;
295                                                            } keys %{ $_ };
296                                                    } else {
297                                                            $self->{_stats}->{repeatable}->{ $fld }++;
298                                                    }
299                                            } @{ $rec->{$fld} };
300                                    }
301                            } keys %{ $rec };
302                    }
303    
304                    $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
305    
306            }
307    
308            $self->{pos} = -1;
309            $self->{last_pcnt} = 0;
310    
311            # store max mfn and return it.
312            $self->{max_pos} = $to_rec;
313            $log->debug("max_pos: $to_rec");
314    
315            return $size;
316    }
317    
318    =head2 fetch
319    
320    Fetch next record from database. It will also displays progress bar.
321    
322     my $rec = $isis->fetch;
323    
324    Record from this function should probably go to C<data_structure> for
325    normalisation.
326    
327    =cut
328    
329    sub fetch {
330            my $self = shift;
331    
332            my $log = $self->_get_logger();
333    
334            $log->logconfess("it seems that you didn't load database!") unless ($self->{pos});
335    
336            if ($self->{pos} == -1) {
337                    $self->{pos} = $self->{offset};
338            } else {
339                    $self->{pos}++;
340            }
341    
342            my $mfn = $self->{pos};
343    
344            if ($mfn > $self->{max_pos}) {
345                    $self->{pos} = $self->{max_pos};
346                    $log->debug("at EOF");
347                    return;
348            }
349    
350            $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
351    
352            my $rec;
353    
354            if ($self->{low_mem}) {
355                    $rec = $self->{db}->get($mfn);
356            } else {
357                    $rec = $self->{data}->{$mfn};
358            }
359    
360            $rec ||= 0E0;
361    }
362    
363    =head2 pos
364    
365    Returns current record number (MFN).
366    
367     print $isis->pos;
368    
369    First record in database has position 1.
370    
371    =cut
372    
373    sub pos {
374            my $self = shift;
375            return $self->{pos};
376    }
377    
378    
379    =head2 size
380    
381    Returns number of records in database
382    
383     print $isis->size;
384    
385    Result from this function can be used to loop through all records
386    
387     foreach my $mfn ( 1 ... $isis->size ) { ... }
388    
389    because it takes into account C<offset> and C<limit>.
390    
391    =cut
392    
393    sub size {
394            my $self = shift;
395            return $self->{size};
396    }
397    
398    =head2 seek
399    
400    Seek to specified MFN in file.
401    
402     $isis->seek(42);
403    
404    First record in database has position 1.
405    
406    =cut
407    
408    sub seek {
409            my $self = shift;
410            my $pos = shift || return;
411    
412            my $log = $self->_get_logger();
413    
414            if ($pos < 1) {
415                    $log->warn("seek before first record");
416                    $pos = 1;
417            } elsif ($pos > $self->{max_pos}) {
418                    $log->warn("seek beyond last record");
419                    $pos = $self->{max_pos};
420            }
421    
422            return $self->{pos} = (($pos - 1) || -1);
423    }
424    
425    =head2 stats
426    
427    Dump statistics about field and subfield usage
428    
429      print Dumper( $input->stats );
430    
431    =cut
432    
433    sub stats {
434            my $self = shift;
435            return $self->{_stats};
436    }
437    
438  =head1 MEMORY USAGE  =head1 MEMORY USAGE
439    
440  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.506
  ViewVC Help
Powered by ViewVC 1.1.26