/[webpac2]/trunk/lib/WebPAC/Validate.pm

This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!

Diff of /trunk/lib/WebPAC/Validate.pm

Parent Directory | Revision Log | View Patch Patch

-revision 515 by dpavlin,
Tue May 16 15:23:05 2006 UTC
+revision 665 by dpavlin,
Mon Sep 11 11:57:30 2006 UTC
 Line 8 
 use blib;
  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
-Line 16 
 WebPAC::Validate - provide simple valida
+Line 18 
 WebPAC::Validate - provide simple valida
  =head1 VERSION
- Version 0.01
+ Version 0.07
  =cut
- our $VERSION = '0.01';
+ our $VERSION = '0.07';
  =head1 SYNOPSIS
-Line 32 
 configuration file in following format:
+Line 34 
 configuration file in following format:
    # same with 101
    # field 200 have valid subfields a-g
-a b c d e f g
+   # and field e is repeatable
+a b c d e* f g
    # field 205 can have only subfield a
-a
+   # and must exists
+! a
    # while 210 can have a c or d
 a c d
-Line 45 
 configuration file in following format:
+Line 49 
 configuration file in following format:
  Create new validation object
    my $validate = new WebPAC::Validate(
-         path => '/path/to/input/validate_file',
+         path => 'conf/validate/file',
    );
  =cut
-Line 69 
 sub new {
+Line 73 
 sub new {
          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}++;
+                 }
+                 $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;
  }
-Line 98 
 sub new {
+Line 117 
 sub new {
  Validate record and return errors
-   my @errors = $validate->validate_errors( $rec );
+   my @errors = $validate->validate_errors( $rec, $rec_dump );
  =cut
-Line 108 
 sub validate_errors {
+Line 127 
 sub validate_errors {
          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 { Dumper($rec) }, "keys = ", keys %{ $rec });
+         $log->debug("rec = ", sub { dump($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');
+                 $fields->{$f}++;
-                 if (! defined($r->{$f})) {
+                 if ( ! defined($r->{$f}) ) {
-                         push @errors, "field '$f' shouldn't exists";
+                         $errors->{field}->{ $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->{field}->{ $f }->{not_repeatable} = "probably bug in parsing input data";
                          next;
                  }
-Line 134 
 sub validate_errors {
+Line 159 
 sub validate_errors {
                          # can we have subfields?
                          if (ref($r->{$f}) eq 'ARRAY') {
                                  # are values hashes? (has subfields)
-                                 if (ref($v) ne 'HASH') {
+                                 if (! defined($v)) {
-                                         push @errors, "$f has value without subfields: $v";
+ #                                       $errors->{field}->{$f}->{empty} = undef;
+ #                                       $errors->{dump} = $rec_dump if ($rec_dump);
+                                 } elsif (ref($v) ne 'HASH') {
+                                         $errors->{field}->{$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} }) {
+                                                 $subfields->{ $sf }++;
-                                                         push @errors, "$f has unknown subfield: $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->{field}->{ $f }->{subfield}->{extra}->{$sf}++;
+                                                         }
                                                  }
+                                         }
+                                         if (my @r_sf = sort keys( %$sf_repeatable )) {
+                                                 foreach my $sf (@r_sf) {
+                                                         $errors->{field}->{$f}->{subfield}->{extra_repeatable}->{$sf}++;
+                                                         $errors->{field}->{$f}->{dump} =
+                                                                 join('', _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->{field}->{$f}->{subfield}->{missing}->{$sf}++
+                                                                 unless defined( $subfields->{$sf} );
+                                                 }
+                                         }
                                  }
                          } elsif (ref($v) eq 'HASH') {
-                                 push @errors, "$f has subfields which is not valid";
+                                 $errors->{field}->{$f}->{unexpected_subfields}++;
+                                 $errors->{field}->{$f}->{dump} =
+                                         join('', _pack_subfields_hash( $v, 1 ) );
                          }
                  }
          }
+         foreach my $must (sort keys %{ $self->{must_exist} }) {
+                 next if ($fields->{$must});
+                 $errors->{field}->{$must}->{missing}++;
+                 $errors->{dump} = $rec_dump if ($rec_dump);
+         }
+         if ($errors) {
+                 $log->debug("errors: ", sub { dump( $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
+ Produce nice humanly readable report of errors
+   print $validate->report;
+ =cut
+ sub report {
+         my $self = shift;
+         my $log = $self->_get_logger();
+         sub unroll {
+                 my ($tree, $accumulated) = @_;
+                 $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\n";
+                                 next;
+                         }
+                         $log->debug("current: $k");
+                         my ($new_results, $new_dump) = 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);
+                 }
+         }
+         my $out = '';
+         my $e = $self->{errors} || return;
+         foreach my $mfn (sort keys %$e) {
+                 my ($r, $d) = unroll( $e->{$mfn} );
+                 $out .= "MFN $mfn\n", dump($r), "\t$d\n\n";
+         }
-         return @errors;
+         return $out;
  }
  =head1 AUTHOR

 Legend:



Removed from v.515
 


changed lines


 
Added in v.665
 Legend:



Removed from v.515
 


changed lines


 
Added in v.665
-Removed from v.515
+Added in v.665

	ViewVC Help
Powered by ViewVC 1.1.26