/[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 289 by dpavlin, Sun Dec 18 22:16:44 2005 UTC revision 757 by dpavlin, Tue Oct 10 10:57:59 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    
# Line 15  WebPAC::Input - read different file form Line 16  WebPAC::Input - read different file form
16    
17  =head1 VERSION  =head1 VERSION
18    
19  Version 0.03  Version 0.13
20    
21  =cut  =cut
22    
23  our $VERSION = '0.03';  our $VERSION = '0.13';
24    
25  =head1 SYNOPSIS  =head1 SYNOPSIS
26    
# Line 38  C<fetch_rec> and optional C<init> functi Line 39  C<fetch_rec> and optional C<init> functi
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(          my $db = WebPAC::Input->new(
45          module => 'WebPAC::Input::ISIS',                  module => 'WebPAC::Input::ISIS',
                 config => $config,  
                 lookup => $lookup_obj,  
46                  low_mem => 1,                  low_mem => 1,
47      );          );
48    
49      $db->open('/path/to/database');          $db->open( path => '/path/to/database' );
50      print "database size: ",$db->size,"\n";          print "database size: ",$db->size,"\n";
51      while (my $rec = $db->fetch) {          while (my $rec = $db->fetch) {
52      }                  # do something with $rec
53            }
54    
55    
56    
# Line 62  Create new input database object. Line 62  Create new input database object.
62    
63    my $db = new WebPAC::Input(    my $db = new WebPAC::Input(
64          module => 'WebPAC::Input::MARC',          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  C<module> is low-level file format module. See L<WebPAC::Input::Isis> and  C<module> is low-level file format module. See L<WebPAC::Input::ISIS> and
72  L<WebPAC::Input::MARC>.  L<WebPAC::Input::MARC>.
73    
74  Optional parametar C<code_page> specify application code page (which will be  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 87  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});          $log->logconfess("specify low-level file format module") unless ($self->{module});
101          my $module = $self->{module};          my $module_path = $self->{module};
102          $module =~ s#::#/#g;          $module_path =~ s#::#/#g;
103          $module .= '.pm';          $module_path .= '.pm';
104          $log->debug("require low-level module $self->{module} from $module");          $log->debug("require low-level module $self->{module} from $module_path");
105    
106          require $module;          require $module_path;
         #eval $self->{module} .'->import';  
107    
108          # check if required subclasses are implemented          # check if required subclasses are implemented
109          foreach my $subclass (qw/open_db fetch_rec init/) {          foreach my $subclass (qw/open_db fetch_rec init dump_rec/) {
110                  my $n = $self->{module} . '::' . $subclass;                  # FIXME
                 if (! defined &{ $n }) {  
                         $log->logwarn("missing implementation of $subclass");  
                 } else {  
                         $self->{$subclass} = \&{ $n };  
                 }  
111          }          }
112    
113          if ($self->{init}) {          $self->{'encoding'} ||= 'ISO-8859-2';
                 $log->debug("calling init");  
                 $self->{init}->($self, @_);  
         }  
   
         $self->{'code_page'} ||= 'ISO-8859-2';  
114    
115          # running with low_mem flag? well, use DBM::Deep then.          # running with low_mem flag? well, use DBM::Deep then.
116          if ($self->{'low_mem'}) {          if ($self->{'low_mem'}) {
# Line 148  This function will read whole database i Line 147  This function will read whole database i
147    
148   $input->open(   $input->open(
149          path => '/path/to/database/file',          path => '/path/to/database/file',
150          code_page => '852',          code_page => 'cp852',
151          limit => 500,          limit => 500,
152          offset => 6000,          offset => 6000,
153          lookup => $lookup_obj,          stats => 1,
154            lookup_coderef => sub {
155                    my $rec = shift;
156                    # store lookups
157            },
158            modify_records => {
159                    900 => { '^a' => { ' : ' => '^b' } },
160                    901 => { '*' => { '^b' => ' ; ' } },
161            },
162            modify_file => 'conf/modify/mapping.map',
163   );   );
164    
165  By default, C<code_page> is assumed to be C<852>.  By default, C<code_page> is assumed to be C<cp852>.
166    
167  C<offset> is optional parametar to position at some offset before reading from database.  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  C<limit> is optional parametar to read just C<limit> records from database
170    
171    C<stats> create optional report about usage of fields and subfields
172    
173    C<lookup_coderef> is closure to called to save data into lookups
174    
175    C<modify_records> specify mapping from subfields to delimiters or from
176    delimiters to subfields, as well as oprations on fields (if subfield is
177    defined as C<*>.
178    
179    C<modify_file> is alternative for C<modify_records> above which preserves order and offers
180    (hopefully) simplier sintax than YAML or perl (see L</modify_file_regex>). This option
181    overrides C<modify_records> if both exists for same input.
182    
183  Returns size of database, regardless of C<offset> and C<limit>  Returns size of database, regardless of C<offset> and C<limit>
184  parametars, see also C<size>.  parametars, see also C<size>.
185    
# Line 171  sub open { Line 191  sub open {
191    
192          my $log = $self->_get_logger();          my $log = $self->_get_logger();
193    
194            $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_coderef") if ($arg->{lookup});
195            $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
196                    if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
197    
198            $log->debug( $arg->{lookup_coderef} ? '' : 'not ', "using lookup_coderef");
199    
200          $log->logcroak("need path") if (! $arg->{'path'});          $log->logcroak("need path") if (! $arg->{'path'});
201          my $code_page = $arg->{'code_page'} || '852';          my $code_page = $arg->{'code_page'} || 'cp852';
202    
203          # store data in object          # store data in object
204          $self->{'code_page'} = $code_page;          $self->{'input_code_page'} = $code_page;
205          foreach my $v (qw/path offset limit/) {          foreach my $v (qw/path offset limit/) {
206                  $self->{$v} = $arg->{$v} if ($arg->{$v});                  $self->{$v} = $arg->{$v} if ($arg->{$v});
207          }          }
208    
209          # create Text::Iconv object          my $filter_ref;
210          $self->{iconv} = Text::Iconv->new($code_page,$self->{'code_page'});          my $recode_regex;
211            my $recode_map;
212    
213            if ($self->{recode}) {
214                    my @r = split(/\s/, $self->{recode});
215                    if ($#r % 2 != 1) {
216                            $log->logwarn("recode needs even number of elements (some number of valid pairs)");
217                    } else {
218                            while (@r) {
219                                    my $from = shift @r;
220                                    my $to = shift @r;
221                                    $recode_map->{$from} = $to;
222                            }
223    
224                            $recode_regex = join '|' => keys %{ $recode_map };
225    
226          my ($db, $size) = $self->{open_db}->( $self,                          $log->debug("using recode regex: $recode_regex");
227                    }
228    
229            }
230    
231            my $rec_regex;
232            if (my $p = $arg->{modify_file}) {
233                    $log->debug("using modify_file $p");
234                    $rec_regex = $self->modify_file_regexps( $p );
235            } elsif (my $h = $arg->{modify_records}) {
236                    $log->debug("using modify_records ", Dumper( $h ));
237                    $rec_regex = $self->modify_record_regexps(%{ $h });
238            }
239            $log->debug("rec_regex: ", Dumper($rec_regex)) if ($rec_regex);
240    
241            my $class = $self->{module} || $log->logconfess("can't get low-level module name!");
242    
243            my $ll_db = $class->new(
244                  path => $arg->{path},                  path => $arg->{path},
245    #               filter => sub {
246    #                       my ($l,$f_nr) = @_;
247    #                       return unless defined($l);
248    #                       from_to($l, $code_page, $self->{'encoding'});
249    #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
250    #                       return $l;
251    #               },
252                    %{ $arg },
253          );          );
254    
255          unless ($db) {          unless (defined($ll_db)) {
256                  $log->logwarn("can't open database $arg->{path}, skipping...");                  $log->logwarn("can't open database $arg->{path}, skipping...");
257                  return;                  return;
258          }          }
259    
260            my $size = $ll_db->size;
261    
262          unless ($size) {          unless ($size) {
263                  $log->logwarn("no records in database $arg->{path}, skipping...");                  $log->logwarn("no records in database $arg->{path}, skipping...");
264                  return;                  return;
265          }          }
266    
267          my $offset = 1;          my $from_rec = 1;
268          my $limit = $size;          my $to_rec = $size;
269    
270          if (my $s = $self->{offset}) {          if (my $s = $self->{offset}) {
271                  $log->info("skipping to MFN $s");                  $log->debug("skipping to MFN $s");
272                  $offset = $s;                  $from_rec = $s;
273          } else {          } else {
274                  $self->{offset} = $offset;                  $self->{offset} = $from_rec;
275          }          }
276    
277          if ($self->{limit}) {          if ($self->{limit}) {
278                  $log->info("limiting to ",$self->{limit}," records");                  $log->debug("limiting to ",$self->{limit}," records");
279                  $limit = $offset + $self->{limit} - 1;                  $to_rec = $from_rec + $self->{limit} - 1;
280                  $limit = $size if ($limit > $size);                  $to_rec = $size if ($to_rec > $size);
281          }          }
282    
283          # store size for later          # store size for later
284          $self->{size} = ($limit - $offset) ? ($limit - $offset + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
285    
286          $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]' : '');
287    
288          # read database          # read database
289          for (my $pos = $offset; $pos <= $limit; $pos++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
290    
291                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
292    
293                  my $rec = $self->{fetch_rec}->($self, $db, $pos );                  my $rec = $ll_db->fetch_rec($pos, sub {
294                                    my ($l,$f_nr) = @_;
295    #                               return unless defined($l);
296    #                               return $l unless ($rec_regex && $f_nr);
297    
298                                    $log->debug("-=> $f_nr ## $l");
299    
300                                    # codepage conversion and recode_regex
301                                    from_to($l, $code_page, $self->{'encoding'});
302                                    $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
303    
304                                    # apply regexps
305                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
306                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
307                                            my $c = 0;
308                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
309                                                    my $old_l = $l;
310                                                    eval '$l =~ ' . $r;
311                                                    if ($old_l ne $l) {
312                                                            $log->debug("REGEX on $f_nr eval \$l =~ $r\n## old l: [$old_l]\n## new l: [$l]");
313                                                    }
314                                                    $log->error("error applying regex: $r") if ($@);
315                                            }
316                                    }
317    
318                                    $log->debug("<=- $f_nr ## $l");
319                                    return $l;
320                    });
321    
322                    $log->debug(sub { Dumper($rec) });
323    
324                  if (! $rec) {                  if (! $rec) {
325                          $log->warn("record $pos empty? skipping...");                          $log->warn("record $pos empty? skipping...");
# Line 238  sub open { Line 334  sub open {
334                  }                  }
335    
336                  # create lookup                  # create lookup
337                  $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});                  $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
338    
339                  $self->progress_bar($pos,$limit);                  # update counters for statistics
340                    if ($self->{stats}) {
341    
342                            # fetch clean record with regexpes applied for statistics
343                            my $rec = $ll_db->fetch_rec($pos);
344    
345                            foreach my $fld (keys %{ $rec }) {
346                                    $self->{_stats}->{fld}->{ $fld }++;
347    
348                                    $log->logdie("invalid record fild $fld, not ARRAY")
349                                            unless (ref($rec->{ $fld }) eq 'ARRAY');
350            
351                                    foreach my $row (@{ $rec->{$fld} }) {
352    
353                                            if (ref($row) eq 'HASH') {
354    
355                                                    foreach my $sf (keys %{ $row }) {
356                                                            next if ($sf eq 'subfields');
357                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
358                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
359                                                                            if (ref($row->{$sf}) eq 'ARRAY');
360                                                    }
361    
362                                            } else {
363                                                    $self->{_stats}->{repeatable}->{ $fld }++;
364                                            }
365                                    }
366                            }
367                    }
368    
369                    $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
370    
371          }          }
372    
# Line 248  sub open { Line 374  sub open {
374          $self->{last_pcnt} = 0;          $self->{last_pcnt} = 0;
375    
376          # store max mfn and return it.          # store max mfn and return it.
377          $self->{max_pos} = $limit;          $self->{max_pos} = $to_rec;
378          $log->debug("max_pos: $limit");          $log->debug("max_pos: $to_rec");
379    
380            # save for dump
381            $self->{ll_db} = $ll_db;
382    
383          return $size;          return $size;
384  }  }
# Line 286  sub fetch { Line 415  sub fetch {
415                  return;                  return;
416          }          }
417    
418          $self->progress_bar($mfn,$self->{max_pos});          $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
419    
420          my $rec;          my $rec;
421    
# Line 361  sub seek { Line 490  sub seek {
490          return $self->{pos} = (($pos - 1) || -1);          return $self->{pos} = (($pos - 1) || -1);
491  }  }
492    
493    =head2 stats
494    
495    Dump statistics about field and subfield usage
496    
497      print $input->stats;
498    
499    =cut
500    
501    sub stats {
502            my $self = shift;
503    
504            my $log = $self->_get_logger();
505    
506            my $s = $self->{_stats};
507            if (! $s) {
508                    $log->warn("called stats, but there is no statistics collected");
509                    return;
510            }
511    
512            my $max_fld = 0;
513    
514            my $out = join("\n",
515                    map {
516                            my $f = $_ || die "no field";
517                            my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
518                            $max_fld = $v if ($v > $max_fld);
519    
520                            my $o = sprintf("%4s %d ~", $f, $v);
521    
522                            if (defined($s->{sf}->{$f})) {
523                                    map {
524                                            $o .= sprintf(" %s:%d%s", $_,
525                                                    $s->{sf}->{$f}->{$_}->{count},
526                                                    $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
527                                            );
528                                    } sort keys %{ $s->{sf}->{$f} };
529                            }
530    
531                            if (my $v_r = $s->{repeatable}->{$f}) {
532                                    $o .= " ($v_r)" if ($v_r != $v);
533                            }
534    
535                            $o;
536                    } sort { $a cmp $b } keys %{ $s->{fld} }
537            );
538    
539            $log->debug( sub { Dumper($s) } );
540    
541            return $out;
542    }
543    
544    =head2 dump
545    
546    Display humanly readable dump of record
547    
548    =cut
549    
550    sub dump {
551            my $self = shift;
552    
553            return $self->{ll_db}->dump_rec( $self->{pos} );
554    
555    }
556    
557    =head2 modify_record_regexps
558    
559    Generate hash with regexpes to be applied using l<filter>.
560    
561      my $regexpes = $input->modify_record_regexps(
562                    900 => { '^a' => { ' : ' => '^b' } },
563                    901 => { '*' => { '^b' => ' ; ' } },
564      );
565    
566    =cut
567    
568    sub _get_regex {
569            my ($sf,$from,$to) = @_;
570            if ($sf =~ /^\^/) {
571                    return
572                            's/\Q'. $sf .'\E([^\^]*?)\Q'. $from .'\E([^\^]*?)/'. $sf .'$1'. $to .'$2/';
573            } else {
574                    return
575                            's/\Q'. $from .'\E/'. $to .'/g';
576            }
577    }
578    
579    sub modify_record_regexps {
580            my $self = shift;
581            my $modify_record = {@_};
582    
583            my $regexpes;
584    
585            my $log = $self->_get_logger();
586    
587            foreach my $f (keys %$modify_record) {
588                    $log->debug("field: $f");
589    
590                    foreach my $sf (keys %{ $modify_record->{$f} }) {
591                            $log->debug("subfield: $sf");
592    
593                            foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
594                                    my $to = $modify_record->{$f}->{$sf}->{$from};
595                                    #die "no field?" unless defined($to);
596                                    $log->debug("transform: |$from| -> |$to|");
597    
598                                    my $regex = _get_regex($sf,$from,$to);
599                                    push @{ $regexpes->{$f} }, $regex;
600                                    $log->debug("regex: $regex");
601                            }
602                    }
603            }
604    
605            return $regexpes;
606    }
607    
608    =head2 modify_file_regexps
609    
610    Generate hash with regexpes to be applied using l<filter> from
611    pseudo hash/yaml format for regex mappings.
612    
613    It should be obvious:
614    
615            200
616              '^a'
617                ' : ' => '^e'
618                ' = ' => '^d'
619    
620    In field I<200> find C<'^a'> and then C<' : '>, and replace it with C<'^e'>.
621    In field I<200> find C<'^a'> and then C<' = '>, and replace it with C<'^d'>.
622    
623      my $regexpes = $input->modify_file_regexps( 'conf/modify/common.pl' );
624    
625    On undef path it will just return.
626    
627    =cut
628    
629    sub modify_file_regexps {
630            my $self = shift;
631    
632            my $modify_path = shift || return;
633    
634            my $log = $self->_get_logger();
635    
636            my $regexpes;
637    
638            CORE::open(my $fh, $modify_path) || $log->logdie("can't open modify file $modify_path: $!");
639    
640            my ($f,$sf);
641    
642            while(<$fh>) {
643                    chomp;
644                    next if (/^#/ || /^\s*$/);
645    
646                    if (/^\s*(\d+)\s*$/) {
647                            $f = $1;
648                            $log->debug("field: $f");
649                            next;
650                    } elsif (/^\s*'([^']*)'\s*$/) {
651                            $sf = $1;
652                            $log->die("can't define subfiled before field in: $_") unless ($f);
653                            $log->debug("subfield: $sf");
654                    } elsif (/^\s*'([^']*)'\s*=>\s*'([^']*)'\s*$/) {
655                            my ($from,$to) = ($1, $2);
656    
657                            $log->debug("transform: |$from| -> |$to|");
658    
659                            my $regex = _get_regex($sf,$from,$to);
660                            push @{ $regexpes->{$f} }, $regex;
661                            $log->debug("regex: $regex");
662                    }
663            }
664    
665            return $regexpes;
666    }
667    
668  =head1 MEMORY USAGE  =head1 MEMORY USAGE
669    
# Line 399  Dobrica Pavlinusic, C<< <dpavlin@rot13.o Line 702  Dobrica Pavlinusic, C<< <dpavlin@rot13.o
702    
703  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
704    
705  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
706    
707  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
708  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.289  
changed lines
  Added in v.757
  ViewVC Help
Powered by ViewVC 1.1.26