/[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 597 by dpavlin, Thu Jul 13 11:54:33 2006 UTC revision 619 by dpavlin, Fri Aug 25 12:31:06 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.08  Version 0.11
20    
21  =cut  =cut
22    
23  our $VERSION = '0.08';  our $VERSION = '0.11';
24    
25  =head1 SYNOPSIS  =head1 SYNOPSIS
26    
# Line 252  sub open { Line 252  sub open {
252                    
253                                  $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);
254    
255                                  return $l unless ($rec_regex);                                  ## FIXME remove this warning when we are sure that none of API is calling
256                                    ## this wrongly
257                                  # apply regexps                                  warn "filter called without field number" unless ($f_nr);
                                 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});  
                                 }  
258    
259                                  return $l;                                  return $l;
260                  },                  },
# Line 305  sub open { Line 297  sub open {
297    
298                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
299    
300                  my $rec = $self->{fetch_rec}->($self, $db, $pos );                  my $rec = $self->{fetch_rec}->($self, $db, $pos, sub {
301                                    my ($l,$f_nr) = @_;
302                                    return unless defined($l);
303                                    return $l unless ($rec_regex && $f_nr);
304    
305                                    # apply regexps
306                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
307                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
308                                            my $c = 0;
309                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
310                                                    #$log->debug("\$l = $l\neval \$l =~ $r");
311                                                    eval '$l =~ ' . $r;
312                                                    $log->error("error applying regex: $r") if ($@);
313                                            }
314                                    }
315    
316                                    return $l;
317                    });
318    
319                  $log->debug(sub { Dumper($rec) });                  $log->debug(sub { Dumper($rec) });
320    
# Line 327  sub open { Line 336  sub open {
336                  # update counters for statistics                  # update counters for statistics
337                  if ($self->{stats}) {                  if ($self->{stats}) {
338    
339                            # fetch clean record with regexpes applied for statistics
340                            my $rec = $self->{fetch_rec}->($self, $db, $pos);
341    
342                          foreach my $fld (keys %{ $rec }) {                          foreach my $fld (keys %{ $rec }) {
343                                  $self->{_stats}->{fld}->{ $fld }++;                                  $self->{_stats}->{fld}->{ $fld }++;
344    
# Line 338  sub open { Line 350  sub open {
350                                          if (ref($row) eq 'HASH') {                                          if (ref($row) eq 'HASH') {
351    
352                                                  foreach my $sf (keys %{ $row }) {                                                  foreach my $sf (keys %{ $row }) {
353                                                            next if ($sf eq 'subfields');
354                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
355                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
356                                                                          if (ref($row->{$sf}) eq 'ARRAY');                                                                          if (ref($row->{$sf}) eq 'ARRAY');
# Line 522  sub stats { Line 535  sub stats {
535          return $out;          return $out;
536  }  }
537    
538  =head1 modify_record_regexps  =head2 modify_record_regexps
539    
540  Generate hash with regexpes to be applied using L<filter>.  Generate hash with regexpes to be applied using L<filter>.
541    
# Line 604  Dobrica Pavlinusic, C<< <dpavlin@rot13.o Line 617  Dobrica Pavlinusic, C<< <dpavlin@rot13.o
617    
618  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
619    
620  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
621    
622  This program is free software; you can redistribute it and/or modify it  This program is free software; you can redistribute it and/or modify it
623  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.597  
changed lines
  Added in v.619
  ViewVC Help
Powered by ViewVC 1.1.26