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                         foreach my $v (@{ $rec->{$f} }) {
 163                                 my $l = _pack_subfields_hash( $v, 1 );
 164                                 my $subfield_dump = $l;
 165                                 my $template = '';
 166                                 $l =~ s/$regex/$template.=$1/eg;
 167                                 #warn "## template: $template\n";
 168
 169                                 if ( $template ) {
 170                                         $self->{_delimiters_templates}->{$f}->{$template}++;
 171
 172                                         if ( my $v = $self->{_validate_delimiters_templates} ) {
 173                                                 if ( ! defined( $v->{$template} ) ) {
 174                                                         $errors->{$f}->{invalid_delimiters_combination} = $template;
 175                                                         $errors->{$f}->{dump} = $subfield_dump;
 176                                                 } else {
 177                                                         warn "## $f $template ok\n";
 178                                                 }
 179                                         }
 180                                 }
 181                         }
 182                 }
 183
 184                 next if (defined( $self->{dont_validate}->{$f} ));
 185
 186                 # track field usage
 187                 $fields->{$f}++;
 188
 189                 if ( ! defined($r->{$f}) ) {
 190                         $errors->{ $f }->{unexpected} = "this field is not expected";
 191                         next;
 192                 }
 193
 194
 195                 if (ref($rec->{$f}) ne 'ARRAY') {
 196                         $errors->{ $f }->{not_repeatable} = "probably bug in parsing input data";
 197                         next;
 198                 }
 199
 200                 foreach my $v (@{ $rec->{$f} }) {
 201                         # can we have subfields?
 202                         if (ref($r->{$f}) eq 'ARRAY') {
 203                                 # are values hashes? (has subfields)
 204                                 if (! defined($v)) {
 205 #                                       $errors->{$f}->{empty} = undef;
 206 #                                       $errors->{dump} = $rec_dump if ($rec_dump);
 207                                 } elsif (ref($v) ne 'HASH') {
 208                                         $errors->{$f}->{missing_subfield} = join(",", @{ $r->{$f} }) . " required";
 209                                         next;
 210                                 } else {
 211
 212                                         my $h = dclone( $v );
 213
 214                                         my $sf_repeatable;
 215
 216                                         delete($v->{subfields}) if (defined($v->{subfields}));
 217
 218                                         my $subfields;
 219
 220                                         foreach my $sf (keys %{ $v }) {
 221
 222                                                 $subfields->{ $sf }++;
 223
 224                                                 # is non-repeatable but with multiple values?
 225                                                 if ( ! first { $_ eq $sf.'*' } @{$r->{$f}} ) {
 226                                                         if ( ref($v->{$sf}) eq 'ARRAY' ) {
 227                                                                 $sf_repeatable->{$sf}++;
 228                                                         };
 229                                                         if (! first { $_ eq $sf } @{ $r->{$f} }) {
 230                                                                 $errors->{ $f }->{subfield}->{extra}->{$sf}++;
 231                                                         }
 232                                                 }
 233
 234                                         }
 235                                         if (my @r_sf = sort keys( %$sf_repeatable )) {
 236
 237                                                 foreach my $sf (@r_sf) {
 238                                                         $errors->{$f}->{subfield}->{extra_repeatable}->{$sf}++;
 239                                                         $errors->{$f}->{dump} = _pack_subfields_hash( $h, 1 );
 240                                                 }
 241
 242                                         }
 243
 244                                         if ( defined( $self->{must_exist_sf}->{$f} ) ) {
 245                                                 foreach my $sf (sort keys %{ $self->{must_exist_sf}->{$f} }) {
 246 #warn "====> $f $sf must exist\n";
 247                                                         $errors->{$f}->{subfield}->{missing}->{$sf}++
 248                                                                 unless defined( $subfields->{$sf} );
 249                                                 }
 250                                         }
 251
 252                                 }
 253                         } elsif (ref($v) eq 'HASH') {
 254                                 $errors->{$f}->{unexpected_subfields}++;
 255                                 $errors->{$f}->{dump} = _pack_subfields_hash( $v, 1 );
 256                         }
 257                 }
 258         }
 259
 260         $log->debug("_delimiters_templates = ", dump( $self->{_delimiters_templates} ) );
 261
 262         foreach my $must (sort keys %{ $self->{must_exist} }) {
 263                 next if ($fields->{$must});
 264                 $errors->{$must}->{missing}++;
 265                 $errors->{dump} = $rec_dump if ($rec_dump);
 266         }
 267
 268         if ($errors) {
 269                 $log->debug("errors: ", $self->report_error( $errors ) );
 270
 271                 my $mfn = $rec->{'000'}->[0] || $log->logconfess("record ", dump( $rec ), " doesn't have MFN");
 272                 $self->{errors}->{$mfn} = $errors;
 273         }
 274
 275         #$log->logcluck("return from this function is ARRAY") unless wantarray;
 276
 277         return $errors;
 278 }
 279
 280 =head2 reset_errors
 281
 282 Clean all accumulated errors for this input
 283
 284   $validate->reset_errors;
 285
 286 =cut
 287
 288 sub reset_errors {
 289         my $self = shift;
 290         delete ($self->{errors});
 291 }
 292
 293 =head2 all_errors
 294
 295 Return hash with all errors
 296
 297   print dump( $validate->all_errors );
 298
 299 =cut
 300
 301 sub all_errors {
 302         my $self = shift;
 303         return $self->{errors};
 304 }
 305
 306 =head2 report_error
 307
 308 Produce nice humanly readable report of single error
 309
 310   print $validate->report_error( $error_hash );
 311
 312 =cut
 313
 314 sub report_error {
 315         my $self = shift;
 316
 317         my $h = shift || die "no hash?";
 318
 319         sub _unroll {
 320                 my ($self, $tree, $accumulated) = @_;
 321
 322                 my $log = $self->_get_logger();
 323
 324                 $log->debug("# ",
 325                         ( $tree                 ? "tree: $tree "                                        : '' ),
 326                         ( $accumulated  ? "accumulated: $accumulated "          : '' ),
 327                 );
 328
 329                 my $results;
 330
 331                 if (ref($tree) ne 'HASH') {
 332                         return ("$accumulated\t($tree)", undef);
 333                 }
 334
 335                 my $dump;
 336
 337                 foreach my $k (sort keys %{ $tree }) {
 338
 339                         if ($k eq 'dump') {
 340                                 $dump = $tree->{dump};
 341                                 #warn "## dump ",dump($dump),"\n";
 342                                 next;
 343                         }
 344
 345                         $log->debug("current: $k");
 346
 347                         my ($new_results, $new_dump) = $self->_unroll($tree->{$k},
 348                                 $accumulated ? "$accumulated\t$k" : $k
 349                         );
 350
 351                         $log->debug(
 352                                 ( $new_results          ? "new_results: " . dump($new_results) ." "     : '' ),
 353                         );
 354
 355                         push @$results, $new_results if ($new_results);
 356                         $dump = $new_dump if ($new_dump);
 357
 358                 }
 359
 360                 $log->debug(
 361                         ( $results              ? "results: " . dump($results) ." "     : '' ),
 362                 );
 363
 364                 if ($#$results == 0) {
 365                         return ($results->[0], $dump);
 366                 } else {
 367                         return ($results, $dump);
 368                 }
 369         }
 370
 371
 372         sub _reformat {
 373                 my $l = shift;
 374                 $l =~ s/\t/ /g;
 375                 $l =~ s/_/ /g;
 376                 return $l;
 377         }
 378
 379         my $out = '';
 380
 381         for my $f (sort keys %{ $h }) {
 382                 $out .= "$f: ";
 383
 384                 my ($r, $d) = $self->_unroll( $h->{$f} );
 385                 my $e;
 386                 if (ref($r) eq 'ARRAY') {
 387                         $e .= join(", ", map { _reformat( $_ ) } @$r);
 388                 } else {
 389                         $e .= _reformat( $r );
 390                 }
 391                 $e .= "\n\t$d" if ($d);
 392
 393                 $out .= $e . "\n";
 394         }
 395         return $out;
 396 }
 397
 398
 399 =head2 report
 400
 401 Produce nice humanly readable report of errors
 402
 403   print $validate->report;
 404
 405 =cut
 406
 407 sub report {
 408         my $self = shift;
 409         my $e = $self->{errors} || return;
 410
 411         my $out;
 412         foreach my $mfn (sort { $a <=> $b } keys %$e) {
 413                 $out .= "MFN $mfn\n" . $self->report_error( $e->{$mfn} ) . "\n";
 414         }
 415
 416         return $out;
 417
 418 }
 419
 420 =head2 delimiters_templates
 421
 422 Generate report of delimiter tamplates
 423
 424   my $report = $validate->delimiter_teplates(
 425         report => 1,
 426   );
 427
 428 Options:
 429
 430 =over 4
 431
 432 =item report
 433
 434 Generate humanly readable report with single fields
 435
 436 =back
 437
 438 =cut
 439
 440 sub delimiters_templates {
 441         my $self = shift;
 442
 443         my $args = {@_};
 444
 445         my $t = $self->{_delimiters_templates};
 446
 447         my $log = $self->_get_logger;
 448
 449         unless ($t) {
 450                 $log->error("called without delimiters");
 451                 return;
 452         }
 453
 454         my $out;
 455
 456         foreach my $f (sort { $a <=> $b } keys %$t) {
 457                 $out .= "$f\n" if ( $args->{report} );
 458                 foreach my $template (sort { $a cmp $b } keys %{ $t->{$f} }) {
 459                         my $count = $t->{$f}->{$template};
 460                         $out .=
 461                                 ( $count ? "" : "# " ) .
 462                                 ( $args->{report} ? "" : "$f" ) .
 463                                 "\t$count\t$template\n";
 464                 }
 465         }
 466
 467         return $out;
 468 }
 469
 470 =head1 AUTHOR
 471
 472 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
 473
 474 =head1 COPYRIGHT & LICENSE
 475
 476 Copyright 2006 Dobrica Pavlinusic, All Rights Reserved.
 477
 478 This program is free software; you can redistribute it and/or modify it
 479 under the same terms as Perl itself.
 480
 481 =cut
 482
 483 1; # End of WebPAC::Validate