18 |
|
|
19 |
=head1 VERSION |
=head1 VERSION |
20 |
|
|
21 |
Version 0.07 |
Version 0.09 |
22 |
|
|
23 |
=cut |
=cut |
24 |
|
|
25 |
our $VERSION = '0.07'; |
our $VERSION = '0.09'; |
26 |
|
|
27 |
=head1 SYNOPSIS |
=head1 SYNOPSIS |
28 |
|
|
41 |
205! a |
205! a |
42 |
# while 210 can have a c or d |
# while 210 can have a c or d |
43 |
210 a c d |
210 a c d |
44 |
|
# field which is ignored in validation |
45 |
|
999- |
46 |
|
|
47 |
=head1 FUNCTIONS |
=head1 FUNCTIONS |
48 |
|
|
88 |
|
|
89 |
if ($fld =~ s/!$//) { |
if ($fld =~ s/!$//) { |
90 |
$self->{must_exist}->{$fld}++; |
$self->{must_exist}->{$fld}++; |
91 |
|
} elsif ($fld =~ s/-$//) { |
92 |
|
$self->{dont_validate}->{$fld}++; |
93 |
} |
} |
94 |
|
|
95 |
$log->logdie("need field name in line $curr_line: $l") unless (defined($fld)); |
$log->logdie("need field name in line $curr_line: $l") unless (defined($fld)); |
146 |
|
|
147 |
next if (!defined($f) || $f eq '' || $f eq '000'); |
next if (!defined($f) || $f eq '' || $f eq '000'); |
148 |
|
|
149 |
|
next if (defined( $self->{dont_validate}->{$f} )); |
150 |
|
|
151 |
|
# track field usage |
152 |
$fields->{$f}++; |
$fields->{$f}++; |
153 |
|
|
154 |
if ( ! defined($r->{$f}) ) { |
if ( ! defined($r->{$f}) ) { |
201 |
|
|
202 |
foreach my $sf (@r_sf) { |
foreach my $sf (@r_sf) { |
203 |
$errors->{$f}->{subfield}->{extra_repeatable}->{$sf}++; |
$errors->{$f}->{subfield}->{extra_repeatable}->{$sf}++; |
204 |
$errors->{$f}->{dump} = |
$errors->{$f}->{dump} = _pack_subfields_hash( $h, 1 ); |
|
join('', _pack_subfields_hash( $h, 1 ) ); |
|
205 |
} |
} |
206 |
|
|
207 |
} |
} |
217 |
} |
} |
218 |
} elsif (ref($v) eq 'HASH') { |
} elsif (ref($v) eq 'HASH') { |
219 |
$errors->{$f}->{unexpected_subfields}++; |
$errors->{$f}->{unexpected_subfields}++; |
220 |
$errors->{$f}->{dump} = |
$errors->{$f}->{dump} = _pack_subfields_hash( $v, 1 ); |
|
join('', _pack_subfields_hash( $v, 1 ) ); |
|
221 |
} |
} |
222 |
} |
} |
223 |
} |
} |
229 |
} |
} |
230 |
|
|
231 |
if ($errors) { |
if ($errors) { |
232 |
$log->debug("errors: ", sub { dump( $errors ) } ); |
$log->debug("errors: ", $self->report_error( $errors ) ); |
233 |
|
|
234 |
my $mfn = $rec->{'000'}->[0] || $log->logconfess("record ", dump( $rec ), " doesn't have MFN"); |
my $mfn = $rec->{'000'}->[0] || $log->logconfess("record ", dump( $rec ), " doesn't have MFN"); |
235 |
$self->{errors}->{$mfn} = $errors; |
$self->{errors}->{$mfn} = $errors; |
266 |
return $self->{errors}; |
return $self->{errors}; |
267 |
} |
} |
268 |
|
|
269 |
=head2 report |
=head2 report_error |
270 |
|
|
271 |
Produce nice humanly readable report of errors |
Produce nice humanly readable report of single error |
272 |
|
|
273 |
print $validate->report; |
print $validate->report_error( $error_hash ); |
274 |
|
|
275 |
=cut |
=cut |
276 |
|
|
277 |
sub report { |
sub report_error { |
278 |
my $self = shift; |
my $self = shift; |
279 |
|
|
280 |
sub unroll { |
my $h = shift || die "no hash?"; |
281 |
|
|
282 |
|
sub _unroll { |
283 |
my ($self, $tree, $accumulated) = @_; |
my ($self, $tree, $accumulated) = @_; |
284 |
|
|
285 |
my $log = $self->_get_logger(); |
my $log = $self->_get_logger(); |
301 |
|
|
302 |
if ($k eq 'dump') { |
if ($k eq 'dump') { |
303 |
$dump = $tree->{dump}; |
$dump = $tree->{dump}; |
304 |
warn "## dump: ",dump($dump),"\n"; |
# warn "## dump: ",dump($dump),"\n"; |
305 |
next; |
next; |
306 |
} |
} |
307 |
|
|
308 |
$log->debug("current: $k"); |
$log->debug("current: $k"); |
309 |
|
|
310 |
my ($new_results, $new_dump) = $self->unroll($tree->{$k}, |
my ($new_results, $new_dump) = $self->_unroll($tree->{$k}, |
311 |
$accumulated ? "$accumulated\t$k" : $k |
$accumulated ? "$accumulated\t$k" : $k |
312 |
); |
); |
313 |
|
|
331 |
} |
} |
332 |
} |
} |
333 |
|
|
|
my $log = $self->_get_logger(); |
|
|
|
|
|
my $out = ''; |
|
|
my $e = $self->{errors} || return; |
|
334 |
|
|
335 |
sub reformat { |
sub _reformat { |
336 |
my $l = shift; |
my $l = shift; |
337 |
$l =~ s/\t/ /g; |
$l =~ s/\t/ /g; |
338 |
$l =~ s/_/ /; |
$l =~ s/_/ /; |
339 |
return $l; |
return $l; |
340 |
} |
} |
341 |
|
|
342 |
foreach my $mfn (sort keys %$e) { |
my $out = ''; |
|
$out .= "MFN $mfn\n"; |
|
343 |
|
|
344 |
for my $f (sort keys %{ $e->{$mfn} }) { |
for my $f (sort keys %{ $h }) { |
345 |
my ($r, $d) = $self->unroll( $e->{$mfn}->{$f} ); |
$out .= "$f: "; |
346 |
my $e = $f . ': '; |
|
347 |
if (ref($r) eq 'ARRAY') { |
my ($r, $d) = $self->_unroll( $h->{$f} ); |
348 |
$e .= join(", ", map { reformat( $_ ) } @$r); |
my $e; |
349 |
} else { |
if (ref($r) eq 'ARRAY') { |
350 |
$e .= reformat( $r ); |
$e .= join(", ", map { _reformat( $_ ) } @$r); |
351 |
} |
} else { |
352 |
$e .= "\n\t$d" if ($d); |
$e .= _reformat( $r ); |
|
$e .= "\n"; |
|
|
$log->debug("MFN $mfn | $e"); |
|
|
$out .= $e; |
|
353 |
} |
} |
354 |
|
$e .= "\n\t$d" if ($d); |
355 |
|
|
356 |
|
$out .= $e . "\n"; |
357 |
|
} |
358 |
|
return $out; |
359 |
|
} |
360 |
|
|
361 |
|
|
362 |
|
=head2 report |
363 |
|
|
364 |
|
Produce nice humanly readable report of errors |
365 |
|
|
366 |
|
print $validate->report; |
367 |
|
|
368 |
|
=cut |
369 |
|
|
370 |
|
sub report { |
371 |
|
my $self = shift; |
372 |
|
my $e = $self->{errors} || return; |
373 |
|
|
374 |
|
my $out; |
375 |
|
foreach my $mfn (sort { $a <=> $b } keys %$e) { |
376 |
|
$out .= "MFN $mfn\n" . $self->report_error( $e->{$mfn} ) . "\n"; |
377 |
} |
} |
378 |
|
|
379 |
return $out; |
return $out; |
380 |
|
|
381 |
} |
} |
382 |
|
|
383 |
=head1 AUTHOR |
=head1 AUTHOR |