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 |
|
|
254 |
|
|
255 |
## FIXME remove this warning when we are sure that none of API is calling |
## FIXME remove this warning when we are sure that none of API is calling |
256 |
## this wrongly |
## this wrongly |
257 |
#warn "filter called without field number" unless ($f_nr); |
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); |
|
|
|
|
|
} |
|
|
} |
|
258 |
|
|
259 |
return $l; |
return $l; |
260 |
}, |
}, |
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 |
|
|
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 |
|
|
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'); |