--- trunk/lib/WebPAC/Validate.pm 2006/05/16 15:23:05 515 +++ trunk/lib/WebPAC/Validate.pm 2006/09/13 17:44:57 677 @@ -8,7 +8,9 @@ use base 'WebPAC::Common'; use File::Slurp; use List::Util qw/first/; -use Data::Dumper; +use Data::Dump qw/dump/; +use WebPAC::Normalize qw/_pack_subfields_hash/; +use Storable qw/dclone/; =head1 NAME @@ -16,11 +18,11 @@ =head1 VERSION -Version 0.01 +Version 0.09 =cut -our $VERSION = '0.01'; +our $VERSION = '0.09'; =head1 SYNOPSIS @@ -32,11 +34,15 @@ # same with 101 101 # field 200 have valid subfields a-g - 200 a b c d e f g + # and field e is repeatable + 200 a b c d e* f g # field 205 can have only subfield a - 205 a + # and must exists + 205! a # while 210 can have a c or d 210 a c d + # field which is ignored in validation + 999- =head1 FUNCTIONS @@ -45,7 +51,7 @@ Create new validation object my $validate = new WebPAC::Validate( - path => '/path/to/input/validate_file', + path => 'conf/validate/file', ); =cut @@ -69,28 +75,45 @@ foreach my $l (split(/[\n\r]+/, $v_file)) { $curr_line++; - # skip comments - next if ($l =~ m/^#/); + + # skip comments and whitespaces + next if ($l =~ /^#/ || $l =~ /^\s*$/); $l =~ s/^\s+//; $l =~ s/\s+$//; my @d = split(/\s+/, $l); - my $fld = shift @d || $log->logdie("need field name in line $curr_line: $l"); + my $fld = shift @d; + + if ($fld =~ s/!$//) { + $self->{must_exist}->{$fld}++; + } elsif ($fld =~ s/-$//) { + $self->{dont_validate}->{$fld}++; + } + + $log->logdie("need field name in line $curr_line: $l") unless (defined($fld)); if (@d) { - $v->{$fld} = \@d; + $v->{$fld} = [ map { + my $sf = $_; + if ( $sf =~ s/!(\*)?$/$1/ ) { + $self->{must_exist_sf}->{ $fld }->{ $sf }++; + }; + $sf; + } @d ]; } else { $v->{$fld} = 1; } } - $log->debug("current validation rules: ", Dumper($v)); + $log->debug("current validation rules: ", dump($v)); $self->{rules} = $v; + $log->info("validation uses rules from $self->{path}"); + $self ? return $self : return undef; } @@ -98,7 +121,7 @@ Validate record and return errors - my @errors = $validate->validate_errors( $rec ); + my @errors = $validate->validate_errors( $rec, $rec_dump ); =cut @@ -108,25 +131,34 @@ my $log = $self->_get_logger(); my $rec = shift || $log->logdie("validate_errors need record"); + my $rec_dump = shift; $log->logdie("rec isn't HASH") unless (ref($rec) eq 'HASH'); $log->logdie("can't find validation rules") unless (my $r = $self->{rules}); - my @errors; + my $errors; + + $log->debug("rec = ", sub { dump($rec) }, "keys = ", keys %{ $rec }); - $log->debug("rec = ", sub { Dumper($rec) }, "keys = ", keys %{ $rec }); + my $fields; foreach my $f (keys %{ $rec }) { - next if (!defined($f) || $f eq ''); + next if (!defined($f) || $f eq '' || $f eq '000'); - if (! defined($r->{$f})) { - push @errors, "field '$f' shouldn't exists"; + next if (defined( $self->{dont_validate}->{$f} )); + + # track field usage + $fields->{$f}++; + + if ( ! defined($r->{$f}) ) { + $errors->{ $f }->{unexpected} = "this field is not expected"; next; } + if (ref($rec->{$f}) ne 'ARRAY') { - push @errors, "field '$f' isn't repetable, probably bug in parsing input data"; + $errors->{ $f }->{not_repeatable} = "probably bug in parsing input data"; next; } @@ -134,28 +166,218 @@ # can we have subfields? if (ref($r->{$f}) eq 'ARRAY') { # are values hashes? (has subfields) - if (ref($v) ne 'HASH') { - push @errors, "$f has value without subfields: $v"; + if (! defined($v)) { +# $errors->{$f}->{empty} = undef; +# $errors->{dump} = $rec_dump if ($rec_dump); + } elsif (ref($v) ne 'HASH') { + $errors->{$f}->{missing_subfield} = join(",", @{ $r->{$f} }) . " required"; next; } else { + + my $h = dclone( $v ); + + my $sf_repeatable; + + delete($v->{subfields}) if (defined($v->{subfields})); + + my $subfields; + foreach my $sf (keys %{ $v }) { - # permited subfield? - if (! first { $_ eq $sf } @{ $r->{$f} }) { - push @errors, "$f has unknown subfield: $sf"; + + $subfields->{ $sf }++; + + # is non-repeatable but with multiple values? + if ( ! first { $_ eq $sf.'*' } @{$r->{$f}} ) { + if ( ref($v->{$sf}) eq 'ARRAY' ) { + $sf_repeatable->{$sf}++; + }; + if (! first { $_ eq $sf } @{ $r->{$f} }) { + $errors->{ $f }->{subfield}->{extra}->{$sf}++; + } + } + + } + if (my @r_sf = sort keys( %$sf_repeatable )) { + + foreach my $sf (@r_sf) { + $errors->{$f}->{subfield}->{extra_repeatable}->{$sf}++; + $errors->{$f}->{dump} = _pack_subfields_hash( $h, 1 ); + } + + } + + if ( defined( $self->{must_exist_sf}->{$f} ) ) { + foreach my $sf (sort keys %{ $self->{must_exist_sf}->{$f} }) { +#warn "====> $f $sf must exist\n"; + $errors->{$f}->{subfield}->{missing}->{$sf}++ + unless defined( $subfields->{$sf} ); } } + } } elsif (ref($v) eq 'HASH') { - push @errors, "$f has subfields which is not valid"; + $errors->{$f}->{unexpected_subfields}++; + $errors->{$f}->{dump} = _pack_subfields_hash( $v, 1 ); } } } + foreach my $must (sort keys %{ $self->{must_exist} }) { + next if ($fields->{$must}); + $errors->{$must}->{missing}++; + $errors->{dump} = $rec_dump if ($rec_dump); + } + + if ($errors) { + $log->debug("errors: ", $self->report_error( $errors ) ); + + my $mfn = $rec->{'000'}->[0] || $log->logconfess("record ", dump( $rec ), " doesn't have MFN"); + $self->{errors}->{$mfn} = $errors; + } + #$log->logcluck("return from this function is ARRAY") unless wantarray; - $log->debug("errors: ", join(", ", @errors)) if (@errors); + return $errors; +} + +=head2 reset_errors + +Clean all accumulated errors for this input + + $validate->reset_errors; + +=cut + +sub reset_errors { + my $self = shift; + delete ($self->{errors}); +} + +=head2 all_errors + +Return hash with all errors + + print dump( $validate->all_errors ); + +=cut + +sub all_errors { + my $self = shift; + return $self->{errors}; +} + +=head2 report_error + +Produce nice humanly readable report of single error + + print $validate->report_error( $error_hash ); + +=cut + +sub report_error { + my $self = shift; + + my $h = shift || die "no hash?"; + + sub _unroll { + my ($self, $tree, $accumulated) = @_; + + my $log = $self->_get_logger(); + + $log->debug("# ", + ( $tree ? "tree: $tree " : '' ), + ( $accumulated ? "accumulated: $accumulated " : '' ), + ); + + my $results; + + if (ref($tree) ne 'HASH') { + return ("$accumulated\t($tree)", undef); + } + + my $dump; + + foreach my $k (sort keys %{ $tree }) { + + if ($k eq 'dump') { + $dump = $tree->{dump}; +# warn "## dump: ",dump($dump),"\n"; + next; + } + + $log->debug("current: $k"); + + my ($new_results, $new_dump) = $self->_unroll($tree->{$k}, + $accumulated ? "$accumulated\t$k" : $k + ); + + $log->debug( + ( $new_results ? "new_results: " . dump($new_results) ." " : '' ), + ); + + push @$results, $new_results if ($new_results); + $dump = $new_dump if ($new_dump); + + } + + $log->debug( + ( $results ? "results: " . dump($results) ." " : '' ), + ); + + if ($#$results == 0) { + return ($results->[0], $dump); + } else { + return ($results, $dump); + } + } + + + sub _reformat { + my $l = shift; + $l =~ s/\t/ /g; + $l =~ s/_/ /; + return $l; + } + + my $out = ''; + + for my $f (sort keys %{ $h }) { + $out .= "$f: "; + + my ($r, $d) = $self->_unroll( $h->{$f} ); + my $e; + if (ref($r) eq 'ARRAY') { + $e .= join(", ", map { _reformat( $_ ) } @$r); + } else { + $e .= _reformat( $r ); + } + $e .= "\n\t$d" if ($d); + + $out .= $e . "\n"; + } + return $out; +} + + +=head2 report + +Produce nice humanly readable report of errors + + print $validate->report; + +=cut + +sub report { + my $self = shift; + my $e = $self->{errors} || return; + + my $out; + foreach my $mfn (sort { $a <=> $b } keys %$e) { + $out .= "MFN $mfn\n" . $self->report_error( $e->{$mfn} ) . "\n"; + } + + return $out; - return @errors; } =head1 AUTHOR