/[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 800 by dpavlin, Sun Feb 4 23:10:18 2007 UTC revision 860 by dpavlin, Sun May 27 19:10: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 286  sub open { Line 286  sub open {
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);                                  warn "-=> $f_nr ## |$l|\n" if ($debug);
292                                  $log->debug("-=> $f_nr ## $l");                                  $log->debug("-=> $f_nr ## $l");
293    
# Line 517  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 537  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 { dump($s) } );          $log->debug( sub { dump($s) } );
# Line 556  sub dump_ascii { Line 559  sub dump_ascii {
559    
560          return unless $self->{ll_db};          return unless $self->{ll_db};
561    
562          if ($self->{ll_db}->can('dump_rec')) {          if ($self->{ll_db}->can('dump_ascii')) {
563                  return $self->{ll_db}->dump_ascii( $self->{pos} );                  return $self->{ll_db}->dump_ascii( $self->{pos} );
564          } else {          } else {
565                  return dump( $self->{ll_db}->fetch_rec( $self->{pos} ) );                  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    
# Line 587  sub _get_regex { Line 591  sub _get_regex {
591                  $from = '\Q' . $from . '\E';                  $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([^\^]*?)'. $from .'([^\^]*?)/'. $sf .'$1'. $to .'$2/';                          's/\Q'. $sf .'\E([^\^]' . $need_subfield_data . '?)'. $from .'([^\^]*?)/'. $sf .'$1'. $to .'$2/';
600          } else {          } else {
601                  return                  return
602                          's/'. $from .'/'. $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 = {@_};
Legend:
Removed from v.800  
changed lines
  Added in v.860
  ViewVC Help
Powered by ViewVC 1.1.26