/[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 599 by dpavlin, Thu Jul 13 13:55:19 2006 UTC revision 636 by dpavlin, Wed Sep 6 19:25:22 2006 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/;
 use Text::Iconv;  
10  use Data::Dumper;  use Data::Dumper;
11    use Encode qw/from_to/;
12    
13  =head1 NAME  =head1 NAME
14    
# 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.09  Version 0.12
20    
21  =cut  =cut
22    
23  our $VERSION = '0.09';  our $VERSION = '0.12';
24    
25  =head1 SYNOPSIS  =head1 SYNOPSIS
26    
# Line 159  This function will read whole database i Line 159  This function will read whole database i
159    
160   $input->open(   $input->open(
161          path => '/path/to/database/file',          path => '/path/to/database/file',
162          code_page => '852',          code_page => 'cp852',
163          limit => 500,          limit => 500,
164          offset => 6000,          offset => 6000,
165          lookup => $lookup_obj,          lookup => $lookup_obj,
# Line 172  This function will read whole database i Line 172  This function will read whole database i
172                  900 => { '^a' => { ' : ' => '^b' } },                  900 => { '^a' => { ' : ' => '^b' } },
173                  901 => { '*' => { '^b' => ' ; ' } },                  901 => { '*' => { '^b' => ' ; ' } },
174          },          },
175            modify_file => 'conf/modify/mapping.map',
176   );   );
177    
178  By default, C<code_page> is assumed to be C<852>.  By default, C<code_page> is assumed to be C<cp852>.
179    
180  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.
181    
# Line 189  C<modify_records> specify mapping from s Line 190  C<modify_records> specify mapping from s
190  delimiters to subfields, as well as oprations on fields (if subfield is  delimiters to subfields, as well as oprations on fields (if subfield is
191  defined as C<*>.  defined as C<*>.
192    
193    C<modify_file> is alternative for C<modify_records> above which preserves order and offers
194    (hopefully) simplier sintax than YAML or perl (see L</modify_file_regex>). This option
195    overrides C<modify_records> if both exists for same input.
196    
197  Returns size of database, regardless of C<offset> and C<limit>  Returns size of database, regardless of C<offset> and C<limit>
198  parametars, see also C<size>.  parametars, see also C<size>.
199    
# Line 205  sub open { Line 210  sub open {
210                  if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');                  if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
211    
212          $log->logcroak("need path") if (! $arg->{'path'});          $log->logcroak("need path") if (! $arg->{'path'});
213          my $code_page = $arg->{'code_page'} || '852';          my $code_page = $arg->{'code_page'} || 'cp852';
214    
215          # store data in object          # store data in object
216          $self->{'input_code_page'} = $code_page;          $self->{'input_code_page'} = $code_page;
# Line 213  sub open { Line 218  sub open {
218                  $self->{$v} = $arg->{$v} if ($arg->{$v});                  $self->{$v} = $arg->{$v} if ($arg->{$v});
219          }          }
220    
         # create Text::Iconv object  
         $self->{iconv} = Text::Iconv->new($code_page,$self->{'encoding'});      ## FIXME remove!  
   
221          my $filter_ref;          my $filter_ref;
222          my $recode_regex;          my $recode_regex;
223          my $recode_map;          my $recode_map;
# Line 238  sub open { Line 240  sub open {
240    
241          }          }
242    
243          my $rec_regex = $self->modify_record_regexps(%{ $arg->{modify_records} });          my $rec_regex;
244          $log->debug("rec_regex: ", Dumper($rec_regex));          if (my $p = $arg->{modify_file}) {
245                    $log->debug("using modify_file $p");
246                    $rec_regex = $self->modify_file_regexps( $p );
247            } elsif (my $h = $arg->{modify_records}) {
248                    $log->debug("using modify_records ", Dumper( $h ));
249                    $rec_regex = $self->modify_record_regexps(%{ $h });
250            }
251            $log->debug("rec_regex: ", Dumper($rec_regex)) if ($rec_regex);
252    
253          my ($db, $size) = $self->{open_db}->( $self,          my ($db, $size) = $self->{open_db}->( $self,
254                  path => $arg->{path},                  path => $arg->{path},
255                  filter => sub {  #               filter => sub {
256                                  my ($l,$f_nr) = @_;  #                       my ($l,$f_nr) = @_;
257                                  return unless defined($l);  #                       return unless defined($l);
258    #                       from_to($l, $code_page, $self->{'encoding'});
259                                  ## FIXME remove iconv!  #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
260                                  $l = $self->{iconv}->convert($l) if ($self->{iconv});  #                       return $l;
261            #               },
                                 $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);  
   
                                 ## FIXME remove this warning when we are sure that none of API is calling  
                                 ## this wrongly  
                                 warn "filter called without field number" unless ($f_nr);  
   
                                 return $l unless ($rec_regex && $f_nr);  
   
                                 # apply regexps  
                                 if ($rec_regex && defined($rec_regex->{$f_nr})) {  
                                         $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');  
                                         my $c = 0;  
                                         foreach my $r (@{ $rec_regex->{$f_nr} }) {  
                                                 while ( eval '$l =~ ' . $r ) { $c++ };  
                                         }  
                                         warn "## field $f_nr triggered $c regexpes\n" if ($c && $self->{debug});  
                                 }  
   
                                 return $l;  
                 },  
262                  %{ $arg },                  %{ $arg },
263          );          );
264    
# Line 309  sub open { Line 298  sub open {
298    
299                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
300    
301                  my $rec = $self->{fetch_rec}->($self, $db, $pos );                  my $rec = $self->{fetch_rec}->($self, $db, $pos, sub {
302                                    my ($l,$f_nr) = @_;
303    #                               return unless defined($l);
304    #                               return $l unless ($rec_regex && $f_nr);
305    
306                                    $log->debug("-=> $f_nr ## $l");
307    
308                                    # codepage conversion and recode_regex
309                                    from_to($l, $code_page, $self->{'encoding'});
310                                    $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
311    
312                                    # apply regexps
313                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
314                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
315                                            my $c = 0;
316                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
317                                                    my $old_l = $l;
318                                                    eval '$l =~ ' . $r;
319                                                    if ($old_l ne $l) {
320                                                            $log->debug("REGEX on $f_nr eval \$l =~ $r\n## old l: [$old_l]\n## new l: [$l]");
321                                                    }
322                                                    $log->error("error applying regex: $r") if ($@);
323                                            }
324                                    }
325    
326                                    $log->debug("<=- $f_nr ## $l");
327                                    return $l;
328                    });
329    
330                  $log->debug(sub { Dumper($rec) });                  $log->debug(sub { Dumper($rec) });
331    
# Line 331  sub open { Line 347  sub open {
347                  # update counters for statistics                  # update counters for statistics
348                  if ($self->{stats}) {                  if ($self->{stats}) {
349    
350                            # fetch clean record with regexpes applied for statistics
351                            my $rec = $self->{fetch_rec}->($self, $db, $pos);
352    
353                          foreach my $fld (keys %{ $rec }) {                          foreach my $fld (keys %{ $rec }) {
354                                  $self->{_stats}->{fld}->{ $fld }++;                                  $self->{_stats}->{fld}->{ $fld }++;
355    
# Line 342  sub open { Line 361  sub open {
361                                          if (ref($row) eq 'HASH') {                                          if (ref($row) eq 'HASH') {
362    
363                                                  foreach my $sf (keys %{ $row }) {                                                  foreach my $sf (keys %{ $row }) {
364                                                            next if ($sf eq 'subfields');
365                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
366                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
367                                                                          if (ref($row->{$sf}) eq 'ARRAY');                                                                          if (ref($row->{$sf}) eq 'ARRAY');
# Line 528  sub stats { Line 548  sub stats {
548    
549  =head2 modify_record_regexps  =head2 modify_record_regexps
550    
551  Generate hash with regexpes to be applied using L<filter>.  Generate hash with regexpes to be applied using l<filter>.
552    
553    my $regexpes = $input->modify_record_regexps(    my $regexpes = $input->modify_record_regexps(
554                  900 => { '^a' => { ' : ' => '^b' } },                  900 => { '^a' => { ' : ' => '^b' } },
# Line 537  Generate hash with regexpes to be applie Line 557  Generate hash with regexpes to be applie
557    
558  =cut  =cut
559    
560    sub _get_regex {
561            my ($sf,$from,$to) = @_;
562            if ($sf =~ /^\^/) {
563                    return
564                            's/\Q'. $sf .'\E([^\^]*?)\Q'. $from .'\E([^\^]*?)/'. $sf .'$1'. $to .'$2/';
565            } else {
566                    return
567                            's/\Q'. $from .'\E/'. $to .'/g';
568            }
569    }
570    
571  sub modify_record_regexps {  sub modify_record_regexps {
572          my $self = shift;          my $self = shift;
573          my $modify_record = {@_};          my $modify_record = {@_};
574    
575          my $regexpes;          my $regexpes;
576    
577            my $log = $self->_get_logger();
578    
579          foreach my $f (keys %$modify_record) {          foreach my $f (keys %$modify_record) {
580  warn "--- f: $f\n";                  $log->debug("field: $f");
581    
582                  foreach my $sf (keys %{ $modify_record->{$f} }) {                  foreach my $sf (keys %{ $modify_record->{$f} }) {
583  warn "---- sf: $sf\n";                          $log->debug("subfield: $sf");
584    
585                          foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {                          foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
586                                  my $to = $modify_record->{$f}->{$sf}->{$from};                                  my $to = $modify_record->{$f}->{$sf}->{$from};
587                                  #die "no field?" unless defined($to);                                  #die "no field?" unless defined($to);
588  warn "----- transform: |$from| -> |$to|\n";                                  $log->debug("transform: |$from| -> |$to|");
   
                                 if ($sf =~ /^\^/) {  
                                         my $regex =  
                                                 's/\Q'. $sf .'\E([^\^]+)\Q'. $from .'\E([^\^]+)/'. $sf .'$1'. $to .'$2/g';  
                                         push @{ $regexpes->{$f} }, $regex;  
 warn ">>>>> $regex [sf]\n";  
                                 } else {  
                                         my $regex =  
                                                 's/\Q'. $from .'\E/'. $to .'/g';  
                                         push @{ $regexpes->{$f} }, $regex;  
 warn ">>>>> $regex [global]\n";  
                                 }  
589    
590                                    my $regex = _get_regex($sf,$from,$to);
591                                    push @{ $regexpes->{$f} }, $regex;
592                                    $log->debug("regex: $regex");
593                          }                          }
594                  }                  }
595          }          }
596    
597            return $regexpes;
598    }
599    
600    =head2 modify_file_regexps
601    
602    Generate hash with regexpes to be applied using l<filter> from
603    pseudo hash/yaml format for regex mappings.
604    
605    It should be obvious:
606    
607            200
608              '^a'
609                ' : ' => '^e'
610                ' = ' => '^d'
611    
612    In field I<200> find C<'^a'> and then C<' : '>, and replace it with C<'^e'>.
613    In field I<200> find C<'^a'> and then C<' = '>, and replace it with C<'^d'>.
614    
615      my $regexpes = $input->modify_file_regexps( 'conf/modify/common.pl' );
616    
617    On undef path it will just return.
618    
619    =cut
620    
621    sub modify_file_regexps {
622            my $self = shift;
623    
624            my $modify_path = shift || return;
625    
626            my $log = $self->_get_logger();
627    
628            my $regexpes;
629    
630            CORE::open(my $fh, $modify_path) || $log->die("can't open modify file $modify_path: $!");
631    
632            my ($f,$sf);
633    
634            while(<$fh>) {
635                    chomp;
636                    next if (/^#/ || /^\s*$/);
637    
638                    if (/^\s*(\d+)\s*$/) {
639                            $f = $1;
640                            $log->debug("field: $f");
641                            next;
642                    } elsif (/^\s*'([^']*)'\s*$/) {
643                            $sf = $1;
644                            $log->die("can't define subfiled before field in: $_") unless ($f);
645                            $log->debug("subfield: $sf");
646                    } elsif (/^\s*'([^']*)'\s*=>\s*'([^']*)'\s*$/) {
647                            my ($from,$to) = ($1, $2);
648    
649                            $log->debug("transform: |$from| -> |$to|");
650    
651                            my $regex = _get_regex($sf,$from,$to);
652                            push @{ $regexpes->{$f} }, $regex;
653                            $log->debug("regex: $regex");
654                    }
655            }
656    
657          return $regexpes;          return $regexpes;
658  }  }
659    
Legend:
Removed from v.599  
changed lines
  Added in v.636
  ViewVC Help
Powered by ViewVC 1.1.26