/[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 624 by dpavlin, Sat Aug 26 12:00:31 2006 UTC revision 707 by dpavlin, Mon Sep 25 15:26:12 2006 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.11  Version 0.13
20    
21  =cut  =cut
22    
23  our $VERSION = '0.11';  our $VERSION = '0.13';
24    
25  =head1 SYNOPSIS  =head1 SYNOPSIS
26    
# Line 107  sub new { Line 107  sub new {
107          #eval $self->{module} .'->import';          #eval $self->{module} .'->import';
108    
109          # check if required subclasses are implemented          # check if required subclasses are implemented
110          foreach my $subclass (qw/open_db fetch_rec init/) {          foreach my $subclass (qw/open_db fetch_rec init dump_rec/) {
111                  my $n = $self->{module} . '::' . $subclass;                  my $n = $self->{module} . '::' . $subclass;
112                  if (! defined &{ $n }) {                  if (! defined &{ $n }) {
113                          my $missing = "missing $subclass in $self->{module}";                          my $missing = "missing $subclass in $self->{module}";
# Line 162  This function will read whole database i Line 162  This function will read whole database i
162          code_page => 'cp852',          code_page => 'cp852',
163          limit => 500,          limit => 500,
164          offset => 6000,          offset => 6000,
         lookup => $lookup_obj,  
165          stats => 1,          stats => 1,
166          lookup_ref => sub {          lookup_coderef => sub {
167                  my ($k,$v) = @_;                  my $rec = shift;
168                  # store lookup $k => $v                  # store lookups
169          },          },
170          modify_records => {          modify_records => {
171                  900 => { '^a' => { ' : ' => '^b' } },                  900 => { '^a' => { ' : ' => '^b' } },
172                  901 => { '*' => { '^b' => ' ; ' } },                  901 => { '*' => { '^b' => ' ; ' } },
173          },          },
174            modify_file => 'conf/modify/mapping.map',
175   );   );
176    
177  By default, C<code_page> is assumed to be C<cp852>.  By default, C<code_page> is assumed to be C<cp852>.
# Line 182  C<limit> is optional parametar to read j Line 182  C<limit> is optional parametar to read j
182    
183  C<stats> create optional report about usage of fields and subfields  C<stats> create optional report about usage of fields and subfields
184    
185  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.  
186    
187  C<modify_records> specify mapping from subfields to delimiters or from  C<modify_records> specify mapping from subfields to delimiters or from
188  delimiters to subfields, as well as oprations on fields (if subfield is  delimiters to subfields, as well as oprations on fields (if subfield is
189  defined as C<*>.  defined as C<*>.
190    
191    C<modify_file> is alternative for C<modify_records> above which preserves order and offers
192    (hopefully) simplier sintax than YAML or perl (see L</modify_file_regex>). This option
193    overrides C<modify_records> if both exists for same input.
194    
195  Returns size of database, regardless of C<offset> and C<limit>  Returns size of database, regardless of C<offset> and C<limit>
196  parametars, see also C<size>.  parametars, see also C<size>.
197    
# Line 204  sub open { Line 207  sub open {
207          $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))          $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
208                  if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');                  if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
209    
210            $log->debug( $arg->{lookup_coderef} ? '' : 'not ', "using lookup_coderef");
211    
212          $log->logcroak("need path") if (! $arg->{'path'});          $log->logcroak("need path") if (! $arg->{'path'});
213          my $code_page = $arg->{'code_page'} || 'cp852';          my $code_page = $arg->{'code_page'} || 'cp852';
214    
# Line 235  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},
# Line 286  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, sub {                  my $rec = $self->{fetch_rec}->($self, $pos, sub {
302                                  my ($l,$f_nr) = @_;                                  my ($l,$f_nr) = @_;
303  #                               return unless defined($l);  #                               return unless defined($l);
304  #                               return $l unless ($rec_regex && $f_nr);  #                               return $l unless ($rec_regex && $f_nr);
305    
306  warn "## --> $f_nr ## $l\n";                                  $log->debug("-=> $f_nr ## $l");
307    
308                                  # codepage conversion and recode_regex                                  # codepage conversion and recode_regex
309  #                               from_to($l, $code_page, $self->{'encoding'});                                  from_to($l, $code_page, $self->{'encoding'});
                                 from_to($l, $code_page, 'utf-8');  
310                                  $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);                                  $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
311    
312                                  # apply regexps                                  # apply regexps
# Line 302  warn "## --> $f_nr ## $l\n"; Line 314  warn "## --> $f_nr ## $l\n";
314                                          $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');                                          $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
315                                          my $c = 0;                                          my $c = 0;
316                                          foreach my $r (@{ $rec_regex->{$f_nr} }) {                                          foreach my $r (@{ $rec_regex->{$f_nr} }) {
317                                                  #$log->debug("\$l = $l\neval \$l =~ $r");                                                  my $old_l = $l;
318                                                  eval '$l =~ ' . $r;                                                  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 ($@);                                                  $log->error("error applying regex: $r") if ($@);
323                                          }                                          }
324                                  }                                  }
325    
326  warn "## <-- $f_nr ## $l\n";                                  $log->debug("<=- $f_nr ## $l");
327                                  return $l;                                  return $l;
328                  });                  });
329    
# Line 333  warn "## <-- $f_nr ## $l\n"; Line 348  warn "## <-- $f_nr ## $l\n";
348                  if ($self->{stats}) {                  if ($self->{stats}) {
349    
350                          # fetch clean record with regexpes applied for statistics                          # fetch clean record with regexpes applied for statistics
351                          my $rec = $self->{fetch_rec}->($self, $db, $pos);                          my $rec = $self->{fetch_rec}->($self, $pos);
352    
353                          foreach my $fld (keys %{ $rec }) {                          foreach my $fld (keys %{ $rec }) {
354                                  $self->{_stats}->{fld}->{ $fld }++;                                  $self->{_stats}->{fld}->{ $fld }++;
# Line 531  sub stats { Line 546  sub stats {
546          return $out;          return $out;
547  }  }
548    
549    =head2 dump
550    
551    Display humanly readable dump of record
552    
553    =cut
554    
555    sub dump {
556            my $self = shift;
557    
558            return $self->{dump_rec}->($self, $self->{pos});
559    
560    }
561    
562  =head2 modify_record_regexps  =head2 modify_record_regexps
563    
564  Generate hash with regexpes to be applied using L<filter>.  Generate hash with regexpes to be applied using l<filter>.
565    
566    my $regexpes = $input->modify_record_regexps(    my $regexpes = $input->modify_record_regexps(
567                  900 => { '^a' => { ' : ' => '^b' } },                  900 => { '^a' => { ' : ' => '^b' } },
# Line 542  Generate hash with regexpes to be applie Line 570  Generate hash with regexpes to be applie
570    
571  =cut  =cut
572    
573    sub _get_regex {
574            my ($sf,$from,$to) = @_;
575            if ($sf =~ /^\^/) {
576                    return
577                            's/\Q'. $sf .'\E([^\^]*?)\Q'. $from .'\E([^\^]*?)/'. $sf .'$1'. $to .'$2/';
578            } else {
579                    return
580                            's/\Q'. $from .'\E/'. $to .'/g';
581            }
582    }
583    
584  sub modify_record_regexps {  sub modify_record_regexps {
585          my $self = shift;          my $self = shift;
586          my $modify_record = {@_};          my $modify_record = {@_};
587    
588          my $regexpes;          my $regexpes;
589    
590            my $log = $self->_get_logger();
591    
592          foreach my $f (keys %$modify_record) {          foreach my $f (keys %$modify_record) {
593  warn "--- f: $f\n";                  $log->debug("field: $f");
594    
595                  foreach my $sf (keys %{ $modify_record->{$f} }) {                  foreach my $sf (keys %{ $modify_record->{$f} }) {
596  warn "---- sf: $sf\n";                          $log->debug("subfield: $sf");
597    
598                          foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {                          foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
599                                  my $to = $modify_record->{$f}->{$sf}->{$from};                                  my $to = $modify_record->{$f}->{$sf}->{$from};
600                                  #die "no field?" unless defined($to);                                  #die "no field?" unless defined($to);
601  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";  
                                 }  
602    
603                                    my $regex = _get_regex($sf,$from,$to);
604                                    push @{ $regexpes->{$f} }, $regex;
605                                    $log->debug("regex: $regex");
606                          }                          }
607                  }                  }
608          }          }
609    
610            return $regexpes;
611    }
612    
613    =head2 modify_file_regexps
614    
615    Generate hash with regexpes to be applied using l<filter> from
616    pseudo hash/yaml format for regex mappings.
617    
618    It should be obvious:
619    
620            200
621              '^a'
622                ' : ' => '^e'
623                ' = ' => '^d'
624    
625    In field I<200> find C<'^a'> and then C<' : '>, and replace it with C<'^e'>.
626    In field I<200> find C<'^a'> and then C<' = '>, and replace it with C<'^d'>.
627    
628      my $regexpes = $input->modify_file_regexps( 'conf/modify/common.pl' );
629    
630    On undef path it will just return.
631    
632    =cut
633    
634    sub modify_file_regexps {
635            my $self = shift;
636    
637            my $modify_path = shift || return;
638    
639            my $log = $self->_get_logger();
640    
641            my $regexpes;
642    
643            CORE::open(my $fh, $modify_path) || $log->logdie("can't open modify file $modify_path: $!");
644    
645            my ($f,$sf);
646    
647            while(<$fh>) {
648                    chomp;
649                    next if (/^#/ || /^\s*$/);
650    
651                    if (/^\s*(\d+)\s*$/) {
652                            $f = $1;
653                            $log->debug("field: $f");
654                            next;
655                    } elsif (/^\s*'([^']*)'\s*$/) {
656                            $sf = $1;
657                            $log->die("can't define subfiled before field in: $_") unless ($f);
658                            $log->debug("subfield: $sf");
659                    } elsif (/^\s*'([^']*)'\s*=>\s*'([^']*)'\s*$/) {
660                            my ($from,$to) = ($1, $2);
661    
662                            $log->debug("transform: |$from| -> |$to|");
663    
664                            my $regex = _get_regex($sf,$from,$to);
665                            push @{ $regexpes->{$f} }, $regex;
666                            $log->debug("regex: $regex");
667                    }
668            }
669    
670          return $regexpes;          return $regexpes;
671  }  }
672    
Legend:
Removed from v.624  
changed lines
  Added in v.707
  ViewVC Help
Powered by ViewVC 1.1.26