/[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 818 by dpavlin, Thu Apr 5 21:53:52 2007 UTC revision 1076 by dpavlin, Wed Nov 28 22:51:43 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 349  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 519  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 539  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 { dump($s) } );          $log->debug( sub { dump($s) } );
# Line 558  sub dump_ascii { Line 575  sub dump_ascii {
575    
576          return unless $self->{ll_db};          return unless $self->{ll_db};
577    
578          if ($self->{ll_db}->can('dump_rec')) {          if ($self->{ll_db}->can('dump_ascii')) {
579                  return $self->{ll_db}->dump_ascii( $self->{pos} );                  return $self->{ll_db}->dump_ascii( $self->{pos} );
580          } else {          } else {
581                  return dump( $self->{ll_db}->fetch_rec( $self->{pos} ) );                  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    
# Line 589  sub _get_regex { Line 607  sub _get_regex {
607                  $from = '\Q' . $from . '\E';                  $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([^\^]*?)'. $from .'([^\^]*?)/'. $sf .'$1'. $to .'$2/';                          's/\Q'. $sf .'\E([^\^]' . $need_subfield_data . '?)'. $from .'([^\^]*?)/'. $sf .'$1'. $to .'$2/';
616          } else {          } else {
617                  return                  return
618                          's/'. $from .'/'. $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 = {@_};
Legend:
Removed from v.818  
changed lines
  Added in v.1076
  ViewVC Help
Powered by ViewVC 1.1.26