/[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 860 by dpavlin, Sun May 27 19:10:43 2007 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/from_to/;
12    
13  =head1 NAME  =head1 NAME
# 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.14  Version 0.18
20    
21  =cut  =cut
22    
23  our $VERSION = '0.14';  our $VERSION = '0.18';
24    
25  =head1 SYNOPSIS  =head1 SYNOPSIS
26    
# Line 102  sub new { Line 102  sub new {
102    
103          require $module_path;          require $module_path;
104    
         # check if required subclasses are implemented  
         foreach my $subclass (qw/open_db fetch_rec init dump_rec/) {  
                 # FIXME  
         }  
   
105          $self->{'encoding'} ||= 'ISO-8859-2';          $self->{'encoding'} ||= 'ISO-8859-2';
106    
107          $self ? return $self : return undef;          $self ? return $self : return undef;
# Line 229  sub open { Line 224  sub open {
224                  $log->debug("using modify_file $p");                  $log->debug("using modify_file $p");
225                  $rec_regex = $self->modify_file_regexps( $p );                  $rec_regex = $self->modify_file_regexps( $p );
226          } elsif (my $h = $arg->{modify_records}) {          } elsif (my $h = $arg->{modify_records}) {
227                  $log->debug("using modify_records ", Dumper( $h ));                  $log->debug("using modify_records ", sub { dump( $h ) });
228                  $rec_regex = $self->modify_record_regexps(%{ $h });                  $rec_regex = $self->modify_record_regexps(%{ $h });
229          }          }
230          $log->debug("rec_regex: ", Dumper($rec_regex)) if ($rec_regex);          $log->debug("rec_regex: ", sub { dump($rec_regex) }) if ($rec_regex);
231    
232          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!");
233    
# Line 287  sub open { Line 282  sub open {
282                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
283    
284                  my $rec = $ll_db->fetch_rec($pos, sub {                  my $rec = $ll_db->fetch_rec($pos, sub {
285                                  my ($l,$f_nr) = @_;                                  my ($l,$f_nr,$debug) = @_;
286  #                               return unless defined($l);  #                               return unless defined($l);
287  #                               return $l unless ($rec_regex && $f_nr);  #                               return $l unless ($rec_regex && $f_nr);
288    
289                                    return unless ( defined($l) && defined($f_nr) );
290    
291                                    warn "-=> $f_nr ## |$l|\n" if ($debug);
292                                  $log->debug("-=> $f_nr ## $l");                                  $log->debug("-=> $f_nr ## $l");
293    
294                                  # codepage conversion and recode_regex                                  # codepage conversion and recode_regex
# Line 303  sub open { Line 301  sub open {
301                                          my $c = 0;                                          my $c = 0;
302                                          foreach my $r (@{ $rec_regex->{$f_nr} }) {                                          foreach my $r (@{ $rec_regex->{$f_nr} }) {
303                                                  my $old_l = $l;                                                  my $old_l = $l;
304                                                  eval '$l =~ ' . $r;                                                  $log->logconfess("expected regex in ", dump( $r )) unless defined($r->{regex});
305                                                    eval '$l =~ ' . $r->{regex};
306                                                  if ($old_l ne $l) {                                                  if ($old_l ne $l) {
307                                                          $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};
308                                                            $d .= ' +' . $r->{line} . ' ' . $r->{file} if defined($r->{line});
309                                                            $d .= ' ' . $r->{debug} if defined($r->{debug});
310                                                            $log->debug("MODIFY $d");
311                                                            warn "*** $d\n" if ($debug);
312    
313                                                  }                                                  }
314                                                  $log->error("error applying regex: $r") if ($@);                                                  $log->error("error applying regex: $r") if ($@);
315                                          }                                          }
316                                  }                                  }
317    
318                                  $log->debug("<=- $f_nr ## $l");                                  $log->debug("<=- $f_nr ## |$l|");
319                                    warn "<=- $f_nr ## $l\n" if ($debug);
320                                  return $l;                                  return $l;
321                  });                  });
322    
323                  $log->debug(sub { Dumper($rec) });                  $log->debug(sub { dump($rec) });
324    
325                  if (! $rec) {                  if (! $rec) {
326                          $log->warn("record $pos empty? skipping...");                          $log->warn("record $pos empty? skipping...");
# Line 474  First record in database has position 1. Line 479  First record in database has position 1.
479    
480  sub seek {  sub seek {
481          my $self = shift;          my $self = shift;
482          my $pos = shift || return;          my $pos = shift;
483    
484          my $log = $self->_get_logger();          my $log = $self->_get_logger();
485    
486            $log->logconfess("called without pos") unless defined($pos);
487    
488          if ($pos < 1) {          if ($pos < 1) {
489                  $log->warn("seek before first record");                  $log->warn("seek before first record");
490                  $pos = 1;                  $pos = 1;
# Line 512  sub stats { Line 519  sub stats {
519    
520          my $out = join("\n",          my $out = join("\n",
521                  map {                  map {
522                          my $f = $_ || die "no field";                          my $f = $_;
523                            die "no field in ", dump( $s->{fld} ) unless defined( $f );
524                          my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";                          my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
525                          $max_fld = $v if ($v > $max_fld);                          $max_fld = $v if ($v > $max_fld);
526    
# Line 532  sub stats { Line 540  sub stats {
540                          }                          }
541    
542                          $o;                          $o;
543                  } sort { $a cmp $b } keys %{ $s->{fld} }                  } sort { $a <=> $b } keys %{ $s->{fld} }
544          );          );
545    
546          $log->debug( sub { Dumper($s) } );          $log->debug( sub { dump($s) } );
547    
548          return $out;          return $out;
549  }  }
550    
551  =head2 dump  =head2 dump_ascii
552    
553  Display humanly readable dump of record  Display humanly readable dump of record
554    
555  =cut  =cut
556    
557  sub dump {  sub dump_ascii {
558          my $self = shift;          my $self = shift;
559    
560          return $self->{ll_db}->dump_rec( $self->{pos} );          return unless $self->{ll_db};
561    
562            if ($self->{ll_db}->can('dump_ascii')) {
563                    return $self->{ll_db}->dump_ascii( $self->{pos} );
564            } else {
565                    return dump( $self->{ll_db}->fetch_rec( $self->{pos} ) );
566            }
567  }  }
568    
569  =head2 modify_record_regexps  =head2 _get_regex
570    
571  Generate hash with regexpes to be applied using l<filter>.  Helper function called which create regexps to be execute on code.
572    
573    my $regexpes = $input->modify_record_regexps(    _get_regex( 900, 'regex:[0-9]+' ,'numbers' );
574                  900 => { '^a' => { ' : ' => '^b' } },    _get_regex( 900, '^b', ' : ^b' );
575                  901 => { '*' => { '^b' => ' ; ' } },  
576    );  It supports perl regexps with C<regex:> prefix to from value and has
577    additional logic to skip empty subfields.
578    
579  =cut  =cut
580    
581  sub _get_regex {  sub _get_regex {
582          my ($sf,$from,$to) = @_;          my ($sf,$from,$to) = @_;
583    
584            # protect /
585            $from =~ s!/!\\/!gs;
586            $to =~ s!/!\\/!gs;
587    
588            if ($from =~ m/^regex:(.+)$/) {
589                    $from = $1;
590            } else {
591                    $from = '\Q' . $from . '\E';
592            }
593          if ($sf =~ /^\^/) {          if ($sf =~ /^\^/) {
594                    my $need_subfield_data = '*';   # no
595                    # if from is also subfield, require some data in between
596                    # to correctly skip empty subfields
597                    $need_subfield_data = '+' if ($from =~ m/^\\Q\^/);
598                  return                  return
599                          's/\Q'. $sf .'\E([^\^]*?)\Q'. $from .'\E([^\^]*?)/'. $sf .'$1'. $to .'$2/';                          's/\Q'. $sf .'\E([^\^]' . $need_subfield_data . '?)'. $from .'([^\^]*?)/'. $sf .'$1'. $to .'$2/';
600          } else {          } else {
601                  return                  return
602                          's/\Q'. $from .'\E/'. $to .'/g';                          's/'. $from .'/'. $to .'/g';
603          }          }
604  }  }
605    
606    
607    =head2 modify_record_regexps
608    
609    Generate hash with regexpes to be applied using L<filter>.
610    
611      my $regexpes = $input->modify_record_regexps(
612                    900 => { '^a' => { ' : ' => '^b' } },
613                    901 => { '*' => { '^b' => ' ; ' } },
614      );
615    
616    =cut
617    
618  sub modify_record_regexps {  sub modify_record_regexps {
619          my $self = shift;          my $self = shift;
620          my $modify_record = {@_};          my $modify_record = {@_};
# Line 592  sub modify_record_regexps { Line 632  sub modify_record_regexps {
632                          foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {                          foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
633                                  my $to = $modify_record->{$f}->{$sf}->{$from};                                  my $to = $modify_record->{$f}->{$sf}->{$from};
634                                  #die "no field?" unless defined($to);                                  #die "no field?" unless defined($to);
635                                  $log->debug("transform: |$from| -> |$to|");                                  my $d = "|$from| -> |$to|";
636                                    $log->debug("transform: $d");
637    
638                                  my $regex = _get_regex($sf,$from,$to);                                  my $regex = _get_regex($sf,$from,$to);
639                                  push @{ $regexpes->{$f} }, $regex;                                  push @{ $regexpes->{$f} }, { regex => $regex, debug => $d };
640                                  $log->debug("regex: $regex");                                  $log->debug("regex: $regex");
641                          }                          }
642                  }                  }
# Line 606  sub modify_record_regexps { Line 647  sub modify_record_regexps {
647    
648  =head2 modify_file_regexps  =head2 modify_file_regexps
649    
650  Generate hash with regexpes to be applied using l<filter> from  Generate hash with regexpes to be applied using L<filter> from
651  pseudo hash/yaml format for regex mappings.  pseudo hash/yaml format for regex mappings.
652    
653  It should be obvious:  It should be obvious:
# Line 656  sub modify_file_regexps { Line 697  sub modify_file_regexps {
697                          $log->debug("transform: |$from| -> |$to|");                          $log->debug("transform: |$from| -> |$to|");
698    
699                          my $regex = _get_regex($sf,$from,$to);                          my $regex = _get_regex($sf,$from,$to);
700                          push @{ $regexpes->{$f} }, $regex;                          push @{ $regexpes->{$f} }, {
701                                    regex => $regex,
702                                    file => $modify_path,
703                                    line => $.,
704                            };
705                          $log->debug("regex: $regex");                          $log->debug("regex: $regex");
706                  }                  }
707          }          }
Legend:
Removed from v.761  
changed lines
  Added in v.860
  ViewVC Help
Powered by ViewVC 1.1.26