/[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 793 by dpavlin, Sun Feb 4 12:19:51 2007 UTC revision 1307 by dpavlin, Mon Sep 21 16:42:25 2009 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;  use lib 'lib';
7    
8  use WebPAC::Common;  use WebPAC::Common;
9  use base qw/WebPAC::Common/;  use base qw/WebPAC::Common/;
10  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
11  use Encode qw/from_to/;  use Encode qw/decode from_to/;
12    use YAML;
13    
14  =head1 NAME  =head1 NAME
15    
16  WebPAC::Input - read different file formats into WebPAC  WebPAC::Input - read different file formats into WebPAC
17    
 =head1 VERSION  
   
 Version 0.17  
   
18  =cut  =cut
19    
20  our $VERSION = '0.17';  our $VERSION = '0.19';
21    
22  =head1 SYNOPSIS  =head1 SYNOPSIS
23    
# Line 61  Create new input database object. Line 58  Create new input database object.
58    
59    my $db = new WebPAC::Input(    my $db = new WebPAC::Input(
60          module => 'WebPAC::Input::MARC',          module => 'WebPAC::Input::MARC',
         encoding => 'ISO-8859-2',  
61          recode => 'char pairs',          recode => 'char pairs',
62          no_progress_bar => 1,          no_progress_bar => 1,
63            input_config => {
64                    mapping => [ 'foo', 'bar', 'baz' ],
65            },
66    );    );
67    
68  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
69  L<WebPAC::Input::MARC>.  L<WebPAC::Input::MARC>.
70    
 Optional parametar C<encoding> specify application code page (which will be  
 used internally). This should probably be your terminal encoding, and by  
 default, it C<ISO-8859-2>.  
   
71  C<recode> is optional string constisting of character or words pairs that  C<recode> is optional string constisting of character or words pairs that
72  should be replaced in input stream.  should be replaced in input stream.
73    
# Line 90  sub new { Line 85  sub new {
85    
86          my $log = $self->_get_logger;          my $log = $self->_get_logger;
87    
88          $log->logconfess("code_page argument is not suppored any more. change it to encoding") if ($self->{lookup});          $log->logconfess("code_page argument is not suppored any more.") if $self->{code_page};
89          $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if ($self->{lookup});          $log->logconfess("encoding argument is not suppored any more.") if $self->{encoding};
90          $log->logconfess("low_mem argument is not suppored any more. rewrite it to load_row and save_row") if ($self->{low_mem});          $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if $self->{lookup};
91            $log->logconfess("low_mem argument is not suppored any more. rewrite it to load_row and save_row") if $self->{low_mem};
92    
93          $log->logconfess("specify low-level file format module") unless ($self->{module});          $log->logconfess("specify low-level file format module") unless ($self->{module});
94          my $module_path = $self->{module};          my $module_path = $self->{module};
# Line 102  sub new { Line 98  sub new {
98    
99          require $module_path;          require $module_path;
100    
         $self->{'encoding'} ||= 'ISO-8859-2';  
   
101          $self ? return $self : return undef;          $self ? return $self : return undef;
102  }  }
103    
# Line 115  This function will read whole database i Line 109  This function will read whole database i
109    
110   $input->open(   $input->open(
111          path => '/path/to/database/file',          path => '/path/to/database/file',
112          code_page => 'cp852',          input_encoding => 'cp852',
113            strict_encoding => 0,
114          limit => 500,          limit => 500,
115          offset => 6000,          offset => 6000,
116          stats => 1,          stats => 1,
# Line 140  This function will read whole database i Line 135  This function will read whole database i
135    
136   );   );
137    
138  By default, C<code_page> is assumed to be C<cp852>.  By default, C<input_encoding> is assumed to be C<cp852>.
139    
140  C<offset> is optional parametar to position at some offset before reading from database.  C<offset> is optional parametar to skip records at beginning.
141    
142  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
143    
# Line 161  overrides C<modify_records> if both exis Line 156  overrides C<modify_records> if both exis
156  C<save_row> and C<load_row> are low-level implementation of store engine. Calling convention  C<save_row> and C<load_row> are low-level implementation of store engine. Calling convention
157  is documented in example above.  is documented in example above.
158    
159    C<strict_encoding> should really default to 1, but it doesn't for now.
160    
161  Returns size of database, regardless of C<offset> and C<limit>  Returns size of database, regardless of C<offset> and C<limit>
162  parametars, see also C<size>.  parametars, see also C<size>.
163    
# Line 171  sub open { Line 168  sub open {
168          my $arg = {@_};          my $arg = {@_};
169    
170          my $log = $self->_get_logger();          my $log = $self->_get_logger();
171            $log->debug( "arguments: ",dump( $arg ));
172    
173            $log->logconfess("encoding argument is not suppored any more.") if $self->{encoding};
174            $log->logconfess("code_page argument is not suppored any more.") if $self->{code_page};
175          $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_coderef") if ($arg->{lookup});          $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_coderef") if ($arg->{lookup});
176          $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))          $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
177                  if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');                  if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
# Line 179  sub open { Line 179  sub open {
179          $log->debug( $arg->{lookup_coderef} ? '' : 'not ', "using lookup_coderef");          $log->debug( $arg->{lookup_coderef} ? '' : 'not ', "using lookup_coderef");
180    
181          $log->logcroak("need path") if (! $arg->{'path'});          $log->logcroak("need path") if (! $arg->{'path'});
182          my $code_page = $arg->{'code_page'} || 'cp852';          my $input_encoding = $arg->{'input_encoding'} || $self->{'input_encoding'} || 'cp852';
183    
184          # store data in object          # store data in object
185          $self->{'input_code_page'} = $code_page;          $self->{$_} = $arg->{$_} foreach grep { defined $arg->{$_} } qw(path offset limit);
         foreach my $v (qw/path offset limit/) {  
                 $self->{$v} = $arg->{$v} if ($arg->{$v});  
         }  
186    
187          if ($arg->{load_row} || $arg->{save_row}) {          if ($arg->{load_row} || $arg->{save_row}) {
188                  $log->logconfess("save_row and load_row must be defined in pair and be CODE") unless (                  $log->logconfess("save_row and load_row must be defined in pair and be CODE") unless (
# Line 231  sub open { Line 228  sub open {
228    
229          my $class = $self->{module} || $log->logconfess("can't get low-level module name!");          my $class = $self->{module} || $log->logconfess("can't get low-level module name!");
230    
231            $arg->{$_} = $self->{$_} foreach qw(offset limit);
232    
233          my $ll_db = $class->new(          my $ll_db = $class->new(
234                  path => $arg->{path},                  path => $arg->{path},
235                    input_config => $arg->{input_config} || $self->{input_config},
236  #               filter => sub {  #               filter => sub {
237  #                       my ($l,$f_nr) = @_;  #                       my ($l,$f_nr) = @_;
238  #                       return unless defined($l);  #                       return unless defined($l);
239  #                       from_to($l, $code_page, $self->{'encoding'});  #                       $l = decode($input_encoding, $l);
240  #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);  #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
241  #                       return $l;  #                       return $l;
242  #               },  #               },
243                  %{ $arg },                  %{ $arg },
244          );          );
245    
246            # save for dump and input_module
247            $self->{ll_db} = $ll_db;
248    
249          unless (defined($ll_db)) {          unless (defined($ll_db)) {
250                  $log->logwarn("can't open database $arg->{path}, skipping...");                  $log->logwarn("can't open database $arg->{path}, skipping...");
251                  return;                  return;
# Line 259  sub open { Line 262  sub open {
262          my $to_rec = $size;          my $to_rec = $size;
263    
264          if (my $s = $self->{offset}) {          if (my $s = $self->{offset}) {
265                  $log->debug("skipping to MFN $s");                  $log->debug("offset $s records");
266                  $from_rec = $s;                  $from_rec = $s + 1;
267          } else {          } else {
268                  $self->{offset} = $from_rec;                  $self->{offset} = $from_rec - 1;
269          }          }
270    
271          if ($self->{limit}) {          if ($self->{limit}) {
# Line 271  sub open { Line 274  sub open {
274                  $to_rec = $size if ($to_rec > $size);                  $to_rec = $size if ($to_rec > $size);
275          }          }
276    
277          # store size for later          my $strict_encoding = $arg->{strict_encoding} || $self->{strict_encoding}; ## FIXME should be 1 really
         $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;  
278    
279          $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{encoding}", $self->{stats} ? ' [stats]' : '');          $log->info("processing $self->{size}/$size records [$from_rec-$to_rec]",
280                    " encoding $input_encoding ", $strict_encoding ? ' [strict]' : '',
281                    $self->{stats} ? ' [stats]' : '',
282            );
283    
284            $self->{size} = 0;
285    
286          # read database          # read database
287          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
288    
289                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
290    
291                    $self->{size}++; # XXX I could move this more down if I didn't want empty records...
292    
293                  my $rec = $ll_db->fetch_rec($pos, sub {                  my $rec = $ll_db->fetch_rec($pos, sub {
294                                  my ($l,$f_nr) = @_;                                  my ($l,$f_nr,$debug) = @_;
295  #                               return unless defined($l);  #                               return unless defined($l);
296  #                               return $l unless ($rec_regex && $f_nr);  #                               return $l unless ($rec_regex && $f_nr);
297    
298                                    return unless ( defined($l) && defined($f_nr) );
299    
300                                    warn "-=> $f_nr ## |$l|\n" if ($debug);
301                                  $log->debug("-=> $f_nr ## $l");                                  $log->debug("-=> $f_nr ## $l");
302    
303                                  # codepage conversion and recode_regex                                  # codepage conversion and recode_regex
304                                  from_to($l, $code_page, $self->{'encoding'});                                  $l = decode($input_encoding, $l, 1);
305                                  $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);                                  $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
306    
307                                  # apply regexps                                  # apply regexps
# Line 298  sub open { Line 310  sub open {
310                                          my $c = 0;                                          my $c = 0;
311                                          foreach my $r (@{ $rec_regex->{$f_nr} }) {                                          foreach my $r (@{ $rec_regex->{$f_nr} }) {
312                                                  my $old_l = $l;                                                  my $old_l = $l;
313                                                  eval '$l =~ ' . $r;                                                  $log->logconfess("expected regex in ", dump( $r )) unless defined($r->{regex});
314                                                    eval '$l =~ ' . $r->{regex};
315                                                  if ($old_l ne $l) {                                                  if ($old_l ne $l) {
316                                                          $log->debug("REGEX on $f_nr eval \$l =~ $r\n## old l: [$old_l]\n## new l: [$l]");                                                          my $d = "|$old_l| -> |$l| "; # . $r->{regex};
317                                                            $d .= ' +' . $r->{line} . ' ' . $r->{file} if defined($r->{line});
318                                                            $d .= ' ' . $r->{debug} if defined($r->{debug});
319                                                            $log->debug("MODIFY $d");
320                                                            warn "*** $d\n" if ($debug);
321    
322                                                  }                                                  }
323                                                  $log->error("error applying regex: $r") if ($@);                                                  $log->error("error applying regex: ",dump($r), $@) if $@;
324                                          }                                          }
325                                  }                                  }
326    
327                                  $log->debug("<=- $f_nr ## $l");                                  $log->debug("<=- $f_nr ## |$l|");
328                                    warn "<=- $f_nr ## $l\n" if ($debug);
329                                  return $l;                                  return $l;
330                  });                  });
331    
# Line 339  sub open { Line 358  sub open {
358                          foreach my $fld (keys %{ $rec }) {                          foreach my $fld (keys %{ $rec }) {
359                                  $self->{_stats}->{fld}->{ $fld }++;                                  $self->{_stats}->{fld}->{ $fld }++;
360    
361                                  $log->logdie("invalid record fild $fld, not ARRAY")                                  #$log->logdie("invalid record fild $fld, not ARRAY")
362                                          unless (ref($rec->{ $fld }) eq 'ARRAY');                                  next unless (ref($rec->{ $fld }) eq 'ARRAY');
363                    
364                                  foreach my $row (@{ $rec->{$fld} }) {                                  foreach my $row (@{ $rec->{$fld} }) {
365    
# Line 371  sub open { Line 390  sub open {
390          $self->{max_pos} = $to_rec;          $self->{max_pos} = $to_rec;
391          $log->debug("max_pos: $to_rec");          $log->debug("max_pos: $to_rec");
392    
         # save for dump  
         $self->{ll_db} = $ll_db;  
   
393          return $size;          return $size;
394  }  }
395    
396    sub input_module { $_[0]->{ll_db} }
397    
398  =head2 fetch  =head2 fetch
399    
400  Fetch next record from database. It will also displays progress bar.  Fetch next record from database. It will also displays progress bar.
# Line 396  sub fetch { Line 414  sub fetch {
414          $log->logconfess("it seems that you didn't load database!") unless ($self->{pos});          $log->logconfess("it seems that you didn't load database!") unless ($self->{pos});
415    
416          if ($self->{pos} == -1) {          if ($self->{pos} == -1) {
417                  $self->{pos} = $self->{offset};                  $self->{pos} = $self->{offset} + 1;
418          } else {          } else {
419                  $self->{pos}++;                  $self->{pos}++;
420          }          }
# Line 454  because it takes into account C<offset> Line 472  because it takes into account C<offset>
472    
473  sub size {  sub size {
474          my $self = shift;          my $self = shift;
475          return $self->{size};          return $self->{size}; # FIXME this is buggy if open is called multiple times!
476  }  }
477    
478  =head2 seek  =head2 seek
# Line 473  sub seek { Line 491  sub seek {
491    
492          my $log = $self->_get_logger();          my $log = $self->_get_logger();
493    
494          $log->confess("called without pos") unless defined($pos);          $log->logconfess("called without pos") unless defined($pos);
495    
496          if ($pos < 1) {          if ($pos < 1) {
497                  $log->warn("seek before first record");                  $log->warn("seek before first record");
# Line 509  sub stats { Line 527  sub stats {
527    
528          my $out = join("\n",          my $out = join("\n",
529                  map {                  map {
530                          my $f = $_ || die "no field";                          my $f = $_;
531                            die "no field in ", dump( $s->{fld} ) unless defined( $f );
532                          my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";                          my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
533                          $max_fld = $v if ($v > $max_fld);                          $max_fld = $v if ($v > $max_fld);
534    
535                          my $o = sprintf("%4s %d ~", $f, $v);                          my $o = sprintf("%4s %d ~", $f, $v);
536    
537                          if (defined($s->{sf}->{$f})) {                          if (defined($s->{sf}->{$f})) {
538                                    my @subfields = keys %{ $s->{sf}->{$f} };
539                                  map {                                  map {
540                                          $o .= sprintf(" %s:%d%s", $_,                                          $o .= sprintf(" %s:%d%s", $_,
541                                                  $s->{sf}->{$f}->{$_}->{count},                                                  $s->{sf}->{$f}->{$_}->{count},
542                                                  $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',                                                  $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
543                                          );                                          );
544                                  } sort keys %{ $s->{sf}->{$f} };                                  } (
545                                            # first indicators and other special subfields
546                                            sort( grep { length($_)  > 1 } @subfields ),
547                                            # then subfileds (single char)
548                                            sort( grep { length($_) == 1 } @subfields ),
549                                    );
550                          }                          }
551    
552                          if (my $v_r = $s->{repeatable}->{$f}) {                          if (my $v_r = $s->{repeatable}->{$f}) {
# Line 529  sub stats { Line 554  sub stats {
554                          }                          }
555    
556                          $o;                          $o;
557                  } sort { $a cmp $b } keys %{ $s->{fld} }                  } sort {
558                            if ( $a =~ m/^\d+$/ && $b =~ m/^\d+$/ ) {
559                                    $a <=> $b
560                            } else {
561                                    $a cmp $b
562                            }
563                    } keys %{ $s->{fld} }
564          );          );
565    
566          $log->debug( sub { dump($s) } );          $log->debug( sub { dump($s) } );
567    
568            my $path = 'var/stats.yml';
569            YAML::DumpFile( $path, $s );
570            $log->info( 'created ', $path, ' with ', -s $path, ' bytes' );
571    
572          return $out;          return $out;
573  }  }
574    
# Line 548  sub dump_ascii { Line 583  sub dump_ascii {
583    
584          return unless $self->{ll_db};          return unless $self->{ll_db};
585    
586          if ($self->{ll_db}->can('dump_rec')) {          if ($self->{ll_db}->can('dump_ascii')) {
587                  return $self->{ll_db}->dump_ascii( $self->{pos} );                  return $self->{ll_db}->dump_ascii( $self->{pos} );
588          } else {          } else {
589                  return dump( $self->{ll_db}->fetch_rec( $self->{pos} ) );                  return dump( $self->{ll_db}->fetch_rec( $self->{pos} ) );
590          }          }
591  }  }
592    
593  =head2 modify_record_regexps  =head2 _get_regex
594    
595  Generate hash with regexpes to be applied using l<filter>.  Helper function called which create regexps to be execute on code.
596    
597    my $regexpes = $input->modify_record_regexps(    _get_regex( 900, 'regex:[0-9]+' ,'numbers' );
598                  900 => { '^a' => { ' : ' => '^b' } },    _get_regex( 900, '^b', ' : ^b' );
599                  901 => { '*' => { '^b' => ' ; ' } },  
600    );  It supports perl regexps with C<regex:> prefix to from value and has
601    additional logic to skip empty subfields.
602    
603  =cut  =cut
604    
605  sub _get_regex {  sub _get_regex {
606          my ($sf,$from,$to) = @_;          my ($sf,$from,$to) = @_;
607    
608            # protect /
609            $from =~ s!/!\\/!gs;
610            $to =~ s!/!\\/!gs;
611    
612          if ($from =~ m/^regex:(.+)$/) {          if ($from =~ m/^regex:(.+)$/) {
613                  $from = $1;                  $from = $1;
614          } else {          } else {
615                  $from = '\Q' . $from . '\E';                  $from = '\Q' . $from . '\E';
616          }          }
617          if ($sf =~ /^\^/) {          if ($sf =~ /^\^/) {
618                    my $need_subfield_data = '*';   # no
619                    # if from is also subfield, require some data in between
620                    # to correctly skip empty subfields
621                    $need_subfield_data = '+' if ($from =~ m/^\\Q\^/);
622                  return                  return
623                          's/\Q'. $sf .'\E([^\^]*?)'. $from .'([^\^]*?)/'. $sf .'$1'. $to .'$2/';                          's/\Q'. $sf .'\E([^\^]' . $need_subfield_data . '?)'. $from .'([^\^]*?)/'. $sf .'$1'. $to .'$2/';
624          } else {          } else {
625                  return                  return
626                          's/'. $from .'/'. $to .'/g';                          's/'. $from .'/'. $to .'/g';
627          }          }
628  }  }
629    
630    
631    =head2 modify_record_regexps
632    
633    Generate hash with regexpes to be applied using L<filter>.
634    
635      my $regexpes = $input->modify_record_regexps(
636                    900 => { '^a' => { ' : ' => '^b' } },
637                    901 => { '*' => { '^b' => ' ; ' } },
638      );
639    
640    =cut
641    
642  sub modify_record_regexps {  sub modify_record_regexps {
643          my $self = shift;          my $self = shift;
644          my $modify_record = {@_};          my $modify_record = {@_};
# Line 599  sub modify_record_regexps { Line 656  sub modify_record_regexps {
656                          foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {                          foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
657                                  my $to = $modify_record->{$f}->{$sf}->{$from};                                  my $to = $modify_record->{$f}->{$sf}->{$from};
658                                  #die "no field?" unless defined($to);                                  #die "no field?" unless defined($to);
659                                  $log->debug("transform: |$from| -> |$to|");                                  my $d = "|$from| -> |$to|";
660                                    $log->debug("transform: $d");
661    
662                                  my $regex = _get_regex($sf,$from,$to);                                  my $regex = _get_regex($sf,$from,$to);
663                                  push @{ $regexpes->{$f} }, $regex;                                  push @{ $regexpes->{$f} }, { regex => $regex, debug => $d };
664                                  $log->debug("regex: $regex");                                  $log->debug("regex: $regex");
665                          }                          }
666                  }                  }
# Line 613  sub modify_record_regexps { Line 671  sub modify_record_regexps {
671    
672  =head2 modify_file_regexps  =head2 modify_file_regexps
673    
674  Generate hash with regexpes to be applied using l<filter> from  Generate hash with regexpes to be applied using L<filter> from
675  pseudo hash/yaml format for regex mappings.  pseudo hash/yaml format for regex mappings.
676    
677  It should be obvious:  It should be obvious:
# Line 663  sub modify_file_regexps { Line 721  sub modify_file_regexps {
721                          $log->debug("transform: |$from| -> |$to|");                          $log->debug("transform: |$from| -> |$to|");
722    
723                          my $regex = _get_regex($sf,$from,$to);                          my $regex = _get_regex($sf,$from,$to);
724                          push @{ $regexpes->{$f} }, $regex;                          push @{ $regexpes->{$f} }, {
725                                    regex => $regex,
726                                    file => $modify_path,
727                                    line => $.,
728                            };
729                          $log->debug("regex: $regex");                          $log->debug("regex: $regex");
730                    } else {
731                            die "can't parse: $_";
732                  }                  }
733          }          }
734    
Legend:
Removed from v.793  
changed lines
  Added in v.1307
  ViewVC Help
Powered by ViewVC 1.1.26