/[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 761 by dpavlin, Wed Oct 25 17:10:08 2006 UTC revision 1122 by dpavlin, Mon Nov 17 21:30:05 2008 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 Data::Dumper;  use Data::Dump qw/dump/;
11  use Encode qw/from_to/;  use Encode qw/decode from_to/;
12    
13  =head1 NAME  =head1 NAME
14    
15  WebPAC::Input - read different file formats into WebPAC  WebPAC::Input - read different file formats into WebPAC
16    
 =head1 VERSION  
   
 Version 0.14  
   
17  =cut  =cut
18    
19  our $VERSION = '0.14';  our $VERSION = '0.19';
20    
21  =head1 SYNOPSIS  =head1 SYNOPSIS
22    
# Line 61  Create new input database object. Line 57  Create new input database object.
57    
58    my $db = new WebPAC::Input(    my $db = new WebPAC::Input(
59          module => 'WebPAC::Input::MARC',          module => 'WebPAC::Input::MARC',
         encoding => 'ISO-8859-2',  
60          recode => 'char pairs',          recode => 'char pairs',
61          no_progress_bar => 1,          no_progress_bar => 1,
62            input_config => {
63                    mapping => [ 'foo', 'bar', 'baz' ],
64            },
65    );    );
66    
67  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
68  L<WebPAC::Input::MARC>.  L<WebPAC::Input::MARC>.
69    
 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>.  
   
70  C<recode> is optional string constisting of character or words pairs that  C<recode> is optional string constisting of character or words pairs that
71  should be replaced in input stream.  should be replaced in input stream.
72    
# Line 90  sub new { Line 84  sub new {
84    
85          my $log = $self->_get_logger;          my $log = $self->_get_logger;
86    
87          $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};
88          $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};
89          $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};
90            $log->logconfess("low_mem argument is not suppored any more. rewrite it to load_row and save_row") if $self->{low_mem};
91    
92          $log->logconfess("specify low-level file format module") unless ($self->{module});          $log->logconfess("specify low-level file format module") unless ($self->{module});
93          my $module_path = $self->{module};          my $module_path = $self->{module};
# Line 102  sub new { Line 97  sub new {
97    
98          require $module_path;          require $module_path;
99    
         # check if required subclasses are implemented  
         foreach my $subclass (qw/open_db fetch_rec init dump_rec/) {  
                 # FIXME  
         }  
   
         $self->{'encoding'} ||= 'ISO-8859-2';  
   
100          $self ? return $self : return undef;          $self ? return $self : return undef;
101  }  }
102    
# Line 120  This function will read whole database i Line 108  This function will read whole database i
108    
109   $input->open(   $input->open(
110          path => '/path/to/database/file',          path => '/path/to/database/file',
111          code_page => 'cp852',          input_encoding => 'cp852',
112            strict_encoding => 0,
113          limit => 500,          limit => 500,
114          offset => 6000,          offset => 6000,
115          stats => 1,          stats => 1,
# Line 145  This function will read whole database i Line 134  This function will read whole database i
134    
135   );   );
136    
137  By default, C<code_page> is assumed to be C<cp852>.  By default, C<input_encoding> is assumed to be C<cp852>.
138    
139  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.
140    
# Line 166  overrides C<modify_records> if both exis Line 155  overrides C<modify_records> if both exis
155  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
156  is documented in example above.  is documented in example above.
157    
158    C<strict_encoding> should really default to 1, but it doesn't for now.
159    
160  Returns size of database, regardless of C<offset> and C<limit>  Returns size of database, regardless of C<offset> and C<limit>
161  parametars, see also C<size>.  parametars, see also C<size>.
162    
# Line 176  sub open { Line 167  sub open {
167          my $arg = {@_};          my $arg = {@_};
168    
169          my $log = $self->_get_logger();          my $log = $self->_get_logger();
170            $log->debug( "arguments: ",dump( $arg ));
171    
172            $log->logconfess("encoding argument is not suppored any more.") if $self->{encoding};
173            $log->logconfess("code_page argument is not suppored any more.") if $self->{code_page};
174          $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});
175          $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))          $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
176                  if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');                  if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
# Line 184  sub open { Line 178  sub open {
178          $log->debug( $arg->{lookup_coderef} ? '' : 'not ', "using lookup_coderef");          $log->debug( $arg->{lookup_coderef} ? '' : 'not ', "using lookup_coderef");
179    
180          $log->logcroak("need path") if (! $arg->{'path'});          $log->logcroak("need path") if (! $arg->{'path'});
181          my $code_page = $arg->{'code_page'} || 'cp852';          my $input_encoding = $arg->{'input_encoding'} || $self->{'input_encoding'} || 'cp852';
182    
183          # store data in object          # store data in object
         $self->{'input_code_page'} = $code_page;  
184          foreach my $v (qw/path offset limit/) {          foreach my $v (qw/path offset limit/) {
185                  $self->{$v} = $arg->{$v} if ($arg->{$v});                  $self->{$v} = $arg->{$v} if ($arg->{$v});
186          }          }
# Line 229  sub open { Line 222  sub open {
222                  $log->debug("using modify_file $p");                  $log->debug("using modify_file $p");
223                  $rec_regex = $self->modify_file_regexps( $p );                  $rec_regex = $self->modify_file_regexps( $p );
224          } elsif (my $h = $arg->{modify_records}) {          } elsif (my $h = $arg->{modify_records}) {
225                  $log->debug("using modify_records ", Dumper( $h ));                  $log->debug("using modify_records ", sub { dump( $h ) });
226                  $rec_regex = $self->modify_record_regexps(%{ $h });                  $rec_regex = $self->modify_record_regexps(%{ $h });
227          }          }
228          $log->debug("rec_regex: ", Dumper($rec_regex)) if ($rec_regex);          $log->debug("rec_regex: ", sub { dump($rec_regex) }) if ($rec_regex);
229    
230          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!");
231    
232          my $ll_db = $class->new(          my $ll_db = $class->new(
233                  path => $arg->{path},                  path => $arg->{path},
234                    input_config => $arg->{input_config} || $self->{input_config},
235  #               filter => sub {  #               filter => sub {
236  #                       my ($l,$f_nr) = @_;  #                       my ($l,$f_nr) = @_;
237  #                       return unless defined($l);  #                       return unless defined($l);
238  #                       from_to($l, $code_page, $self->{'encoding'});  #                       $l = decode($input_encoding, $l);
239  #                       $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);
240  #                       return $l;  #                       return $l;
241  #               },  #               },
# Line 279  sub open { Line 273  sub open {
273          # store size for later          # store size for later
274          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
275    
276          $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{encoding}", $self->{stats} ? ' [stats]' : '');          my $strict_encoding = $arg->{strict_encoding} || $self->{strict_encoding}; ## FIXME should be 1 really
277    
278            $log->info("processing $self->{size}/$size records [$from_rec-$to_rec]",
279                    " encoding $input_encoding ", $strict_encoding ? ' [strict]' : '',
280                    $self->{stats} ? ' [stats]' : '',
281            );
282    
283          # read database          # read database
284          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
# Line 287  sub open { Line 286  sub open {
286                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
287    
288                  my $rec = $ll_db->fetch_rec($pos, sub {                  my $rec = $ll_db->fetch_rec($pos, sub {
289                                  my ($l,$f_nr) = @_;                                  my ($l,$f_nr,$debug) = @_;
290  #                               return unless defined($l);  #                               return unless defined($l);
291  #                               return $l unless ($rec_regex && $f_nr);  #                               return $l unless ($rec_regex && $f_nr);
292    
293                                    return unless ( defined($l) && defined($f_nr) );
294    
295                                    warn "-=> $f_nr ## |$l|\n" if ($debug);
296                                  $log->debug("-=> $f_nr ## $l");                                  $log->debug("-=> $f_nr ## $l");
297    
298                                  # codepage conversion and recode_regex                                  # codepage conversion and recode_regex
299                                  from_to($l, $code_page, $self->{'encoding'});                                  $l = decode($input_encoding, $l, 1);
300                                  $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);
301    
302                                  # apply regexps                                  # apply regexps
# Line 303  sub open { Line 305  sub open {
305                                          my $c = 0;                                          my $c = 0;
306                                          foreach my $r (@{ $rec_regex->{$f_nr} }) {                                          foreach my $r (@{ $rec_regex->{$f_nr} }) {
307                                                  my $old_l = $l;                                                  my $old_l = $l;
308                                                  eval '$l =~ ' . $r;                                                  $log->logconfess("expected regex in ", dump( $r )) unless defined($r->{regex});
309                                                    eval '$l =~ ' . $r->{regex};
310                                                  if ($old_l ne $l) {                                                  if ($old_l ne $l) {
311                                                          $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};
312                                                            $d .= ' +' . $r->{line} . ' ' . $r->{file} if defined($r->{line});
313                                                            $d .= ' ' . $r->{debug} if defined($r->{debug});
314                                                            $log->debug("MODIFY $d");
315                                                            warn "*** $d\n" if ($debug);
316    
317                                                  }                                                  }
318                                                  $log->error("error applying regex: $r") if ($@);                                                  $log->error("error applying regex: ",dump($r), $@) if $@;
319                                          }                                          }
320                                  }                                  }
321    
322                                  $log->debug("<=- $f_nr ## $l");                                  $log->debug("<=- $f_nr ## |$l|");
323                                    warn "<=- $f_nr ## $l\n" if ($debug);
324                                  return $l;                                  return $l;
325                  });                  });
326    
327                  $log->debug(sub { Dumper($rec) });                  $log->debug(sub { dump($rec) });
328    
329                  if (! $rec) {                  if (! $rec) {
330                          $log->warn("record $pos empty? skipping...");                          $log->warn("record $pos empty? skipping...");
# Line 344  sub open { Line 353  sub open {
353                          foreach my $fld (keys %{ $rec }) {                          foreach my $fld (keys %{ $rec }) {
354                                  $self->{_stats}->{fld}->{ $fld }++;                                  $self->{_stats}->{fld}->{ $fld }++;
355    
356                                  $log->logdie("invalid record fild $fld, not ARRAY")                                  #$log->logdie("invalid record fild $fld, not ARRAY")
357                                          unless (ref($rec->{ $fld }) eq 'ARRAY');                                  next unless (ref($rec->{ $fld }) eq 'ARRAY');
358                    
359                                  foreach my $row (@{ $rec->{$fld} }) {                                  foreach my $row (@{ $rec->{$fld} }) {
360    
# Line 474  First record in database has position 1. Line 483  First record in database has position 1.
483    
484  sub seek {  sub seek {
485          my $self = shift;          my $self = shift;
486          my $pos = shift || return;          my $pos = shift;
487    
488          my $log = $self->_get_logger();          my $log = $self->_get_logger();
489    
490            $log->logconfess("called without pos") unless defined($pos);
491    
492          if ($pos < 1) {          if ($pos < 1) {
493                  $log->warn("seek before first record");                  $log->warn("seek before first record");
494                  $pos = 1;                  $pos = 1;
# Line 512  sub stats { Line 523  sub stats {
523    
524          my $out = join("\n",          my $out = join("\n",
525                  map {                  map {
526                          my $f = $_ || die "no field";                          my $f = $_;
527                            die "no field in ", dump( $s->{fld} ) unless defined( $f );
528                          my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";                          my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
529                          $max_fld = $v if ($v > $max_fld);                          $max_fld = $v if ($v > $max_fld);
530    
531                          my $o = sprintf("%4s %d ~", $f, $v);                          my $o = sprintf("%4s %d ~", $f, $v);
532    
533                          if (defined($s->{sf}->{$f})) {                          if (defined($s->{sf}->{$f})) {
534                                    my @subfields = keys %{ $s->{sf}->{$f} };
535                                  map {                                  map {
536                                          $o .= sprintf(" %s:%d%s", $_,                                          $o .= sprintf(" %s:%d%s", $_,
537                                                  $s->{sf}->{$f}->{$_}->{count},                                                  $s->{sf}->{$f}->{$_}->{count},
538                                                  $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',                                                  $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
539                                          );                                          );
540                                  } sort keys %{ $s->{sf}->{$f} };                                  } (
541                                            # first indicators and other special subfields
542                                            sort( grep { length($_)  > 1 } @subfields ),
543                                            # then subfileds (single char)
544                                            sort( grep { length($_) == 1 } @subfields ),
545                                    );
546                          }                          }
547    
548                          if (my $v_r = $s->{repeatable}->{$f}) {                          if (my $v_r = $s->{repeatable}->{$f}) {
# Line 532  sub stats { Line 550  sub stats {
550                          }                          }
551    
552                          $o;                          $o;
553                  } sort { $a cmp $b } keys %{ $s->{fld} }                  } sort {
554                            if ( $a =~ m/^\d+$/ && $b =~ m/^\d+$/ ) {
555                                    $a <=> $b
556                            } else {
557                                    $a cmp $b
558                            }
559                    } keys %{ $s->{fld} }
560          );          );
561    
562          $log->debug( sub { Dumper($s) } );          $log->debug( sub { dump($s) } );
563    
564          return $out;          return $out;
565  }  }
566    
567  =head2 dump  =head2 dump_ascii
568    
569  Display humanly readable dump of record  Display humanly readable dump of record
570    
571  =cut  =cut
572    
573  sub dump {  sub dump_ascii {
574          my $self = shift;          my $self = shift;
575    
576          return $self->{ll_db}->dump_rec( $self->{pos} );          return unless $self->{ll_db};
577    
578            if ($self->{ll_db}->can('dump_ascii')) {
579                    return $self->{ll_db}->dump_ascii( $self->{pos} );
580            } else {
581                    return dump( $self->{ll_db}->fetch_rec( $self->{pos} ) );
582            }
583  }  }
584    
585  =head2 modify_record_regexps  =head2 _get_regex
586    
587  Generate hash with regexpes to be applied using l<filter>.  Helper function called which create regexps to be execute on code.
588    
589    my $regexpes = $input->modify_record_regexps(    _get_regex( 900, 'regex:[0-9]+' ,'numbers' );
590                  900 => { '^a' => { ' : ' => '^b' } },    _get_regex( 900, '^b', ' : ^b' );
591                  901 => { '*' => { '^b' => ' ; ' } },  
592    );  It supports perl regexps with C<regex:> prefix to from value and has
593    additional logic to skip empty subfields.
594    
595  =cut  =cut
596    
597  sub _get_regex {  sub _get_regex {
598          my ($sf,$from,$to) = @_;          my ($sf,$from,$to) = @_;
599    
600            # protect /
601            $from =~ s!/!\\/!gs;
602            $to =~ s!/!\\/!gs;
603    
604            if ($from =~ m/^regex:(.+)$/) {
605                    $from = $1;
606            } else {
607                    $from = '\Q' . $from . '\E';
608            }
609          if ($sf =~ /^\^/) {          if ($sf =~ /^\^/) {
610                    my $need_subfield_data = '*';   # no
611                    # if from is also subfield, require some data in between
612                    # to correctly skip empty subfields
613                    $need_subfield_data = '+' if ($from =~ m/^\\Q\^/);
614                  return                  return
615                          's/\Q'. $sf .'\E([^\^]*?)\Q'. $from .'\E([^\^]*?)/'. $sf .'$1'. $to .'$2/';                          's/\Q'. $sf .'\E([^\^]' . $need_subfield_data . '?)'. $from .'([^\^]*?)/'. $sf .'$1'. $to .'$2/';
616          } else {          } else {
617                  return                  return
618                          's/\Q'. $from .'\E/'. $to .'/g';                          's/'. $from .'/'. $to .'/g';
619          }          }
620  }  }
621    
622    
623    =head2 modify_record_regexps
624    
625    Generate hash with regexpes to be applied using L<filter>.
626    
627      my $regexpes = $input->modify_record_regexps(
628                    900 => { '^a' => { ' : ' => '^b' } },
629                    901 => { '*' => { '^b' => ' ; ' } },
630      );
631    
632    =cut
633    
634  sub modify_record_regexps {  sub modify_record_regexps {
635          my $self = shift;          my $self = shift;
636          my $modify_record = {@_};          my $modify_record = {@_};
# Line 592  sub modify_record_regexps { Line 648  sub modify_record_regexps {
648                          foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {                          foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
649                                  my $to = $modify_record->{$f}->{$sf}->{$from};                                  my $to = $modify_record->{$f}->{$sf}->{$from};
650                                  #die "no field?" unless defined($to);                                  #die "no field?" unless defined($to);
651                                  $log->debug("transform: |$from| -> |$to|");                                  my $d = "|$from| -> |$to|";
652                                    $log->debug("transform: $d");
653    
654                                  my $regex = _get_regex($sf,$from,$to);                                  my $regex = _get_regex($sf,$from,$to);
655                                  push @{ $regexpes->{$f} }, $regex;                                  push @{ $regexpes->{$f} }, { regex => $regex, debug => $d };
656                                  $log->debug("regex: $regex");                                  $log->debug("regex: $regex");
657                          }                          }
658                  }                  }
# Line 606  sub modify_record_regexps { Line 663  sub modify_record_regexps {
663    
664  =head2 modify_file_regexps  =head2 modify_file_regexps
665    
666  Generate hash with regexpes to be applied using l<filter> from  Generate hash with regexpes to be applied using L<filter> from
667  pseudo hash/yaml format for regex mappings.  pseudo hash/yaml format for regex mappings.
668    
669  It should be obvious:  It should be obvious:
# Line 656  sub modify_file_regexps { Line 713  sub modify_file_regexps {
713                          $log->debug("transform: |$from| -> |$to|");                          $log->debug("transform: |$from| -> |$to|");
714    
715                          my $regex = _get_regex($sf,$from,$to);                          my $regex = _get_regex($sf,$from,$to);
716                          push @{ $regexpes->{$f} }, $regex;                          push @{ $regexpes->{$f} }, {
717                                    regex => $regex,
718                                    file => $modify_path,
719                                    line => $.,
720                            };
721                          $log->debug("regex: $regex");                          $log->debug("regex: $regex");
722                    } else {
723                            die "can't parse: $_";
724                  }                  }
725          }          }
726    
Legend:
Removed from v.761  
changed lines
  Added in v.1122
  ViewVC Help
Powered by ViewVC 1.1.26