/[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 11 by dpavlin, Sat Jul 16 20:54:28 2005 UTC revision 483 by dpavlin, Sun May 14 09:34: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 0.03;
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.04
18    
19  =cut  =cut
20    
21  our $VERSION = '0.01';  our $VERSION = '0.04';
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    
55    
56    
57  =head1 FUNCTIONS  =head1 FUNCTIONS
58    
# Line 43  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 94  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     );
164    
165    By default, C<code_page> is assumed to be C<852>.
166    
167    C<offset> is optional parametar to position at some offset before reading from database.
168    
169    C<limit> is optional parametar to read just C<limit> records from database
170    
171    Returns size of database, regardless of C<offset> and C<limit>
172    parametars, see also C<size>.
173    
174    =cut
175    
176    sub open {
177            my $self = shift;
178            my $arg = {@_};
179    
180            my $log = $self->_get_logger();
181    
182            $log->logcroak("need path") if (! $arg->{'path'});
183            my $code_page = $arg->{'code_page'} || '852';
184    
185            # store data in object
186            $self->{'input_code_page'} = $code_page;
187            foreach my $v (qw/path offset limit/) {
188                    $self->{$v} = $arg->{$v} if ($arg->{$v});
189            }
190    
191            # create Text::Iconv object
192            $self->{iconv} = Text::Iconv->new($code_page,$self->{'code_page'});
193    
194            my $filter_ref;
195    
196            if ($self->{recode}) {
197                    my @r = split(/\s/, $self->{recode});
198                    if ($#r % 2 != 1) {
199                            $log->logwarn("recode needs even number of elements (some number of valid pairs)");
200                    } else {
201                            my $recode;
202                            while (@r) {
203                                    my $from = shift @r;
204                                    my $to = shift @r;
205                                    $recode->{$from} = $to;
206                            }
207    
208                            my $regex = join '|' => keys %{ $recode };
209    
210                            $log->debug("using recode regex: $regex");
211                            
212                            $filter_ref = sub {
213                                    my $t = shift;
214                                    $t =~ s/($regex)/$recode->{$1}/g;
215                                    return $t;
216                            };
217    
218                    }
219    
220            }
221    
222            my ($db, $size) = $self->{open_db}->( $self,
223                    path => $arg->{path},
224                    filter => $filter_ref,
225            );
226    
227            unless ($db) {
228                    $log->logwarn("can't open database $arg->{path}, skipping...");
229                    return;
230            }
231    
232            unless ($size) {
233                    $log->logwarn("no records in database $arg->{path}, skipping...");
234                    return;
235            }
236    
237            my $from_rec = 1;
238            my $to_rec = $size;
239    
240            if (my $s = $self->{offset}) {
241                    $log->info("skipping to MFN $s");
242                    $from_rec = $s;
243            } else {
244                    $self->{offset} = $from_rec;
245            }
246    
247            if ($self->{limit}) {
248                    $log->debug("limiting to ",$self->{limit}," records");
249                    $to_rec = $from_rec + $self->{limit} - 1;
250                    $to_rec = $size if ($to_rec > $size);
251            }
252    
253            # store size for later
254            $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
255    
256            $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{code_page}");
257    
258            # read database
259            for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
260    
261                    $log->debug("position: $pos\n");
262    
263                    my $rec = $self->{fetch_rec}->($self, $db, $pos );
264    
265                    $log->debug(sub { Dumper($rec) });
266    
267                    if (! $rec) {
268                            $log->warn("record $pos empty? skipping...");
269                            next;
270                    }
271    
272                    # store
273                    if ($self->{low_mem}) {
274                            $self->{db}->put($pos, $rec);
275                    } else {
276                            $self->{data}->{$pos} = $rec;
277                    }
278    
279                    # create lookup
280                    $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});
281    
282                    $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
283    
284            }
285    
286            $self->{pos} = -1;
287            $self->{last_pcnt} = 0;
288    
289            # store max mfn and return it.
290            $self->{max_pos} = $to_rec;
291            $log->debug("max_pos: $to_rec");
292    
293            return $size;
294    }
295    
296    =head2 fetch
297    
298    Fetch next record from database. It will also displays progress bar.
299    
300     my $rec = $isis->fetch;
301    
302    Record from this function should probably go to C<data_structure> for
303    normalisation.
304    
305    =cut
306    
307    sub fetch {
308            my $self = shift;
309    
310            my $log = $self->_get_logger();
311    
312            $log->logconfess("it seems that you didn't load database!") unless ($self->{pos});
313    
314            if ($self->{pos} == -1) {
315                    $self->{pos} = $self->{offset};
316            } else {
317                    $self->{pos}++;
318            }
319    
320            my $mfn = $self->{pos};
321    
322            if ($mfn > $self->{max_pos}) {
323                    $self->{pos} = $self->{max_pos};
324                    $log->debug("at EOF");
325                    return;
326            }
327    
328            $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
329    
330            my $rec;
331    
332            if ($self->{low_mem}) {
333                    $rec = $self->{db}->get($mfn);
334            } else {
335                    $rec = $self->{data}->{$mfn};
336            }
337    
338            $rec ||= 0E0;
339    }
340    
341    =head2 pos
342    
343    Returns current record number (MFN).
344    
345     print $isis->pos;
346    
347    First record in database has position 1.
348    
349    =cut
350    
351    sub pos {
352            my $self = shift;
353            return $self->{pos};
354    }
355    
356    
357    =head2 size
358    
359    Returns number of records in database
360    
361     print $isis->size;
362    
363    Result from this function can be used to loop through all records
364    
365     foreach my $mfn ( 1 ... $isis->size ) { ... }
366    
367    because it takes into account C<offset> and C<limit>.
368    
369    =cut
370    
371    sub size {
372            my $self = shift;
373            return $self->{size};
374    }
375    
376    =head2 seek
377    
378    Seek to specified MFN in file.
379    
380     $isis->seek(42);
381    
382    First record in database has position 1.
383    
384    =cut
385    
386    sub seek {
387            my $self = shift;
388            my $pos = shift || return;
389    
390            my $log = $self->_get_logger();
391    
392            if ($pos < 1) {
393                    $log->warn("seek before first record");
394                    $pos = 1;
395            } elsif ($pos > $self->{max_pos}) {
396                    $log->warn("seek beyond last record");
397                    $pos = $self->{max_pos};
398            }
399    
400            return $self->{pos} = (($pos - 1) || -1);
401    }
402    
403    
404  =head1 MEMORY USAGE  =head1 MEMORY USAGE
405    
406  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.11  
changed lines
  Added in v.483
  ViewVC Help
Powered by ViewVC 1.1.26