/[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 625 by dpavlin, Sat Aug 26 12:00:36 2006 UTC
# Line 7  use blib; Line 7  use blib;
7    
8  use WebPAC::Common;  use WebPAC::Common;
9  use base qw/WebPAC::Common/;  use base qw/WebPAC::Common/;
10  use Text::Iconv;  use Data::Dumper;
11    use Encode qw/from_to/;
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.11
20    
21  =cut  =cut
22    
23  our $VERSION = '0.02';  our $VERSION = '0.11';
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 => 'cp852',
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<cp852>.
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  If optional parametar C<start_mfn> is set, this will be first MFN to read  C<lookup_coderef> is closure to call when adding C<< key => 'value' >> combinations to
186  from database (so you can skip beginning of your database if you need to).  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'} || 'cp852';
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          my $filter_ref;
217          $self->{iconv} = Text::Iconv->new($code_page,$self->{'code_page'});          my $recode_regex;
218            my $recode_map;
219    
220            if ($self->{recode}) {
221                    my @r = split(/\s/, $self->{recode});
222                    if ($#r % 2 != 1) {
223                            $log->logwarn("recode needs even number of elements (some number of valid pairs)");
224                    } else {
225                            while (@r) {
226                                    my $from = shift @r;
227                                    my $to = shift @r;
228                                    $recode_map->{$from} = $to;
229                            }
230    
231                            $recode_regex = join '|' => keys %{ $recode_map };
232    
233                            $log->debug("using recode regex: $recode_regex");
234                    }
235    
236            }
237    
238            my $rec_regex = $self->modify_record_regexps(%{ $arg->{modify_records} });
239            $log->debug("rec_regex: ", Dumper($rec_regex));
240    
241          my ($db, $size) = $self->open_db(          my ($db, $size) = $self->{open_db}->( $self,
242                  path => $arg->{path},                  path => $arg->{path},
243    #               filter => sub {
244    #                       my ($l,$f_nr) = @_;
245    #                       return unless defined($l);
246    #                       from_to($l, $code_page, $self->{'encoding'});
247    #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
248    #                       return $l;
249    #               },
250                    %{ $arg },
251          );          );
252    
253          unless ($db) {          unless (defined($db)) {
254                  $log->logwarn("can't open database $arg->{path}, skipping...");                  $log->logwarn("can't open database $arg->{path}, skipping...");
255                  return;                  return;
256          }          }
# Line 172  sub open { Line 260  sub open {
260                  return;                  return;
261          }          }
262    
263          my $startmfn = 1;          my $from_rec = 1;
264          my $maxmfn = $size;          my $to_rec = $size;
265    
266          if (my $s = $self->{start_mfn}) {          if (my $s = $self->{offset}) {
267                  $log->info("skipping to MFN $s");                  $log->debug("skipping to MFN $s");
268                  $startmfn = $s;                  $from_rec = $s;
269          } else {          } else {
270                  $self->{start_mfn} = $startmfn;                  $self->{offset} = $from_rec;
271          }          }
272    
273          if ($self->{limit_mfn}) {          if ($self->{limit}) {
274                  $log->info("limiting to ",$self->{limit_mfn}," records");                  $log->debug("limiting to ",$self->{limit}," records");
275                  $maxmfn = $startmfn + $self->{limit_mfn} - 1;                  $to_rec = $from_rec + $self->{limit} - 1;
276                  $maxmfn = $size if ($maxmfn > $size);                  $to_rec = $size if ($to_rec > $size);
277          }          }
278    
279          # store size for later          # store size for later
280          $self->{size} = ($maxmfn - $startmfn) ? ($maxmfn - $startmfn + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
281    
282          $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]' : '');
283    
284          # read database          # read database
285          for (my $mfn = $startmfn; $mfn <= $maxmfn; $mfn++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
286    
287                  $log->debug("mfn: $mfn\n");                  $log->debug("position: $pos\n");
288    
289                  my $rec = $self->fetch_rec( $db, $mfn );                  my $rec = $self->{fetch_rec}->($self, $db, $pos, sub {
290                                    my ($l,$f_nr) = @_;
291    #                               return unless defined($l);
292    #                               return $l unless ($rec_regex && $f_nr);
293    
294                                    $log->debug("-=> $f_nr ## $l");
295    
296                                    # codepage conversion and recode_regex
297    #                               from_to($l, $code_page, $self->{'encoding'});
298                                    from_to($l, $code_page, 'utf-8');
299                                    $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
300    
301                                    # apply regexps
302                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
303                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
304                                            my $c = 0;
305                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
306                                                    #$log->debug("\$l = $l\neval \$l =~ $r");
307                                                    eval '$l =~ ' . $r;
308                                                    $log->error("error applying regex: $r") if ($@);
309                                            }
310                                    }
311    
312                                    $log->debug("<=- $f_nr ## $l");
313                                    return $l;
314                    });
315    
316                    $log->debug(sub { Dumper($rec) });
317    
318                  if (! $rec) {                  if (! $rec) {
319                          $log->warn("record $mfn empty? skipping...");                          $log->warn("record $pos empty? skipping...");
320                          next;                          next;
321                  }                  }
322    
323                  # store                  # store
324                  if ($self->{'low_mem'}) {                  if ($self->{low_mem}) {
325                          $self->{'db'}->put($mfn, $rec);                          $self->{db}->put($pos, $rec);
326                  } else {                  } else {
327                          $self->{'data'}->{$mfn} = $rec;                          $self->{data}->{$pos} = $rec;
328                  }                  }
329    
330                  # create lookup                  # create lookup
331                  $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});                  $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
332    
333                  $self->progress_bar($mfn,$maxmfn);                  # update counters for statistics
334                    if ($self->{stats}) {
335    
336          }                          # fetch clean record with regexpes applied for statistics
337                            my $rec = $self->{fetch_rec}->($self, $db, $pos);
338    
339                            foreach my $fld (keys %{ $rec }) {
340                                    $self->{_stats}->{fld}->{ $fld }++;
341    
342                                    $log->logdie("invalid record fild $fld, not ARRAY")
343                                            unless (ref($rec->{ $fld }) eq 'ARRAY');
344            
345                                    foreach my $row (@{ $rec->{$fld} }) {
346    
347                                            if (ref($row) eq 'HASH') {
348    
349                                                    foreach my $sf (keys %{ $row }) {
350                                                            next if ($sf eq 'subfields');
351                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
352                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
353                                                                            if (ref($row->{$sf}) eq 'ARRAY');
354                                                    }
355    
356                                            } else {
357                                                    $self->{_stats}->{repeatable}->{ $fld }++;
358                                            }
359                                    }
360                            }
361                    }
362    
363          $self->{'current_mfn'} = -1;                  $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
         $self->{'last_pcnt'} = 0;  
364    
365          $log->debug("max mfn: $maxmfn");          }
366    
367            $self->{pos} = -1;
368            $self->{last_pcnt} = 0;
369    
370          # store max mfn and return it.          # store max mfn and return it.
371          $self->{'max_mfn'} = $maxmfn;          $self->{max_pos} = $to_rec;
372            $log->debug("max_pos: $to_rec");
373    
374          return $size;          return $size;
375  }  }
# Line 246  sub fetch { Line 390  sub fetch {
390    
391          my $log = $self->_get_logger();          my $log = $self->_get_logger();
392    
393          $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});
394    
395          if ($self->{'current_mfn'} == -1) {          if ($self->{pos} == -1) {
396                  $self->{'current_mfn'} = $self->{'start_mfn'};                  $self->{pos} = $self->{offset};
397          } else {          } else {
398                  $self->{'current_mfn'}++;                  $self->{pos}++;
399          }          }
400    
401          my $mfn = $self->{'current_mfn'};          my $mfn = $self->{pos};
402    
403          if ($mfn > $self->{'max_mfn'}) {          if ($mfn > $self->{max_pos}) {
404                  $self->{'current_mfn'} = $self->{'max_mfn'};                  $self->{pos} = $self->{max_pos};
405                  $log->debug("at EOF");                  $log->debug("at EOF");
406                  return;                  return;
407          }          }
408    
409          $self->progress_bar($mfn,$self->{'max_mfn'});          $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
410    
411          my $rec;          my $rec;
412    
413          if ($self->{'low_mem'}) {          if ($self->{low_mem}) {
414                  $rec = $self->{'db'}->get($mfn);                  $rec = $self->{db}->get($mfn);
415          } else {          } else {
416                  $rec = $self->{'data'}->{$mfn};                  $rec = $self->{data}->{$mfn};
417          }          }
418    
419          $rec ||= 0E0;          $rec ||= 0E0;
# Line 287  First record in database has position 1. Line 431  First record in database has position 1.
431    
432  sub pos {  sub pos {
433          my $self = shift;          my $self = shift;
434          return $self->{'current_mfn'};          return $self->{pos};
435  }  }
436    
437    
# Line 301  Result from this function can be used to Line 445  Result from this function can be used to
445    
446   foreach my $mfn ( 1 ... $isis->size ) { ... }   foreach my $mfn ( 1 ... $isis->size ) { ... }
447    
448  because it takes into account C<start_mfn> and C<limit_mfn>.  because it takes into account C<offset> and C<limit>.
449    
450  =cut  =cut
451    
452  sub size {  sub size {
453          my $self = shift;          my $self = shift;
454          return $self->{'size'};          return $self->{size};
455  }  }
456    
457  =head2 seek  =head2 seek
# Line 329  sub seek { Line 473  sub seek {
473          if ($pos < 1) {          if ($pos < 1) {
474                  $log->warn("seek before first record");                  $log->warn("seek before first record");
475                  $pos = 1;                  $pos = 1;
476          } elsif ($pos > $self->{'max_mfn'}) {          } elsif ($pos > $self->{max_pos}) {
477                  $log->warn("seek beyond last record");                  $log->warn("seek beyond last record");
478                  $pos = $self->{'max_mfn'};                  $pos = $self->{max_pos};
479          }          }
480    
481          return $self->{'current_mfn'} = (($pos - 1) || -1);          return $self->{pos} = (($pos - 1) || -1);
482  }  }
483    
484    =head2 stats
485    
486    Dump statistics about field and subfield usage
487    
488      print $input->stats;
489    
490    =cut
491    
492    sub stats {
493            my $self = shift;
494    
495            my $log = $self->_get_logger();
496    
497            my $s = $self->{_stats};
498            if (! $s) {
499                    $log->warn("called stats, but there is no statistics collected");
500                    return;
501            }
502    
503            my $max_fld = 0;
504    
505            my $out = join("\n",
506                    map {
507                            my $f = $_ || die "no field";
508                            my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
509                            $max_fld = $v if ($v > $max_fld);
510    
511                            my $o = sprintf("%4s %d ~", $f, $v);
512    
513                            if (defined($s->{sf}->{$f})) {
514                                    map {
515                                            $o .= sprintf(" %s:%d%s", $_,
516                                                    $s->{sf}->{$f}->{$_}->{count},
517                                                    $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
518                                            );
519                                    } sort keys %{ $s->{sf}->{$f} };
520                            }
521    
522                            if (my $v_r = $s->{repeatable}->{$f}) {
523                                    $o .= " ($v_r)" if ($v_r != $v);
524                            }
525    
526                            $o;
527                    } sort { $a cmp $b } keys %{ $s->{fld} }
528            );
529    
530            $log->debug( sub { Dumper($s) } );
531    
532            return $out;
533    }
534    
535    =head2 modify_record_regexps
536    
537    Generate hash with regexpes to be applied using L<filter>.
538    
539      my $regexpes = $input->modify_record_regexps(
540                    900 => { '^a' => { ' : ' => '^b' } },
541                    901 => { '*' => { '^b' => ' ; ' } },
542      );
543    
544    =cut
545    
546    sub modify_record_regexps {
547            my $self = shift;
548            my $modify_record = {@_};
549    
550            my $regexpes;
551    
552            foreach my $f (keys %$modify_record) {
553    warn "--- f: $f\n";
554                    foreach my $sf (keys %{ $modify_record->{$f} }) {
555    warn "---- sf: $sf\n";
556                            foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
557                                    my $to = $modify_record->{$f}->{$sf}->{$from};
558                                    #die "no field?" unless defined($to);
559    warn "----- transform: |$from| -> |$to|\n";
560    
561                                    if ($sf =~ /^\^/) {
562                                            my $regex =
563                                                    's/\Q'. $sf .'\E([^\^]+)\Q'. $from .'\E([^\^]+)/'. $sf .'$1'. $to .'$2/g';
564                                            push @{ $regexpes->{$f} }, $regex;
565    warn ">>>>> $regex [sf]\n";
566                                    } else {
567                                            my $regex =
568                                                    's/\Q'. $from .'\E/'. $to .'/g';
569                                            push @{ $regexpes->{$f} }, $regex;
570    warn ">>>>> $regex [global]\n";
571                                    }
572    
573                            }
574                    }
575            }
576    
577            return $regexpes;
578    }
579    
580  =head1 MEMORY USAGE  =head1 MEMORY USAGE
581    
# Line 375  Dobrica Pavlinusic, C<< <dpavlin@rot13.o Line 614  Dobrica Pavlinusic, C<< <dpavlin@rot13.o
614    
615  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
616    
617  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
618    
619  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
620  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.285  
changed lines
  Added in v.625
  ViewVC Help
Powered by ViewVC 1.1.26