git.rot13.org Git - webpac2/blob - lib/WebPAC/Validate.pm

   1 package WebPAC::Validate;
   2
   3 use warnings;
   4 use strict;
   5
   6 use blib;
   7
   8 use base 'WebPAC::Common';
   9 use File::Slurp;
  10 use List::Util qw/first/;
  11 use Data::Dump qw/dump/;
  12 use WebPAC::Normalize qw/_pack_subfields_hash/;
  13 use Storable qw/dclone/;
  14
  15 =head1 NAME
  16
  17 WebPAC::Validate - provide simple validation for records
  18
  19 =head1 VERSION
  20
  21 Version 0.11
  22
  23 =cut
  24
  25 our $VERSION = '0.11';
  26
  27 =head1 SYNOPSIS
  28
  29 This module provide a simple way to validate your file against a simple
  30 configuration file in following format:
  31
  32   # field 10 doesn't have any subfields
  33   10
  34   # same with 101
  35   101
  36   # field 200 have valid subfields a-g
  37   # and field e is repeatable
  38   200 a b c d e* f g
  39   # field 205 can have only subfield a
  40   # and must exists
  41   205! a
  42   # while 210 can have a c or d
  43   210 a c d
  44   # field which is ignored in validation
  45   999-
  46
  47 =head1 FUNCTIONS
  48
  49 =head2 new
  50
  51 Create new validation object
  52
  53   my $validate = new WebPAC::Validate(
  54         path => 'conf/validate/file',
  55         delimiters => [ ' : ', ' / ', ' ; ', ' , ' ],
  56   );
  57
  58 Optional parametar C<delimiters> will turn on validating of delimiters. Be
  59 careful here, those delimiters are just stuck into regex, so they can
  60 contain L<perlre> regexpes.
  61
  62 =cut
  63
  64 sub new {
  65         my $class = shift;
  66         my $self = {@_};
  67         bless($self, $class);
  68
  69         my $log = $self->_get_logger();
  70
  71         foreach my $p (qw/path/) {
  72                 $log->logconfess("need $p") unless ($self->{$p});
  73         }
  74
  75         my $v_file = read_file( $self->{path} ) ||
  76                 $log->logdie("can't open validate path $self->{path}: $!");
  77
  78         my $v;
  79         my $curr_line = 1;
  80
  81         foreach my $l (split(/[\n\r]+/, $v_file)) {
  82                 $curr_line++;
  83
  84                 # skip comments and whitespaces
  85                 next if ($l =~ /^#/ || $l =~ /^\s*$/);
  86
  87                 $l =~ s/^\s+//;
  88                 $l =~ s/\s+$//;
  89
  90                 my @d = split(/\s+/, $l);
  91
  92                 my $fld = shift @d;
  93
  94                 if ($fld =~ s/!$//) {
  95                         $self->{must_exist}->{$fld}++;
  96                 } elsif ($fld =~ s/-$//) {
  97                         $self->{dont_validate}->{$fld}++;
  98                 }
  99
 100                 $log->logdie("need field name in line $curr_line: $l") unless (defined($fld));
 101
 102                 if (@d) {
 103                         $v->{$fld} = [ map {
 104                                 my $sf = $_;
 105                                 if ( $sf =~ s/!(\*)?$/$1/ ) {
 106                                         $self->{must_exist_sf}->{ $fld }->{ $sf }++;
 107                                 };
 108                                 $sf;
 109                         } @d ];
 110                 } else {
 111                         $v->{$fld} = 1;
 112                 }
 113
 114         }
 115
 116         $log->debug("current validation rules: ", dump($v));
 117
 118         $self->{rules} = $v;
 119
 120         $log->info("validation uses rules from $self->{path}");
 121
 122         if ( $self->{delimiters} ) {
 123                 $self->{delimiters_regex} = '(\^[a-z0-9]|' . join('|', @{ $self->{delimiters} }) . ')';
 124                 $log->info("validation check delimiters with regex $self->{delimiters_regex}");
 125         }
 126
 127         $self ? return $self : return undef;
 128 }
 129
 130 =head2 validate_rec
 131
 132 Validate record and return errors
 133
 134   my @errors = $validate->validate_rec( $rec, $rec_dump );
 135
 136 =cut
 137
 138 sub validate_rec {
 139         my $self = shift;
 140
 141         my $log = $self->_get_logger();
 142
 143         my $rec = shift || $log->logdie("validate_rec need record");
 144         my $rec_dump = shift;
 145
 146         $log->logdie("rec isn't HASH") unless (ref($rec) eq 'HASH');
 147         $log->logdie("can't find validation rules") unless (my $r = $self->{rules});
 148
 149         my $errors;
 150
 151         $log->debug("rec = ", sub { dump($rec) }, "keys = ", keys %{ $rec });
 152
 153         my $fields;
 154
 155         foreach my $f (keys %{ $rec }) {
 156
 157                 next if (!defined($f) || $f eq '' || $f eq '000');
 158
 159                 # first check delimiters
 160                 if ( my $regex = $self->{delimiters_regex} ) {
 161
 162                         my $template = '';
 163
 164                         foreach my $v (@{ $rec->{$f} }) {
 165                                         warn "## v = ", dump( $v );
 166                                         my $l = _pack_subfields_hash( $v, 1 );
 167                                         warn "## $l [$regex]\n";
 168                                         $l =~ s/$regex/$template.=$1/eg && warn "## new: $l\n";
 169                                         warn "## template: $template\n";
 170                                         $self->{_delimiters_templates}->{$f}->{$template}++;
 171                         }
 172
 173                 }
 174
 175                 next if (defined( $self->{dont_validate}->{$f} ));
 176
 177                 # track field usage
 178                 $fields->{$f}++;
 179
 180                 if ( ! defined($r->{$f}) ) {
 181                         $errors->{ $f }->{unexpected} = "this field is not expected";
 182                         next;
 183                 }
 184
 185
 186                 if (ref($rec->{$f}) ne 'ARRAY') {
 187                         $errors->{ $f }->{not_repeatable} = "probably bug in parsing input data";
 188                         next;
 189                 }
 190
 191                 foreach my $v (@{ $rec->{$f} }) {
 192                         # can we have subfields?
 193                         if (ref($r->{$f}) eq 'ARRAY') {
 194                                 # are values hashes? (has subfields)
 195                                 if (! defined($v)) {
 196 #                                       $errors->{$f}->{empty} = undef;
 197 #                                       $errors->{dump} = $rec_dump if ($rec_dump);
 198                                 } elsif (ref($v) ne 'HASH') {
 199                                         $errors->{$f}->{missing_subfield} = join(",", @{ $r->{$f} }) . " required";
 200                                         next;
 201                                 } else {
 202
 203                                         my $h = dclone( $v );
 204
 205                                         my $sf_repeatable;
 206
 207                                         delete($v->{subfields}) if (defined($v->{subfields}));
 208
 209                                         my $subfields;
 210
 211                                         foreach my $sf (keys %{ $v }) {
 212
 213                                                 $subfields->{ $sf }++;
 214
 215                                                 # is non-repeatable but with multiple values?
 216                                                 if ( ! first { $_ eq $sf.'*' } @{$r->{$f}} ) {
 217                                                         if ( ref($v->{$sf}) eq 'ARRAY' ) {
 218                                                                 $sf_repeatable->{$sf}++;
 219                                                         };
 220                                                         if (! first { $_ eq $sf } @{ $r->{$f} }) {
 221                                                                 $errors->{ $f }->{subfield}->{extra}->{$sf}++;
 222                                                         }
 223                                                 }
 224
 225                                         }
 226                                         if (my @r_sf = sort keys( %$sf_repeatable )) {
 227
 228                                                 foreach my $sf (@r_sf) {
 229                                                         $errors->{$f}->{subfield}->{extra_repeatable}->{$sf}++;
 230                                                         $errors->{$f}->{dump} = _pack_subfields_hash( $h, 1 );
 231                                                 }
 232
 233                                         }
 234
 235                                         if ( defined( $self->{must_exist_sf}->{$f} ) ) {
 236                                                 foreach my $sf (sort keys %{ $self->{must_exist_sf}->{$f} }) {
 237 #warn "====> $f $sf must exist\n";
 238                                                         $errors->{$f}->{subfield}->{missing}->{$sf}++
 239                                                                 unless defined( $subfields->{$sf} );
 240                                                 }
 241                                         }
 242
 243                                 }
 244                         } elsif (ref($v) eq 'HASH') {
 245                                 $errors->{$f}->{unexpected_subfields}++;
 246                                 $errors->{$f}->{dump} = _pack_subfields_hash( $v, 1 );
 247                         }
 248                 }
 249         }
 250
 251         $log->debug("_delimiters_templates = ", dump( $self->{_delimiters_templates} ) );
 252
 253         foreach my $must (sort keys %{ $self->{must_exist} }) {
 254                 next if ($fields->{$must});
 255                 $errors->{$must}->{missing}++;
 256                 $errors->{dump} = $rec_dump if ($rec_dump);
 257         }
 258
 259         if ($errors) {
 260                 $log->debug("errors: ", $self->report_error( $errors ) );
 261
 262                 my $mfn = $rec->{'000'}->[0] || $log->logconfess("record ", dump( $rec ), " doesn't have MFN");
 263                 $self->{errors}->{$mfn} = $errors;
 264         }
 265
 266         #$log->logcluck("return from this function is ARRAY") unless wantarray;
 267
 268         return $errors;
 269 }
 270
 271 =head2 reset_errors
 272
 273 Clean all accumulated errors for this input
 274
 275   $validate->reset_errors;
 276
 277 =cut
 278
 279 sub reset_errors {
 280         my $self = shift;
 281         delete ($self->{errors});
 282 }
 283
 284 =head2 all_errors
 285
 286 Return hash with all errors
 287
 288   print dump( $validate->all_errors );
 289
 290 =cut
 291
 292 sub all_errors {
 293         my $self = shift;
 294         return $self->{errors};
 295 }
 296
 297 =head2 report_error
 298
 299 Produce nice humanly readable report of single error
 300
 301   print $validate->report_error( $error_hash );
 302
 303 =cut
 304
 305 sub report_error {
 306         my $self = shift;
 307
 308         my $h = shift || die "no hash?";
 309
 310         sub _unroll {
 311                 my ($self, $tree, $accumulated) = @_;
 312
 313                 my $log = $self->_get_logger();
 314
 315                 $log->debug("# ",
 316                         ( $tree                 ? "tree: $tree "                                        : '' ),
 317                         ( $accumulated  ? "accumulated: $accumulated "          : '' ),
 318                 );
 319
 320                 my $results;
 321
 322                 if (ref($tree) ne 'HASH') {
 323                         return ("$accumulated\t($tree)", undef);
 324                 }
 325
 326                 my $dump;
 327
 328                 foreach my $k (sort keys %{ $tree }) {
 329
 330                         if ($k eq 'dump') {
 331                                 $dump = $tree->{dump};
 332 #                               warn "## dump: ",dump($dump),"\n";
 333                                 next;
 334                         }
 335
 336                         $log->debug("current: $k");
 337
 338                         my ($new_results, $new_dump) = $self->_unroll($tree->{$k},
 339                                 $accumulated ? "$accumulated\t$k" : $k
 340                         );
 341
 342                         $log->debug(
 343                                 ( $new_results          ? "new_results: " . dump($new_results) ." "     : '' ),
 344                         );
 345
 346                         push @$results, $new_results if ($new_results);
 347                         $dump = $new_dump if ($new_dump);
 348
 349                 }
 350
 351                 $log->debug(
 352                         ( $results              ? "results: " . dump($results) ." "     : '' ),
 353                 );
 354
 355                 if ($#$results == 0) {
 356                         return ($results->[0], $dump);
 357                 } else {
 358                         return ($results, $dump);
 359                 }
 360         }
 361
 362
 363         sub _reformat {
 364                 my $l = shift;
 365                 $l =~ s/\t/ /g;
 366                 $l =~ s/_/ /;
 367                 return $l;
 368         }
 369
 370         my $out = '';
 371
 372         for my $f (sort keys %{ $h }) {
 373                 $out .= "$f: ";
 374
 375                 my ($r, $d) = $self->_unroll( $h->{$f} );
 376                 my $e;
 377                 if (ref($r) eq 'ARRAY') {
 378                         $e .= join(", ", map { _reformat( $_ ) } @$r);
 379                 } else {
 380                         $e .= _reformat( $r );
 381                 }
 382                 $e .= "\n\t$d" if ($d);
 383
 384                 $out .= $e . "\n";
 385         }
 386         return $out;
 387 }
 388
 389
 390 =head2 report
 391
 392 Produce nice humanly readable report of errors
 393
 394   print $validate->report;
 395
 396 =cut
 397
 398 sub report {
 399         my $self = shift;
 400         my $e = $self->{errors} || return;
 401
 402         my $out;
 403         foreach my $mfn (sort { $a <=> $b } keys %$e) {
 404                 $out .= "MFN $mfn\n" . $self->report_error( $e->{$mfn} ) . "\n";
 405         }
 406
 407         return $out;
 408
 409 }
 410
 411 =head1 AUTHOR
 412
 413 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
 414
 415 =head1 COPYRIGHT & LICENSE
 416
 417 Copyright 2006 Dobrica Pavlinusic, All Rights Reserved.
 418
 419 This program is free software; you can redistribute it and/or modify it
 420 under the same terms as Perl itself.
 421
 422 =cut
 423
 424 1; # End of WebPAC::Validate