/[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 626 by dpavlin, Mon Sep 4 16:15:07 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.11
20    
21  =cut  =cut
22    
23  our $VERSION = '0.10';  our $VERSION = '0.11';
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 174  This function will read whole database i Line 174  This function will read whole database i
174          },          },
175   );   );
176    
177  By default, C<code_page> is assumed to be C<852>.  By default, C<code_page> is assumed to be C<cp852>.
178    
179  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.
180    
# Line 205  sub open { Line 205  sub open {
205                  if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');                  if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
206    
207          $log->logcroak("need path") if (! $arg->{'path'});          $log->logcroak("need path") if (! $arg->{'path'});
208          my $code_page = $arg->{'code_page'} || '852';          my $code_page = $arg->{'code_page'} || 'cp852';
209    
210          # store data in object          # store data in object
211          $self->{'input_code_page'} = $code_page;          $self->{'input_code_page'} = $code_page;
# Line 213  sub open { Line 213  sub open {
213                  $self->{$v} = $arg->{$v} if ($arg->{$v});                  $self->{$v} = $arg->{$v} if ($arg->{$v});
214          }          }
215    
         # create Text::Iconv object  
         $self->{iconv} = Text::Iconv->new($code_page,$self->{'encoding'});      ## FIXME remove!  
   
216          my $filter_ref;          my $filter_ref;
217          my $recode_regex;          my $recode_regex;
218          my $recode_map;          my $recode_map;
# Line 243  sub open { Line 240  sub open {
240    
241          my ($db, $size) = $self->{open_db}->( $self,          my ($db, $size) = $self->{open_db}->( $self,
242                  path => $arg->{path},                  path => $arg->{path},
243                  filter => sub {  #               filter => sub {
244                                  my ($l,$f_nr) = @_;  #                       my ($l,$f_nr) = @_;
245                                  return unless defined($l);  #                       return unless defined($l);
246    #                       from_to($l, $code_page, $self->{'encoding'});
247                                  ## FIXME remove iconv!  #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
248                                  $l = $self->{iconv}->convert($l) if ($self->{iconv});  #                       return $l;
249            #               },
                                 $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);  
   
                                         }  
                                 }  
   
                                 return $l;  
                 },  
250                  %{ $arg },                  %{ $arg },
251          );          );
252    
# Line 316  sub open { Line 286  sub open {
286    
287                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
288    
289                  my $rec = $self->{fetch_rec}->($self, $db, $pos );                  my $rec = $self->{fetch_rec}->($self, $db, $pos, sub {
290                                    my ($l,$f_nr) = @_;
291    #                               return unless defined($l);
292    #                               return $l unless ($rec_regex && $f_nr);
293    
294                                    $log->debug("-=> $f_nr ## $l");
295    
296                                    # codepage conversion and recode_regex
297                                    from_to($l, $code_page, $self->{'encoding'});
298                                    $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
299    
300                                    # apply regexps
301                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
302                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
303                                            my $c = 0;
304                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
305                                                    my $old_l = $l;
306                                                    eval '$l =~ ' . $r;
307                                                    if ($old_l ne $l) {
308                                                            $log->debug("REGEX on $f_nr eval \$l =~ $r\n## old l: [$old_l]\n## new l: [$l]");
309                                                    }
310                                                    $log->error("error applying regex: $r") if ($@);
311                                            }
312                                    }
313    
314                                    $log->debug("<=- $f_nr ## $l");
315                                    return $l;
316                    });
317    
318                  $log->debug(sub { Dumper($rec) });                  $log->debug(sub { Dumper($rec) });
319    
# Line 338  sub open { Line 335  sub open {
335                  # update counters for statistics                  # update counters for statistics
336                  if ($self->{stats}) {                  if ($self->{stats}) {
337    
338                            # fetch clean record with regexpes applied for statistics
339                            my $rec = $self->{fetch_rec}->($self, $db, $pos);
340    
341                          foreach my $fld (keys %{ $rec }) {                          foreach my $fld (keys %{ $rec }) {
342                                  $self->{_stats}->{fld}->{ $fld }++;                                  $self->{_stats}->{fld}->{ $fld }++;
343    
# Line 349  sub open { Line 349  sub open {
349                                          if (ref($row) eq 'HASH') {                                          if (ref($row) eq 'HASH') {
350    
351                                                  foreach my $sf (keys %{ $row }) {                                                  foreach my $sf (keys %{ $row }) {
352                                                            next if ($sf eq 'subfields');
353                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
354                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
355                                                                          if (ref($row->{$sf}) eq 'ARRAY');                                                                          if (ref($row->{$sf}) eq 'ARRAY');
Legend:
Removed from v.613  
changed lines
  Added in v.626
  ViewVC Help
Powered by ViewVC 1.1.26