/[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 613 by dpavlin, Wed Aug 23 11:04:32 2006 UTC revision 757 by dpavlin, Tue Oct 10 10:57:59 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.10  Version 0.13
20    
21  =cut  =cut
22    
23  our $VERSION = '0.10';  our $VERSION = '0.13';
24    
25  =head1 SYNOPSIS  =head1 SYNOPSIS
26    
# Line 98  sub new { Line 98  sub new {
98          $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if ($self->{lookup});          $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if ($self->{lookup});
99    
100          $log->logconfess("specify low-level file format module") unless ($self->{module});          $log->logconfess("specify low-level file format module") unless ($self->{module});
101          my $module = $self->{module};          my $module_path = $self->{module};
102          $module =~ s#::#/#g;          $module_path =~ s#::#/#g;
103          $module .= '.pm';          $module_path .= '.pm';
104          $log->debug("require low-level module $self->{module} from $module");          $log->debug("require low-level module $self->{module} from $module_path");
105    
106          require $module;          require $module_path;
         #eval $self->{module} .'->import';  
107    
108          # check if required subclasses are implemented          # check if required subclasses are implemented
109          foreach my $subclass (qw/open_db fetch_rec init/) {          foreach my $subclass (qw/open_db fetch_rec init dump_rec/) {
110                  my $n = $self->{module} . '::' . $subclass;                  # FIXME
                 if (! defined &{ $n }) {  
                         my $missing = "missing $subclass in $self->{module}";  
                         $self->{$subclass} = sub { $log->logwarn($missing) };  
                 } else {  
                         $self->{$subclass} = \&{ $n };  
                 }  
         }  
   
         if ($self->{init}) {  
                 $log->debug("calling init");  
                 $self->{init}->($self, @_);  
111          }          }
112    
113          $self->{'encoding'} ||= 'ISO-8859-2';          $self->{'encoding'} ||= 'ISO-8859-2';
# Line 159  This function will read whole database i Line 147  This function will read whole database i
147    
148   $input->open(   $input->open(
149          path => '/path/to/database/file',          path => '/path/to/database/file',
150          code_page => '852',          code_page => 'cp852',
151          limit => 500,          limit => 500,
152          offset => 6000,          offset => 6000,
         lookup => $lookup_obj,  
153          stats => 1,          stats => 1,
154          lookup_ref => sub {          lookup_coderef => sub {
155                  my ($k,$v) = @_;                  my $rec = shift;
156                  # store lookup $k => $v                  # store lookups
157          },          },
158          modify_records => {          modify_records => {
159                  900 => { '^a' => { ' : ' => '^b' } },                  900 => { '^a' => { ' : ' => '^b' } },
160                  901 => { '*' => { '^b' => ' ; ' } },                  901 => { '*' => { '^b' => ' ; ' } },
161          },          },
162            modify_file => 'conf/modify/mapping.map',
163   );   );
164    
165  By default, C<code_page> is assumed to be C<852>.  By default, C<code_page> is assumed to be C<cp852>.
166    
167  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.
168    
# Line 182  C<limit> is optional parametar to read j Line 170  C<limit> is optional parametar to read j
170    
171  C<stats> create optional report about usage of fields and subfields  C<stats> create optional report about usage of fields and subfields
172    
173  C<lookup_coderef> is closure to call when adding C<< key => 'value' >> combinations to  C<lookup_coderef> is closure to called to save data into lookups
 lookup.  
174    
175  C<modify_records> specify mapping from subfields to delimiters or from  C<modify_records> specify mapping from subfields to delimiters or from
176  delimiters to subfields, as well as oprations on fields (if subfield is  delimiters to subfields, as well as oprations on fields (if subfield is
177  defined as C<*>.  defined as C<*>.
178    
179    C<modify_file> is alternative for C<modify_records> above which preserves order and offers
180    (hopefully) simplier sintax than YAML or perl (see L</modify_file_regex>). This option
181    overrides C<modify_records> if both exists for same input.
182    
183  Returns size of database, regardless of C<offset> and C<limit>  Returns size of database, regardless of C<offset> and C<limit>
184  parametars, see also C<size>.  parametars, see also C<size>.
185    
# Line 204  sub open { Line 195  sub open {
195          $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))          $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
196                  if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');                  if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
197    
198            $log->debug( $arg->{lookup_coderef} ? '' : 'not ', "using lookup_coderef");
199    
200          $log->logcroak("need path") if (! $arg->{'path'});          $log->logcroak("need path") if (! $arg->{'path'});
201          my $code_page = $arg->{'code_page'} || '852';          my $code_page = $arg->{'code_page'} || 'cp852';
202    
203          # store data in object          # store data in object
204          $self->{'input_code_page'} = $code_page;          $self->{'input_code_page'} = $code_page;
# Line 213  sub open { Line 206  sub open {
206                  $self->{$v} = $arg->{$v} if ($arg->{$v});                  $self->{$v} = $arg->{$v} if ($arg->{$v});
207          }          }
208    
         # create Text::Iconv object  
         $self->{iconv} = Text::Iconv->new($code_page,$self->{'encoding'});      ## FIXME remove!  
   
209          my $filter_ref;          my $filter_ref;
210          my $recode_regex;          my $recode_regex;
211          my $recode_map;          my $recode_map;
# Line 238  sub open { Line 228  sub open {
228    
229          }          }
230    
231          my $rec_regex = $self->modify_record_regexps(%{ $arg->{modify_records} });          my $rec_regex;
232          $log->debug("rec_regex: ", Dumper($rec_regex));          if (my $p = $arg->{modify_file}) {
233                    $log->debug("using modify_file $p");
234          my ($db, $size) = $self->{open_db}->( $self,                  $rec_regex = $self->modify_file_regexps( $p );
235                  path => $arg->{path},          } elsif (my $h = $arg->{modify_records}) {
236                  filter => sub {                  $log->debug("using modify_records ", Dumper( $h ));
237                                  my ($l,$f_nr) = @_;                  $rec_regex = $self->modify_record_regexps(%{ $h });
238                                  return unless defined($l);          }
239            $log->debug("rec_regex: ", Dumper($rec_regex)) if ($rec_regex);
                                 ## FIXME remove iconv!  
                                 $l = $self->{iconv}->convert($l) if ($self->{iconv});  
           
                                 $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);  
   
 #                               my $max_regex = 100;  
   
                                 # 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} }) {  
                                                 #$log->debug("\$l = $l\neval \$l =~ $r");  
                                                 eval '$l =~ ' . $r;  
                                                 $log->error("error applying regex: $r") if ($@);  
   
 #                                               while ( $c < $max_regex && eval '$l =~ ' . $r ) { $c++ };  
 #                                               $log->error("field $f_nr has more than $max_regex regex iterations\n\$l = $l\neval \$l =~ $r") if ($c == $max_regex);  
240    
241                                          }          my $class = $self->{module} || $log->logconfess("can't get low-level module name!");
                                 }  
242    
243                                  return $l;          my $ll_db = $class->new(
244                  },                  path => $arg->{path},
245    #               filter => sub {
246    #                       my ($l,$f_nr) = @_;
247    #                       return unless defined($l);
248    #                       from_to($l, $code_page, $self->{'encoding'});
249    #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
250    #                       return $l;
251    #               },
252                  %{ $arg },                  %{ $arg },
253          );          );
254    
255          unless (defined($db)) {          unless (defined($ll_db)) {
256                  $log->logwarn("can't open database $arg->{path}, skipping...");                  $log->logwarn("can't open database $arg->{path}, skipping...");
257                  return;                  return;
258          }          }
259    
260            my $size = $ll_db->size;
261    
262          unless ($size) {          unless ($size) {
263                  $log->logwarn("no records in database $arg->{path}, skipping...");                  $log->logwarn("no records in database $arg->{path}, skipping...");
264                  return;                  return;
# Line 316  sub open { Line 290  sub open {
290    
291                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
292    
293                  my $rec = $self->{fetch_rec}->($self, $db, $pos );                  my $rec = $ll_db->fetch_rec($pos, sub {
294                                    my ($l,$f_nr) = @_;
295    #                               return unless defined($l);
296    #                               return $l unless ($rec_regex && $f_nr);
297    
298                                    $log->debug("-=> $f_nr ## $l");
299    
300                                    # codepage conversion and recode_regex
301                                    from_to($l, $code_page, $self->{'encoding'});
302                                    $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
303    
304                                    # apply regexps
305                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
306                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
307                                            my $c = 0;
308                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
309                                                    my $old_l = $l;
310                                                    eval '$l =~ ' . $r;
311                                                    if ($old_l ne $l) {
312                                                            $log->debug("REGEX on $f_nr eval \$l =~ $r\n## old l: [$old_l]\n## new l: [$l]");
313                                                    }
314                                                    $log->error("error applying regex: $r") if ($@);
315                                            }
316                                    }
317    
318                                    $log->debug("<=- $f_nr ## $l");
319                                    return $l;
320                    });
321    
322                  $log->debug(sub { Dumper($rec) });                  $log->debug(sub { Dumper($rec) });
323    
# Line 338  sub open { Line 339  sub open {
339                  # update counters for statistics                  # update counters for statistics
340                  if ($self->{stats}) {                  if ($self->{stats}) {
341    
342                            # fetch clean record with regexpes applied for statistics
343                            my $rec = $ll_db->fetch_rec($pos);
344    
345                          foreach my $fld (keys %{ $rec }) {                          foreach my $fld (keys %{ $rec }) {
346                                  $self->{_stats}->{fld}->{ $fld }++;                                  $self->{_stats}->{fld}->{ $fld }++;
347    
# Line 349  sub open { Line 353  sub open {
353                                          if (ref($row) eq 'HASH') {                                          if (ref($row) eq 'HASH') {
354    
355                                                  foreach my $sf (keys %{ $row }) {                                                  foreach my $sf (keys %{ $row }) {
356                                                            next if ($sf eq 'subfields');
357                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
358                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
359                                                                          if (ref($row->{$sf}) eq 'ARRAY');                                                                          if (ref($row->{$sf}) eq 'ARRAY');
# Line 372  sub open { Line 377  sub open {
377          $self->{max_pos} = $to_rec;          $self->{max_pos} = $to_rec;
378          $log->debug("max_pos: $to_rec");          $log->debug("max_pos: $to_rec");
379    
380            # save for dump
381            $self->{ll_db} = $ll_db;
382    
383          return $size;          return $size;
384  }  }
385    
# Line 533  sub stats { Line 541  sub stats {
541          return $out;          return $out;
542  }  }
543    
544    =head2 dump
545    
546    Display humanly readable dump of record
547    
548    =cut
549    
550    sub dump {
551            my $self = shift;
552    
553            return $self->{ll_db}->dump_rec( $self->{pos} );
554    
555    }
556    
557  =head2 modify_record_regexps  =head2 modify_record_regexps
558    
559  Generate hash with regexpes to be applied using L<filter>.  Generate hash with regexpes to be applied using l<filter>.
560    
561    my $regexpes = $input->modify_record_regexps(    my $regexpes = $input->modify_record_regexps(
562                  900 => { '^a' => { ' : ' => '^b' } },                  900 => { '^a' => { ' : ' => '^b' } },
# Line 544  Generate hash with regexpes to be applie Line 565  Generate hash with regexpes to be applie
565    
566  =cut  =cut
567    
568    sub _get_regex {
569            my ($sf,$from,$to) = @_;
570            if ($sf =~ /^\^/) {
571                    return
572                            's/\Q'. $sf .'\E([^\^]*?)\Q'. $from .'\E([^\^]*?)/'. $sf .'$1'. $to .'$2/';
573            } else {
574                    return
575                            's/\Q'. $from .'\E/'. $to .'/g';
576            }
577    }
578    
579  sub modify_record_regexps {  sub modify_record_regexps {
580          my $self = shift;          my $self = shift;
581          my $modify_record = {@_};          my $modify_record = {@_};
582    
583          my $regexpes;          my $regexpes;
584    
585            my $log = $self->_get_logger();
586    
587          foreach my $f (keys %$modify_record) {          foreach my $f (keys %$modify_record) {
588  warn "--- f: $f\n";                  $log->debug("field: $f");
589    
590                  foreach my $sf (keys %{ $modify_record->{$f} }) {                  foreach my $sf (keys %{ $modify_record->{$f} }) {
591  warn "---- sf: $sf\n";                          $log->debug("subfield: $sf");
592    
593                          foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {                          foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
594                                  my $to = $modify_record->{$f}->{$sf}->{$from};                                  my $to = $modify_record->{$f}->{$sf}->{$from};
595                                  #die "no field?" unless defined($to);                                  #die "no field?" unless defined($to);
596  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";  
                                 }  
597    
598                                    my $regex = _get_regex($sf,$from,$to);
599                                    push @{ $regexpes->{$f} }, $regex;
600                                    $log->debug("regex: $regex");
601                          }                          }
602                  }                  }
603          }          }
604    
605            return $regexpes;
606    }
607    
608    =head2 modify_file_regexps
609    
610    Generate hash with regexpes to be applied using l<filter> from
611    pseudo hash/yaml format for regex mappings.
612    
613    It should be obvious:
614    
615            200
616              '^a'
617                ' : ' => '^e'
618                ' = ' => '^d'
619    
620    In field I<200> find C<'^a'> and then C<' : '>, and replace it with C<'^e'>.
621    In field I<200> find C<'^a'> and then C<' = '>, and replace it with C<'^d'>.
622    
623      my $regexpes = $input->modify_file_regexps( 'conf/modify/common.pl' );
624    
625    On undef path it will just return.
626    
627    =cut
628    
629    sub modify_file_regexps {
630            my $self = shift;
631    
632            my $modify_path = shift || return;
633    
634            my $log = $self->_get_logger();
635    
636            my $regexpes;
637    
638            CORE::open(my $fh, $modify_path) || $log->logdie("can't open modify file $modify_path: $!");
639    
640            my ($f,$sf);
641    
642            while(<$fh>) {
643                    chomp;
644                    next if (/^#/ || /^\s*$/);
645    
646                    if (/^\s*(\d+)\s*$/) {
647                            $f = $1;
648                            $log->debug("field: $f");
649                            next;
650                    } elsif (/^\s*'([^']*)'\s*$/) {
651                            $sf = $1;
652                            $log->die("can't define subfiled before field in: $_") unless ($f);
653                            $log->debug("subfield: $sf");
654                    } elsif (/^\s*'([^']*)'\s*=>\s*'([^']*)'\s*$/) {
655                            my ($from,$to) = ($1, $2);
656    
657                            $log->debug("transform: |$from| -> |$to|");
658    
659                            my $regex = _get_regex($sf,$from,$to);
660                            push @{ $regexpes->{$f} }, $regex;
661                            $log->debug("regex: $regex");
662                    }
663            }
664    
665          return $regexpes;          return $regexpes;
666  }  }
667    
Legend:
Removed from v.613  
changed lines
  Added in v.757
  ViewVC Help
Powered by ViewVC 1.1.26