/[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 797 by dpavlin, Sun Feb 4 13:28:30 2007 UTC revision 909 by dpavlin, Tue Oct 30 01:46:41 2007 UTC
# Line 16  WebPAC::Input - read different file form Line 16  WebPAC::Input - read different file form
16    
17  =head1 VERSION  =head1 VERSION
18    
19  Version 0.17  Version 0.18
20    
21  =cut  =cut
22    
23  our $VERSION = '0.17';  our $VERSION = '0.18';
24    
25  =head1 SYNOPSIS  =head1 SYNOPSIS
26    
# Line 64  Create new input database object. Line 64  Create new input database object.
64          encoding => 'ISO-8859-2',          encoding => 'ISO-8859-2',
65          recode => 'char pairs',          recode => 'char pairs',
66          no_progress_bar => 1,          no_progress_bar => 1,
67            input_config => {
68                    mapping => [ 'foo', 'bar', 'baz' ],
69            },
70    );    );
71    
72  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
# Line 233  sub open { Line 236  sub open {
236    
237          my $ll_db = $class->new(          my $ll_db = $class->new(
238                  path => $arg->{path},                  path => $arg->{path},
239                    input_config => $arg->{input_config} || $self->{input_config},
240  #               filter => sub {  #               filter => sub {
241  #                       my ($l,$f_nr) = @_;  #                       my ($l,$f_nr) = @_;
242  #                       return unless defined($l);  #                       return unless defined($l);
# Line 282  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
# Line 298  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: $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    
# Line 509  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    warn "$f has subfields ",dump( @subfields );
536                                  map {                                  map {
537                                          $o .= sprintf(" %s:%d%s", $_,                                          $o .= sprintf(" %s:%d%s", $_,
538                                                  $s->{sf}->{$f}->{$_}->{count},                                                  $s->{sf}->{$f}->{$_}->{count},
539                                                  $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',                                                  $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
540                                          );                                          );
541                                  } sort keys %{ $s->{sf}->{$f} };                                  } (
542                                            # first indicators
543                                            sort( grep(  /^i[12]$/, @subfields ) ),
544                                            # then subfileds
545                                            sort( grep( !/^i[12]$/, @subfields ) ),
546                                    );
547                          }                          }
548    
549                          if (my $v_r = $s->{repeatable}->{$f}) {                          if (my $v_r = $s->{repeatable}->{$f}) {
# Line 529  sub stats { Line 551  sub stats {
551                          }                          }
552    
553                          $o;                          $o;
554                  } sort { $a cmp $b } keys %{ $s->{fld} }                  } sort { $a <=> $b } keys %{ $s->{fld} }
555          );          );
556    
557          $log->debug( sub { dump($s) } );          $log->debug( sub { dump($s) } );
# Line 548  sub dump_ascii { Line 570  sub dump_ascii {
570    
571          return unless $self->{ll_db};          return unless $self->{ll_db};
572    
573          if ($self->{ll_db}->can('dump_rec')) {          if ($self->{ll_db}->can('dump_ascii')) {
574                  return $self->{ll_db}->dump_ascii( $self->{pos} );                  return $self->{ll_db}->dump_ascii( $self->{pos} );
575          } else {          } else {
576                  return dump( $self->{ll_db}->fetch_rec( $self->{pos} ) );                  return dump( $self->{ll_db}->fetch_rec( $self->{pos} ) );
577          }          }
578  }  }
579    
580  =head2 modify_record_regexps  =head2 _get_regex
581    
582  Generate hash with regexpes to be applied using l<filter>.  Helper function called which create regexps to be execute on code.
583    
584    my $regexpes = $input->modify_record_regexps(    _get_regex( 900, 'regex:[0-9]+' ,'numbers' );
585                  900 => { '^a' => { ' : ' => '^b' } },    _get_regex( 900, '^b', ' : ^b' );
586                  901 => { '*' => { '^b' => ' ; ' } },  
587    );  It supports perl regexps with C<regex:> prefix to from value and has
588    additional logic to skip empty subfields.
589    
590  =cut  =cut
591    
# Line 579  sub _get_regex { Line 602  sub _get_regex {
602                  $from = '\Q' . $from . '\E';                  $from = '\Q' . $from . '\E';
603          }          }
604          if ($sf =~ /^\^/) {          if ($sf =~ /^\^/) {
605                    my $need_subfield_data = '*';   # no
606                    # if from is also subfield, require some data in between
607                    # to correctly skip empty subfields
608                    $need_subfield_data = '+' if ($from =~ m/^\\Q\^/);
609                  return                  return
610                          's/\Q'. $sf .'\E([^\^]*?)'. $from .'([^\^]*?)/'. $sf .'$1'. $to .'$2/';                          's/\Q'. $sf .'\E([^\^]' . $need_subfield_data . '?)'. $from .'([^\^]*?)/'. $sf .'$1'. $to .'$2/';
611          } else {          } else {
612                  return                  return
613                          's/'. $from .'/'. $to .'/g';                          's/'. $from .'/'. $to .'/g';
614          }          }
615  }  }
616    
617    
618    =head2 modify_record_regexps
619    
620    Generate hash with regexpes to be applied using L<filter>.
621    
622      my $regexpes = $input->modify_record_regexps(
623                    900 => { '^a' => { ' : ' => '^b' } },
624                    901 => { '*' => { '^b' => ' ; ' } },
625      );
626    
627    =cut
628    
629  sub modify_record_regexps {  sub modify_record_regexps {
630          my $self = shift;          my $self = shift;
631          my $modify_record = {@_};          my $modify_record = {@_};
# Line 604  sub modify_record_regexps { Line 643  sub modify_record_regexps {
643                          foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {                          foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
644                                  my $to = $modify_record->{$f}->{$sf}->{$from};                                  my $to = $modify_record->{$f}->{$sf}->{$from};
645                                  #die "no field?" unless defined($to);                                  #die "no field?" unless defined($to);
646                                  $log->debug("transform: |$from| -> |$to|");                                  my $d = "|$from| -> |$to|";
647                                    $log->debug("transform: $d");
648    
649                                  my $regex = _get_regex($sf,$from,$to);                                  my $regex = _get_regex($sf,$from,$to);
650                                  push @{ $regexpes->{$f} }, $regex;                                  push @{ $regexpes->{$f} }, { regex => $regex, debug => $d };
651                                  $log->debug("regex: $regex");                                  $log->debug("regex: $regex");
652                          }                          }
653                  }                  }
# Line 618  sub modify_record_regexps { Line 658  sub modify_record_regexps {
658    
659  =head2 modify_file_regexps  =head2 modify_file_regexps
660    
661  Generate hash with regexpes to be applied using l<filter> from  Generate hash with regexpes to be applied using L<filter> from
662  pseudo hash/yaml format for regex mappings.  pseudo hash/yaml format for regex mappings.
663    
664  It should be obvious:  It should be obvious:
# Line 668  sub modify_file_regexps { Line 708  sub modify_file_regexps {
708                          $log->debug("transform: |$from| -> |$to|");                          $log->debug("transform: |$from| -> |$to|");
709    
710                          my $regex = _get_regex($sf,$from,$to);                          my $regex = _get_regex($sf,$from,$to);
711                          push @{ $regexpes->{$f} }, $regex;                          push @{ $regexpes->{$f} }, {
712                                    regex => $regex,
713                                    file => $modify_path,
714                                    line => $.,
715                            };
716                          $log->debug("regex: $regex");                          $log->debug("regex: $regex");
717                  }                  }
718          }          }
Legend:
Removed from v.797  
changed lines
  Added in v.909
  ViewVC Help
Powered by ViewVC 1.1.26