--- trunk/lib/WebPAC/Validate.pm 2006/09/07 15:01:45 652 +++ trunk/lib/WebPAC/Validate.pm 2007/05/23 20:03:16 832 @@ -18,11 +18,11 @@ =head1 VERSION -Version 0.06 +Version 0.11 =cut -our $VERSION = '0.06'; +our $VERSION = '0.11'; =head1 SYNOPSIS @@ -41,6 +41,8 @@ 205! a # while 210 can have a c or d 210 a c d + # field which is ignored in validation + 999- =head1 FUNCTIONS @@ -50,8 +52,13 @@ my $validate = new WebPAC::Validate( path => 'conf/validate/file', + delimiters => [ ' : ', ' / ', ' ; ', ' , ' ], ); +Optional parametar C will turn on validating of delimiters. Be +careful here, those delimiters are just stuck into regex, so they can +contain L regexpes. + =cut sub new { @@ -86,6 +93,8 @@ 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)); @@ -110,23 +119,29 @@ $log->info("validation uses rules from $self->{path}"); + if ( $self->{delimiters} ) { + $self->{delimiters_regex} = '(\^[a-z0-9]|' . join('|', @{ $self->{delimiters} }) . ')'; + $log->info("validation check delimiters with regex $self->{delimiters_regex}"); + } + $self ? return $self : return undef; } -=head2 validate_errors +=head2 validate_rec Validate record and return errors - my @errors = $validate->validate_errors( $rec ); + my @errors = $validate->validate_rec( $rec, $rec_dump ); =cut -sub validate_errors { +sub validate_rec { my $self = shift; my $log = $self->_get_logger(); - my $rec = shift || $log->logdie("validate_errors need record"); + my $rec = shift || $log->logdie("validate_rec 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}); @@ -141,16 +156,32 @@ next if (!defined($f) || $f eq '' || $f eq '000'); + # first check delimiters + if ( my $regex = $self->{delimiters_regex} ) { + + foreach my $v (@{ $rec->{$f} }) { + my $l = _pack_subfields_hash( $v, 1 ); + my $template = ''; + $l =~ s/$regex/$template.=$1/eg; +# warn "## template: $template\n"; + $self->{_delimiters_templates}->{$f}->{$template}++ if ( $template ); + } + + } + + next if (defined( $self->{dont_validate}->{$f} )); + + # track field usage $fields->{$f}++; if ( ! defined($r->{$f}) ) { - $errors->{field}->{ $f }->{extra} = "not expected"; + $errors->{ $f }->{unexpected} = "this field is not expected"; next; } if (ref($rec->{$f}) ne 'ARRAY') { - $errors->{field}->{ $f }->{not_repeatable} = "probably bug in parsing input data"; + $errors->{ $f }->{not_repeatable} = "probably bug in parsing input data"; next; } @@ -159,10 +190,10 @@ if (ref($r->{$f}) eq 'ARRAY') { # are values hashes? (has subfields) if (! defined($v)) { - $errors->{field}->{$f}->{empty} = undef; - $errors->{dump}->{record}++; +# $errors->{$f}->{empty} = undef; +# $errors->{dump} = $rec_dump if ($rec_dump); } elsif (ref($v) ne 'HASH') { - $errors->{field}->{$f}->{missing_subfield} = "value without subfields: $v"; + $errors->{$f}->{missing_subfield} = join(",", @{ $r->{$f} }) . " required"; next; } else { @@ -184,7 +215,7 @@ $sf_repeatable->{$sf}++; }; if (! first { $_ eq $sf } @{ $r->{$f} }) { - $errors->{field}->{ $f }->{subfield}->{$sf} = "unknown"; + $errors->{ $f }->{subfield}->{extra}->{$sf}++; } } @@ -192,9 +223,8 @@ if (my @r_sf = sort keys( %$sf_repeatable )) { foreach my $sf (@r_sf) { - $errors->{field}->{$f}->{subfield}->{$sf} = "repeatable"; - $errors->{dump}->{field}->{$f} = - join('', _pack_subfields_hash( $h, 1 ) ); + $errors->{$f}->{subfield}->{extra_repeatable}->{$sf}++; + $errors->{$f}->{dump} = _pack_subfields_hash( $h, 1 ); } } @@ -202,30 +232,31 @@ if ( defined( $self->{must_exist_sf}->{$f} ) ) { foreach my $sf (sort keys %{ $self->{must_exist_sf}->{$f} }) { #warn "====> $f $sf must exist\n"; - $errors->{field}->{$f}->{subfield}->{$sf} = "missing" + $errors->{$f}->{subfield}->{missing}->{$sf}++ unless defined( $subfields->{$sf} ); } } } } elsif (ref($v) eq 'HASH') { - $errors->{field}->{$f}->{unexpected_subfields}++; - $errors->{dump}->{field}->{$f} = - join('', _pack_subfields_hash( $v, 1 ) ); + $errors->{$f}->{unexpected_subfields}++; + $errors->{$f}->{dump} = _pack_subfields_hash( $v, 1 ); } } } + $log->debug("_delimiters_templates = ", dump( $self->{_delimiters_templates} ) ); + foreach my $must (sort keys %{ $self->{must_exist} }) { next if ($fields->{$must}); - $errors->{field}->{$must}->{missing}++; - $errors->{dump}->{record}++; + $errors->{$must}->{missing}++; + $errors->{dump} = $rec_dump if ($rec_dump); } if ($errors) { - $log->debug("errors: ", sub { dump( $errors ) } ); + $log->debug("errors: ", $self->report_error( $errors ) ); - my $mfn = $rec->{'000'}->[0]; + my $mfn = $rec->{'000'}->[0] || $log->logconfess("record ", dump( $rec ), " doesn't have MFN"); $self->{errors}->{$mfn} = $errors; } @@ -234,6 +265,175 @@ 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; + +} + +=head2 delimiters_templates + + +=cut + +sub delimiters_templates { + my $self = shift; + + my $t = $self->{_delimiters_templates}; + + my $log = $self->_get_logger; + + unless ($t) { + $log->warn("called without delimiters"); + return; + } + + my $out; + + foreach my $f (sort { $a <=> $b } keys %$t) { + $out .= "$f\n"; + foreach my $sft (sort { $a cmp $b } keys %{ $t->{$f} }) { + $out .= "\t" . $t->{$f}->{$sft} . "\t$sft\n"; + } + } + + return $out; +} + =head1 AUTHOR Dobrica Pavlinusic, C<< >>