/[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 285 by dpavlin, Sun Dec 18 21:06:39 2005 UTC revision 613 by dpavlin, Wed Aug 23 11:04:32 2006 UTC
# Line 8  use blib; Line 8  use blib;
8  use WebPAC::Common;  use WebPAC::Common;
9  use base qw/WebPAC::Common/;  use base qw/WebPAC::Common/;
10  use Text::Iconv;  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.02  Version 0.10
20    
21  =cut  =cut
22    
23  our $VERSION = '0.02';  our $VERSION = '0.10';
24    
25  =head1 SYNOPSIS  =head1 SYNOPSIS
26    
27  This module is used as base class for all database specific modules  This module implements input as database which have fixed and known
28  (basically, files which have one handle, fixed size while indexing and some  I<size> while indexing and single unique numeric identifier for database
29  kind of numeric idefinirier which goes from 1 to filesize).  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 51  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  This function will also call low-level C<init> if it exists with same
86  parametars.  parametars.
87    
# Line 74  sub new { Line 94  sub new {
94    
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          # check if required subclasses are implemented
110          foreach my $subclass (qw/open_db fetch_rec/) {          foreach my $subclass (qw/open_db fetch_rec init/) {
111                  $log->logdie("missing implementation of $subclass") unless ($self->SUPER::can($subclass));                  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->can('init')) {          if ($self->{init}) {
121                  $log->debug("calling init");                  $log->debug("calling init");
122                  $self->init(@_);                  $self->{init}->($self, @_);
123          }          }
124    
125          $self->{'code_page'} ||= 'ISO-8859-2';          $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'}) {
# Line 119  sub new { Line 157  sub new {
157    
158  This function will read whole database in memory and produce lookups.  This function will read whole database in memory and produce lookups.
159    
160   $isis->open(   $input->open(
161          path => '/path/to/database/file',          path => '/path/to/database/file',
162          code_page => '852',          code_page => '852',
163          limit_mfn => 500,          limit => 500,
164          start_mfn => 6000,          offset => 6000,
165          lookup => $lookup_obj,          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>.  By default, C<code_page> is assumed to be C<852>.
178    
179  If optional parametar C<start_mfn> is set, this will be first MFN to read  C<offset> is optional parametar to position at some offset before reading from database.
180  from database (so you can skip beginning of your database if you need to).  
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  If optional parametar C<limit_mfn> is set, it will read just 500 records  C<modify_records> specify mapping from subfields to delimiters or from
189  from database in example above.  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<start_mfn> and C<limit_mfn>  Returns size of database, regardless of C<offset> and C<limit>
193  parametars, see also C<$isis->size>.  parametars, see also C<size>.
194    
195  =cut  =cut
196    
# Line 146  sub open { Line 200  sub open {
200    
201          my $log = $self->_get_logger();          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'});          $log->logcroak("need path") if (! $arg->{'path'});
208          my $code_page = $arg->{'code_page'} || '852';          my $code_page = $arg->{'code_page'} || '852';
209    
210          # store data in object          # store data in object
211          $self->{'code_page'} = $code_page;          $self->{'input_code_page'} = $code_page;
212          foreach my $v (qw/path start_mfn limit_mfn/) {          foreach my $v (qw/path offset limit/) {
213                  $self->{$v} = $arg->{$v} if ($arg->{$v});                  $self->{$v} = $arg->{$v} if ($arg->{$v});
214          }          }
215    
216          # create Text::Iconv object          # create Text::Iconv object
217          $self->{iconv} = Text::Iconv->new($code_page,$self->{'code_page'});          $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 ($db, $size) = $self->open_db(          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},                  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    #                               my $max_regex = 100;
262    
263                                    # apply regexps
264                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
265                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
266                                            my $c = 0;
267                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
268                                                    #$log->debug("\$l = $l\neval \$l =~ $r");
269                                                    eval '$l =~ ' . $r;
270                                                    $log->error("error applying regex: $r") if ($@);
271    
272    #                                               while ( $c < $max_regex && eval '$l =~ ' . $r ) { $c++ };
273    #                                               $log->error("field $f_nr has more than $max_regex regex iterations\n\$l = $l\neval \$l =~ $r") if ($c == $max_regex);
274    
275                                            }
276                                    }
277    
278                                    return $l;
279                    },
280                    %{ $arg },
281          );          );
282    
283          unless ($db) {          unless (defined($db)) {
284                  $log->logwarn("can't open database $arg->{path}, skipping...");                  $log->logwarn("can't open database $arg->{path}, skipping...");
285                  return;                  return;
286          }          }
# Line 172  sub open { Line 290  sub open {
290                  return;                  return;
291          }          }
292    
293          my $startmfn = 1;          my $from_rec = 1;
294          my $maxmfn = $size;          my $to_rec = $size;
295    
296          if (my $s = $self->{start_mfn}) {          if (my $s = $self->{offset}) {
297                  $log->info("skipping to MFN $s");                  $log->debug("skipping to MFN $s");
298                  $startmfn = $s;                  $from_rec = $s;
299          } else {          } else {
300                  $self->{start_mfn} = $startmfn;                  $self->{offset} = $from_rec;
301          }          }
302    
303          if ($self->{limit_mfn}) {          if ($self->{limit}) {
304                  $log->info("limiting to ",$self->{limit_mfn}," records");                  $log->debug("limiting to ",$self->{limit}," records");
305                  $maxmfn = $startmfn + $self->{limit_mfn} - 1;                  $to_rec = $from_rec + $self->{limit} - 1;
306                  $maxmfn = $size if ($maxmfn > $size);                  $to_rec = $size if ($to_rec > $size);
307          }          }
308    
309          # store size for later          # store size for later
310          $self->{size} = ($maxmfn - $startmfn) ? ($maxmfn - $startmfn + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
311    
312          $log->info("processing $self->{size} records in $code_page, convert to $self->{code_page}");          $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{encoding}", $self->{stats} ? ' [stats]' : '');
313    
314          # read database          # read database
315          for (my $mfn = $startmfn; $mfn <= $maxmfn; $mfn++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
316    
317                    $log->debug("position: $pos\n");
318    
319                  $log->debug("mfn: $mfn\n");                  my $rec = $self->{fetch_rec}->($self, $db, $pos );
320    
321                  my $rec = $self->fetch_rec( $db, $mfn );                  $log->debug(sub { Dumper($rec) });
322    
323                  if (! $rec) {                  if (! $rec) {
324                          $log->warn("record $mfn empty? skipping...");                          $log->warn("record $pos empty? skipping...");
325                          next;                          next;
326                  }                  }
327    
328                  # store                  # store
329                  if ($self->{'low_mem'}) {                  if ($self->{low_mem}) {
330                          $self->{'db'}->put($mfn, $rec);                          $self->{db}->put($pos, $rec);
331                  } else {                  } else {
332                          $self->{'data'}->{$mfn} = $rec;                          $self->{data}->{$pos} = $rec;
333                  }                  }
334    
335                  # create lookup                  # create lookup
336                  $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});                  $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
337    
338                  $self->progress_bar($mfn,$maxmfn);                  # update counters for statistics
339                    if ($self->{stats}) {
340    
341          }                          foreach my $fld (keys %{ $rec }) {
342                                    $self->{_stats}->{fld}->{ $fld }++;
343    
344                                    $log->logdie("invalid record fild $fld, not ARRAY")
345                                            unless (ref($rec->{ $fld }) eq 'ARRAY');
346            
347                                    foreach my $row (@{ $rec->{$fld} }) {
348    
349                                            if (ref($row) eq 'HASH') {
350    
351                                                    foreach my $sf (keys %{ $row }) {
352                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
353                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
354                                                                            if (ref($row->{$sf}) eq 'ARRAY');
355                                                    }
356    
357                                            } else {
358                                                    $self->{_stats}->{repeatable}->{ $fld }++;
359                                            }
360                                    }
361                            }
362                    }
363    
364                    $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
365    
366          $self->{'current_mfn'} = -1;          }
         $self->{'last_pcnt'} = 0;  
367    
368          $log->debug("max mfn: $maxmfn");          $self->{pos} = -1;
369            $self->{last_pcnt} = 0;
370    
371          # store max mfn and return it.          # store max mfn and return it.
372          $self->{'max_mfn'} = $maxmfn;          $self->{max_pos} = $to_rec;
373            $log->debug("max_pos: $to_rec");
374    
375          return $size;          return $size;
376  }  }
# Line 246  sub fetch { Line 391  sub fetch {
391    
392          my $log = $self->_get_logger();          my $log = $self->_get_logger();
393    
394          $log->logconfess("it seems that you didn't load database!") unless ($self->{'current_mfn'});          $log->logconfess("it seems that you didn't load database!") unless ($self->{pos});
395    
396          if ($self->{'current_mfn'} == -1) {          if ($self->{pos} == -1) {
397                  $self->{'current_mfn'} = $self->{'start_mfn'};                  $self->{pos} = $self->{offset};
398          } else {          } else {
399                  $self->{'current_mfn'}++;                  $self->{pos}++;
400          }          }
401    
402          my $mfn = $self->{'current_mfn'};          my $mfn = $self->{pos};
403    
404          if ($mfn > $self->{'max_mfn'}) {          if ($mfn > $self->{max_pos}) {
405                  $self->{'current_mfn'} = $self->{'max_mfn'};                  $self->{pos} = $self->{max_pos};
406                  $log->debug("at EOF");                  $log->debug("at EOF");
407                  return;                  return;
408          }          }
409    
410          $self->progress_bar($mfn,$self->{'max_mfn'});          $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
411    
412          my $rec;          my $rec;
413    
414          if ($self->{'low_mem'}) {          if ($self->{low_mem}) {
415                  $rec = $self->{'db'}->get($mfn);                  $rec = $self->{db}->get($mfn);
416          } else {          } else {
417                  $rec = $self->{'data'}->{$mfn};                  $rec = $self->{data}->{$mfn};
418          }          }
419    
420          $rec ||= 0E0;          $rec ||= 0E0;
# Line 287  First record in database has position 1. Line 432  First record in database has position 1.
432    
433  sub pos {  sub pos {
434          my $self = shift;          my $self = shift;
435          return $self->{'current_mfn'};          return $self->{pos};
436  }  }
437    
438    
# Line 301  Result from this function can be used to Line 446  Result from this function can be used to
446    
447   foreach my $mfn ( 1 ... $isis->size ) { ... }   foreach my $mfn ( 1 ... $isis->size ) { ... }
448    
449  because it takes into account C<start_mfn> and C<limit_mfn>.  because it takes into account C<offset> and C<limit>.
450    
451  =cut  =cut
452    
453  sub size {  sub size {
454          my $self = shift;          my $self = shift;
455          return $self->{'size'};          return $self->{size};
456  }  }
457    
458  =head2 seek  =head2 seek
# Line 329  sub seek { Line 474  sub seek {
474          if ($pos < 1) {          if ($pos < 1) {
475                  $log->warn("seek before first record");                  $log->warn("seek before first record");
476                  $pos = 1;                  $pos = 1;
477          } elsif ($pos > $self->{'max_mfn'}) {          } elsif ($pos > $self->{max_pos}) {
478                  $log->warn("seek beyond last record");                  $log->warn("seek beyond last record");
479                  $pos = $self->{'max_mfn'};                  $pos = $self->{max_pos};
480          }          }
481    
482          return $self->{'current_mfn'} = (($pos - 1) || -1);          return $self->{pos} = (($pos - 1) || -1);
483  }  }
484    
485    =head2 stats
486    
487    Dump statistics about field and subfield usage
488    
489      print $input->stats;
490    
491    =cut
492    
493    sub stats {
494            my $self = shift;
495    
496            my $log = $self->_get_logger();
497    
498            my $s = $self->{_stats};
499            if (! $s) {
500                    $log->warn("called stats, but there is no statistics collected");
501                    return;
502            }
503    
504            my $max_fld = 0;
505    
506            my $out = join("\n",
507                    map {
508                            my $f = $_ || die "no field";
509                            my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
510                            $max_fld = $v if ($v > $max_fld);
511    
512                            my $o = sprintf("%4s %d ~", $f, $v);
513    
514                            if (defined($s->{sf}->{$f})) {
515                                    map {
516                                            $o .= sprintf(" %s:%d%s", $_,
517                                                    $s->{sf}->{$f}->{$_}->{count},
518                                                    $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
519                                            );
520                                    } sort keys %{ $s->{sf}->{$f} };
521                            }
522    
523                            if (my $v_r = $s->{repeatable}->{$f}) {
524                                    $o .= " ($v_r)" if ($v_r != $v);
525                            }
526    
527                            $o;
528                    } sort { $a cmp $b } keys %{ $s->{fld} }
529            );
530    
531            $log->debug( sub { Dumper($s) } );
532    
533            return $out;
534    }
535    
536    =head2 modify_record_regexps
537    
538    Generate hash with regexpes to be applied using L<filter>.
539    
540      my $regexpes = $input->modify_record_regexps(
541                    900 => { '^a' => { ' : ' => '^b' } },
542                    901 => { '*' => { '^b' => ' ; ' } },
543      );
544    
545    =cut
546    
547    sub modify_record_regexps {
548            my $self = shift;
549            my $modify_record = {@_};
550    
551            my $regexpes;
552    
553            foreach my $f (keys %$modify_record) {
554    warn "--- f: $f\n";
555                    foreach my $sf (keys %{ $modify_record->{$f} }) {
556    warn "---- sf: $sf\n";
557                            foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
558                                    my $to = $modify_record->{$f}->{$sf}->{$from};
559                                    #die "no field?" unless defined($to);
560    warn "----- transform: |$from| -> |$to|\n";
561    
562                                    if ($sf =~ /^\^/) {
563                                            my $regex =
564                                                    's/\Q'. $sf .'\E([^\^]+)\Q'. $from .'\E([^\^]+)/'. $sf .'$1'. $to .'$2/g';
565                                            push @{ $regexpes->{$f} }, $regex;
566    warn ">>>>> $regex [sf]\n";
567                                    } else {
568                                            my $regex =
569                                                    's/\Q'. $from .'\E/'. $to .'/g';
570                                            push @{ $regexpes->{$f} }, $regex;
571    warn ">>>>> $regex [global]\n";
572                                    }
573    
574                            }
575                    }
576            }
577    
578            return $regexpes;
579    }
580    
581  =head1 MEMORY USAGE  =head1 MEMORY USAGE
582    
# Line 375  Dobrica Pavlinusic, C<< <dpavlin@rot13.o Line 615  Dobrica Pavlinusic, C<< <dpavlin@rot13.o
615    
616  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
617    
618  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
619    
620  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
621  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.285  
changed lines
  Added in v.613
  ViewVC Help
Powered by ViewVC 1.1.26