/[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 606 by dpavlin, Tue Aug 1 13:59:47 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.09
20    
21  =cut  =cut
22    
23  our $VERSION = '0.01';  our $VERSION = '0.09';
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(
45                    module => 'WebPAC::Input::ISIS',
46                    low_mem => 1,
47            );
48    
49            $db->open( path => '/path/to/database' );
50            print "database size: ",$db->size,"\n";
51            while (my $rec = $db->fetch) {
52                    # do something with $rec
53            }
54    
     my $db = WebPAC::Input->new(  
         format => 'NULL',  
         config => $config,  
         lookup => $lookup_obj,  
         low_mem => 1,  
     );  
55    
     $db->open('/path/to/database');  
     print "database size: ",$db->size,"\n";  
     while (my $row = $db->fetch) {  
         ...  
     }  
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',          encoding => 'ISO-8859-2',
66          low_mem => 1,          low_mem => 1,
67            recode => 'char pairs',
68            no_progress_bar => 1,
69    );    );
70    
71  Optional parametar C<code_page> specify application code page (which will be  C<module> is low-level file format module. See L<WebPAC::Input::ISIS> and
72    L<WebPAC::Input::MARC>.
73    
74    Optional parametar C<encoding> 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("code_page argument is not suppored any more. change it to encoding") if ($self->{lookup});
98            $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if ($self->{lookup});
99    
100            $log->logconfess("specify low-level file format module") unless ($self->{module});
101            my $module = $self->{module};
102            $module =~ s#::#/#g;
103            $module .= '.pm';
104            $log->debug("require low-level module $self->{module} from $module");
105    
106            require $module;
107            #eval $self->{module} .'->import';
108    
109            # check if required subclasses are implemented
110            foreach my $subclass (qw/open_db fetch_rec init/) {
111                    my $n = $self->{module} . '::' . $subclass;
112                    if (! defined &{ $n }) {
113                            my $missing = "missing $subclass in $self->{module}";
114                            $self->{$subclass} = sub { $log->logwarn($missing) };
115                    } else {
116                            $self->{$subclass} = \&{ $n };
117                    }
118            }
119    
120            if ($self->{init}) {
121                    $log->debug("calling init");
122                    $self->{init}->($self, @_);
123            }
124    
125            $self->{'encoding'} ||= 'ISO-8859-2';
126    
127          # running with low_mem flag? well, use DBM::Deep then.          # running with low_mem flag? well, use DBM::Deep then.
128          if ($self->{'low_mem'}) {          if ($self->{'low_mem'}) {
129                  $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 153  sub new {
153          $self ? return $self : return undef;          $self ? return $self : return undef;
154  }  }
155    
156    =head2 open
157    
158    This function will read whole database in memory and produce lookups.
159    
160     $input->open(
161            path => '/path/to/database/file',
162            code_page => '852',
163            limit => 500,
164            offset => 6000,
165            lookup => $lookup_obj,
166            stats => 1,
167            lookup_ref => sub {
168                    my ($k,$v) = @_;
169                    # store lookup $k => $v
170            },
171            modify_records => {
172                    900 => { '^a' => { ' : ' => '^b' } },
173                    901 => { '*' => { '^b' => ' ; ' } },
174            },
175     );
176    
177    By default, C<code_page> is assumed to be C<852>.
178    
179    C<offset> is optional parametar to position at some offset before reading from database.
180    
181    C<limit> is optional parametar to read just C<limit> records from database
182    
183    C<stats> create optional report about usage of fields and subfields
184    
185    C<lookup_coderef> is closure to call when adding C<< key => 'value' >> combinations to
186    lookup.
187    
188    C<modify_records> specify mapping from subfields to delimiters or from
189    delimiters to subfields, as well as oprations on fields (if subfield is
190    defined as C<*>.
191    
192    Returns size of database, regardless of C<offset> and C<limit>
193    parametars, see also C<size>.
194    
195    =cut
196    
197    sub open {
198            my $self = shift;
199            my $arg = {@_};
200    
201            my $log = $self->_get_logger();
202    
203            $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_coderef") if ($arg->{lookup});
204            $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
205                    if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
206    
207            $log->logcroak("need path") if (! $arg->{'path'});
208            my $code_page = $arg->{'code_page'} || '852';
209    
210            # store data in object
211            $self->{'input_code_page'} = $code_page;
212            foreach my $v (qw/path offset limit/) {
213                    $self->{$v} = $arg->{$v} if ($arg->{$v});
214            }
215    
216            # create Text::Iconv object
217            $self->{iconv} = Text::Iconv->new($code_page,$self->{'encoding'});      ## FIXME remove!
218    
219            my $filter_ref;
220            my $recode_regex;
221            my $recode_map;
222    
223            if ($self->{recode}) {
224                    my @r = split(/\s/, $self->{recode});
225                    if ($#r % 2 != 1) {
226                            $log->logwarn("recode needs even number of elements (some number of valid pairs)");
227                    } else {
228                            while (@r) {
229                                    my $from = shift @r;
230                                    my $to = shift @r;
231                                    $recode_map->{$from} = $to;
232                            }
233    
234                            $recode_regex = join '|' => keys %{ $recode_map };
235    
236                            $log->debug("using recode regex: $recode_regex");
237                    }
238    
239            }
240    
241            my $rec_regex = $self->modify_record_regexps(%{ $arg->{modify_records} });
242            $log->debug("rec_regex: ", Dumper($rec_regex));
243    
244            my ($db, $size) = $self->{open_db}->( $self,
245                    path => $arg->{path},
246                    filter => sub {
247                                    my ($l,$f_nr) = @_;
248                                    return unless defined($l);
249    
250                                    ## FIXME remove iconv!
251                                    $l = $self->{iconv}->convert($l) if ($self->{iconv});
252            
253                                    $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
254    
255                                    ## FIXME remove this warning when we are sure that none of API is calling
256                                    ## this wrongly
257                                    #warn "filter called without field number" unless ($f_nr);
258    
259                                    return $l unless ($rec_regex && $f_nr);
260    
261                                    # apply regexps
262                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
263                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
264                                            my $c = 0;
265                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
266                                                    while ( eval '$l =~ ' . $r ) { $c++ };
267                                            }
268                                            warn "## field $f_nr triggered $c regexpes\n" if ($c && $self->{debug});
269                                    }
270    
271                                    return $l;
272                    },
273                    %{ $arg },
274            );
275    
276            unless (defined($db)) {
277                    $log->logwarn("can't open database $arg->{path}, skipping...");
278                    return;
279            }
280    
281            unless ($size) {
282                    $log->logwarn("no records in database $arg->{path}, skipping...");
283                    return;
284            }
285    
286            my $from_rec = 1;
287            my $to_rec = $size;
288    
289            if (my $s = $self->{offset}) {
290                    $log->debug("skipping to MFN $s");
291                    $from_rec = $s;
292            } else {
293                    $self->{offset} = $from_rec;
294            }
295    
296            if ($self->{limit}) {
297                    $log->debug("limiting to ",$self->{limit}," records");
298                    $to_rec = $from_rec + $self->{limit} - 1;
299                    $to_rec = $size if ($to_rec > $size);
300            }
301    
302            # store size for later
303            $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
304    
305            $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{encoding}", $self->{stats} ? ' [stats]' : '');
306    
307            # read database
308            for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
309    
310                    $log->debug("position: $pos\n");
311    
312                    my $rec = $self->{fetch_rec}->($self, $db, $pos );
313    
314                    $log->debug(sub { Dumper($rec) });
315    
316                    if (! $rec) {
317                            $log->warn("record $pos empty? skipping...");
318                            next;
319                    }
320    
321                    # store
322                    if ($self->{low_mem}) {
323                            $self->{db}->put($pos, $rec);
324                    } else {
325                            $self->{data}->{$pos} = $rec;
326                    }
327    
328                    # create lookup
329                    $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
330    
331                    # update counters for statistics
332                    if ($self->{stats}) {
333    
334                            foreach my $fld (keys %{ $rec }) {
335                                    $self->{_stats}->{fld}->{ $fld }++;
336    
337                                    $log->logdie("invalid record fild $fld, not ARRAY")
338                                            unless (ref($rec->{ $fld }) eq 'ARRAY');
339            
340                                    foreach my $row (@{ $rec->{$fld} }) {
341    
342                                            if (ref($row) eq 'HASH') {
343    
344                                                    foreach my $sf (keys %{ $row }) {
345                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
346                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
347                                                                            if (ref($row->{$sf}) eq 'ARRAY');
348                                                    }
349    
350                                            } else {
351                                                    $self->{_stats}->{repeatable}->{ $fld }++;
352                                            }
353                                    }
354                            }
355                    }
356    
357                    $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
358    
359            }
360    
361            $self->{pos} = -1;
362            $self->{last_pcnt} = 0;
363    
364            # store max mfn and return it.
365            $self->{max_pos} = $to_rec;
366            $log->debug("max_pos: $to_rec");
367    
368            return $size;
369    }
370    
371    =head2 fetch
372    
373    Fetch next record from database. It will also displays progress bar.
374    
375     my $rec = $isis->fetch;
376    
377    Record from this function should probably go to C<data_structure> for
378    normalisation.
379    
380    =cut
381    
382    sub fetch {
383            my $self = shift;
384    
385            my $log = $self->_get_logger();
386    
387            $log->logconfess("it seems that you didn't load database!") unless ($self->{pos});
388    
389            if ($self->{pos} == -1) {
390                    $self->{pos} = $self->{offset};
391            } else {
392                    $self->{pos}++;
393            }
394    
395            my $mfn = $self->{pos};
396    
397            if ($mfn > $self->{max_pos}) {
398                    $self->{pos} = $self->{max_pos};
399                    $log->debug("at EOF");
400                    return;
401            }
402    
403            $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
404    
405            my $rec;
406    
407            if ($self->{low_mem}) {
408                    $rec = $self->{db}->get($mfn);
409            } else {
410                    $rec = $self->{data}->{$mfn};
411            }
412    
413            $rec ||= 0E0;
414    }
415    
416    =head2 pos
417    
418    Returns current record number (MFN).
419    
420     print $isis->pos;
421    
422    First record in database has position 1.
423    
424    =cut
425    
426    sub pos {
427            my $self = shift;
428            return $self->{pos};
429    }
430    
431    
432    =head2 size
433    
434    Returns number of records in database
435    
436     print $isis->size;
437    
438    Result from this function can be used to loop through all records
439    
440     foreach my $mfn ( 1 ... $isis->size ) { ... }
441    
442    because it takes into account C<offset> and C<limit>.
443    
444    =cut
445    
446    sub size {
447            my $self = shift;
448            return $self->{size};
449    }
450    
451    =head2 seek
452    
453    Seek to specified MFN in file.
454    
455     $isis->seek(42);
456    
457    First record in database has position 1.
458    
459    =cut
460    
461    sub seek {
462            my $self = shift;
463            my $pos = shift || return;
464    
465            my $log = $self->_get_logger();
466    
467            if ($pos < 1) {
468                    $log->warn("seek before first record");
469                    $pos = 1;
470            } elsif ($pos > $self->{max_pos}) {
471                    $log->warn("seek beyond last record");
472                    $pos = $self->{max_pos};
473            }
474    
475            return $self->{pos} = (($pos - 1) || -1);
476    }
477    
478    =head2 stats
479    
480    Dump statistics about field and subfield usage
481    
482      print $input->stats;
483    
484    =cut
485    
486    sub stats {
487            my $self = shift;
488    
489            my $log = $self->_get_logger();
490    
491            my $s = $self->{_stats};
492            if (! $s) {
493                    $log->warn("called stats, but there is no statistics collected");
494                    return;
495            }
496    
497            my $max_fld = 0;
498    
499            my $out = join("\n",
500                    map {
501                            my $f = $_ || die "no field";
502                            my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
503                            $max_fld = $v if ($v > $max_fld);
504    
505                            my $o = sprintf("%4s %d ~", $f, $v);
506    
507                            if (defined($s->{sf}->{$f})) {
508                                    map {
509                                            $o .= sprintf(" %s:%d%s", $_,
510                                                    $s->{sf}->{$f}->{$_}->{count},
511                                                    $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
512                                            );
513                                    } sort keys %{ $s->{sf}->{$f} };
514                            }
515    
516                            if (my $v_r = $s->{repeatable}->{$f}) {
517                                    $o .= " ($v_r)" if ($v_r != $v);
518                            }
519    
520                            $o;
521                    } sort { $a cmp $b } keys %{ $s->{fld} }
522            );
523    
524            $log->debug( sub { Dumper($s) } );
525    
526            return $out;
527    }
528    
529    =head2 modify_record_regexps
530    
531    Generate hash with regexpes to be applied using L<filter>.
532    
533      my $regexpes = $input->modify_record_regexps(
534                    900 => { '^a' => { ' : ' => '^b' } },
535                    901 => { '*' => { '^b' => ' ; ' } },
536      );
537    
538    =cut
539    
540    sub modify_record_regexps {
541            my $self = shift;
542            my $modify_record = {@_};
543    
544            my $regexpes;
545    
546            foreach my $f (keys %$modify_record) {
547    warn "--- f: $f\n";
548                    foreach my $sf (keys %{ $modify_record->{$f} }) {
549    warn "---- sf: $sf\n";
550                            foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
551                                    my $to = $modify_record->{$f}->{$sf}->{$from};
552                                    #die "no field?" unless defined($to);
553    warn "----- transform: |$from| -> |$to|\n";
554    
555                                    if ($sf =~ /^\^/) {
556                                            my $regex =
557                                                    's/\Q'. $sf .'\E([^\^]+)\Q'. $from .'\E([^\^]+)/'. $sf .'$1'. $to .'$2/g';
558                                            push @{ $regexpes->{$f} }, $regex;
559    warn ">>>>> $regex [sf]\n";
560                                    } else {
561                                            my $regex =
562                                                    's/\Q'. $from .'\E/'. $to .'/g';
563                                            push @{ $regexpes->{$f} }, $regex;
564    warn ">>>>> $regex [global]\n";
565                                    }
566    
567                            }
568                    }
569            }
570    
571            return $regexpes;
572    }
573    
574  =head1 MEMORY USAGE  =head1 MEMORY USAGE
575    
576  C<low_mem> options is double-edged sword. If enabled, WebPAC  C<low_mem> options is double-edged sword. If enabled, WebPAC
# Line 131  Dobrica Pavlinusic, C<< <dpavlin@rot13.o Line 608  Dobrica Pavlinusic, C<< <dpavlin@rot13.o
608    
609  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
610    
611  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
612    
613  This program is free software; you can redistribute it and/or modify it  This program is free software; you can redistribute it and/or modify it
614  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.11  
changed lines
  Added in v.606
  ViewVC Help
Powered by ViewVC 1.1.26