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         delimiters_path => 'conf/validate/delimiters/file',
  57   );
  58
  59 Optional parametar C<delimiters> will turn on validating of delimiters. Be
  60 careful here, those delimiters are just stuck into regex, so they can
  61 contain L<perlre> regexpes.
  62
  63 =cut
  64
  65 sub new {
  66         my $class = shift;
  67         my $self = {@_};
  68         bless($self, $class);
  69
  70         my $log = $self->_get_logger();
  71
  72         $log->logdie("need path or delimiters_path") unless ( $self->{path} || $self->{delimiters_path} );
  73
  74         if ( $self->{path} ) {
  75
  76                 my $v_file = read_file( $self->{path} ) ||
  77                         $log->logdie("can't open validate path $self->{path}: $!");
  78
  79                 my $v;
  80                 my $curr_line = 1;
  81
  82                 foreach my $l (split(/[\n\r]+/, $v_file)) {
  83                         $curr_line++;
  84
  85                         # skip comments and whitespaces
  86                         next if ($l =~ /^#/ || $l =~ /^\s*$/);
  87
  88                         $l =~ s/^\s+//;
  89                         $l =~ s/\s+$//;
  90
  91                         my @d = split(/\s+/, $l);
  92
  93                         my $fld = shift @d;
  94
  95                         if ($fld =~ s/!$//) {
  96                                 $self->{must_exist}->{$fld}++;
  97                         } elsif ($fld =~ s/-$//) {
  98                                 $self->{dont_validate}->{$fld}++;
  99                         }
 100
 101                         $log->logdie("need field name in line $curr_line: $l") unless (defined($fld));
 102
 103                         if (@d) {
 104                                 $v->{$fld} = [ map {
 105                                         my $sf = $_;
 106                                         if ( $sf =~ s/!(\*)?$/$1/ ) {
 107                                                 $self->{must_exist_sf}->{ $fld }->{ $sf }++;
 108                                         };
 109                                         $sf;
 110                                 } @d ];
 111                         } else {
 112                                 $v->{$fld} = 1;
 113                         }
 114
 115                 }
 116
 117                 $log->debug("current validation rules: ", dump($v));
 118
 119                 $self->{rules} = $v;
 120
 121                 $log->info("validation uses rules from $self->{path}");
 122         }
 123
 124         if ( $self->{delimiters} ) {
 125                 $self->{delimiters_regex} = '(\^[a-z0-9]|' . join('|', @{ $self->{delimiters} }) . ')';
 126                 $log->info("validation check delimiters with regex $self->{delimiters_regex}");
 127         }
 128
 129         if ( my $path = $self->{delimiters_path} ) {
 130                 if ( -e $path ) {
 131                         $log->info("using delimiter validation rules from $path");
 132                         open(my $d, $path) || $log->fatal("can't open $path: $!");
 133                         while(<$d>) {
 134                                 chomp($d);
 135                                 if (/^\s*(#*)\s*(\d+)\t+(\d+)\t+(.*)$/) {
 136                                         my ($comment,$field,$count,$template) = ($1,$2,$3,$4);
 137                                         $self->{_validate_delimiters_templates}->{$field}->{$template} = $count unless ($comment);
 138                                 } else {
 139                                         warn "## ignored $d\n";
 140                                 }
 141                         }
 142                         close($d);
 143                         warn "_validate_delimiters_templates = ",dump( $self->{_validate_delimiters_templates} );
 144                 } else {
 145                         $log->warn("delimiters path $path doesn't exist, it will be created after this run");
 146                 }
 147         }
 148
 149         $self ? return $self : return undef;
 150 }
 151
 152 =head2 validate_rec
 153
 154 Validate record and return errors
 155
 156   my @errors = $validate->validate_rec( $rec, $rec_dump );
 157
 158 =cut
 159
 160 sub validate_rec {
 161         my $self = shift;
 162
 163         my $log = $self->_get_logger();
 164
 165         my $rec = shift || $log->logdie("validate_rec need record");
 166         my $rec_dump = shift;
 167
 168         $log->logdie("rec isn't HASH") unless (ref($rec) eq 'HASH');
 169 #       $log->logdie("can't find validation rules") unless (my $r = $self->{rules});
 170         my $r = $self->{rules};
 171
 172         my $errors;
 173
 174         $log->debug("rec = ", sub { dump($rec) }, "keys = ", keys %{ $rec });
 175
 176         my $fields;
 177
 178         foreach my $f (keys %{ $rec }) {
 179
 180                 next if (!defined($f) || $f eq '' || $f eq '000');
 181
 182                 # first check delimiters
 183                 if ( my $regex = $self->{delimiters_regex} ) {
 184
 185                         foreach my $v (@{ $rec->{$f} }) {
 186                                 my $l = _pack_subfields_hash( $v, 1 );
 187                                 my $subfield_dump = $l;
 188                                 my $template = '';
 189                                 $l =~ s/$regex/$template.=$1/eg;
 190                                 #warn "## template: $template\n";
 191
 192                                 if ( $template ) {
 193                                         $self->{_delimiters_templates}->{$f}->{$template}++;
 194
 195                                         if ( my $v = $self->{_validate_delimiters_templates} ) {
 196                                                 if ( ! defined( $v->{$f}->{$template} ) ) {
 197                                                         $errors->{$f}->{invalid_delimiters_combination} = $template;
 198                                                         $errors->{$f}->{dump} = $subfield_dump;
 199                                                 #} else {
 200                                                 #       warn "## $f $template ok\n";
 201                                                 }
 202                                         }
 203                                 }
 204                         }
 205                 }
 206
 207                 next unless ( $r );     # skip validation of no rules are specified
 208
 209                 next if (defined( $self->{dont_validate}->{$f} ));
 210
 211                 # track field usage
 212                 $fields->{$f}++;
 213
 214                 if ( ! defined($r->{$f}) ) {
 215                         $errors->{ $f }->{unexpected} = "this field is not expected";
 216                         next;
 217                 }
 218
 219
 220                 if (ref($rec->{$f}) ne 'ARRAY') {
 221                         $errors->{ $f }->{not_repeatable} = "probably bug in parsing input data";
 222                         next;
 223                 }
 224
 225                 foreach my $v (@{ $rec->{$f} }) {
 226                         # can we have subfields?
 227                         if (ref($r->{$f}) eq 'ARRAY') {
 228                                 # are values hashes? (has subfields)
 229                                 if (! defined($v)) {
 230 #                                       $errors->{$f}->{empty} = undef;
 231 #                                       $errors->{dump} = $rec_dump if ($rec_dump);
 232                                 } elsif (ref($v) ne 'HASH') {
 233                                         $errors->{$f}->{missing_subfield} = join(",", @{ $r->{$f} }) . " required";
 234                                         next;
 235                                 } else {
 236
 237                                         my $h = dclone( $v );
 238
 239                                         my $sf_repeatable;
 240
 241                                         delete($v->{subfields}) if (defined($v->{subfields}));
 242
 243                                         my $subfields;
 244
 245                                         foreach my $sf (keys %{ $v }) {
 246
 247                                                 $subfields->{ $sf }++;
 248
 249                                                 # is non-repeatable but with multiple values?
 250                                                 if ( ! first { $_ eq $sf.'*' } @{$r->{$f}} ) {
 251                                                         if ( ref($v->{$sf}) eq 'ARRAY' ) {
 252                                                                 $sf_repeatable->{$sf}++;
 253                                                         };
 254                                                         if (! first { $_ eq $sf } @{ $r->{$f} }) {
 255                                                                 $errors->{ $f }->{subfield}->{extra}->{$sf}++;
 256                                                         }
 257                                                 }
 258
 259                                         }
 260                                         if (my @r_sf = sort keys( %$sf_repeatable )) {
 261
 262                                                 foreach my $sf (@r_sf) {
 263                                                         $errors->{$f}->{subfield}->{extra_repeatable}->{$sf}++;
 264                                                         $errors->{$f}->{dump} = _pack_subfields_hash( $h, 1 );
 265                                                 }
 266
 267                                         }
 268
 269                                         if ( defined( $self->{must_exist_sf}->{$f} ) ) {
 270                                                 foreach my $sf (sort keys %{ $self->{must_exist_sf}->{$f} }) {
 271 #warn "====> $f $sf must exist\n";
 272                                                         $errors->{$f}->{subfield}->{missing}->{$sf}++
 273                                                                 unless defined( $subfields->{$sf} );
 274                                                 }
 275                                         }
 276
 277                                 }
 278                         } elsif (ref($v) eq 'HASH') {
 279                                 $errors->{$f}->{unexpected_subfields}++;
 280                                 $errors->{$f}->{dump} = _pack_subfields_hash( $v, 1 );
 281                         }
 282                 }
 283         }
 284
 285         $log->debug("_delimiters_templates = ", dump( $self->{_delimiters_templates} ) );
 286
 287         foreach my $must (sort keys %{ $self->{must_exist} }) {
 288                 next if ($fields->{$must});
 289                 $errors->{$must}->{missing}++;
 290                 $errors->{dump} = $rec_dump if ($rec_dump);
 291         }
 292
 293         if ($errors) {
 294                 $log->debug("errors: ", $self->report_error( $errors ) );
 295
 296                 my $mfn = $rec->{'000'}->[0] || $log->logconfess("record ", dump( $rec ), " doesn't have MFN");
 297                 $self->{errors}->{$mfn} = $errors;
 298         }
 299
 300         #$log->logcluck("return from this function is ARRAY") unless wantarray;
 301
 302         return $errors;
 303 }
 304
 305 =head2 reset_errors
 306
 307 Clean all accumulated errors for this input
 308
 309   $validate->reset_errors;
 310
 311 =cut
 312
 313 sub reset_errors {
 314         my $self = shift;
 315         delete ($self->{errors});
 316 }
 317
 318 =head2 all_errors
 319
 320 Return hash with all errors
 321
 322   print dump( $validate->all_errors );
 323
 324 =cut
 325
 326 sub all_errors {
 327         my $self = shift;
 328         return $self->{errors};
 329 }
 330
 331 =head2 report_error
 332
 333 Produce nice humanly readable report of single error
 334
 335   print $validate->report_error( $error_hash );
 336
 337 =cut
 338
 339 sub report_error {
 340         my $self = shift;
 341
 342         my $h = shift || die "no hash?";
 343
 344         sub _unroll {
 345                 my ($self, $tree, $accumulated) = @_;
 346
 347                 my $log = $self->_get_logger();
 348
 349                 $log->debug("# ",
 350                         ( $tree                 ? "tree: $tree "                                        : '' ),
 351                         ( $accumulated  ? "accumulated: $accumulated "          : '' ),
 352                 );
 353
 354                 my $results;
 355
 356                 if (ref($tree) ne 'HASH') {
 357                         return ("$accumulated\t($tree)", undef);
 358                 }
 359
 360                 my $dump;
 361
 362                 foreach my $k (sort keys %{ $tree }) {
 363
 364                         if ($k eq 'dump') {
 365                                 $dump = $tree->{dump};
 366                                 #warn "## dump ",dump($dump),"\n";
 367                                 next;
 368                         }
 369
 370                         $log->debug("current: $k");
 371
 372                         my ($new_results, $new_dump) = $self->_unroll($tree->{$k},
 373                                 $accumulated ? "$accumulated\t$k" : $k
 374                         );
 375
 376                         $log->debug(
 377                                 ( $new_results          ? "new_results: " . dump($new_results) ." "     : '' ),
 378                         );
 379
 380                         push @$results, $new_results if ($new_results);
 381                         $dump = $new_dump if ($new_dump);
 382
 383                 }
 384
 385                 $log->debug(
 386                         ( $results              ? "results: " . dump($results) ." "     : '' ),
 387                 );
 388
 389                 if ($#$results == 0) {
 390                         return ($results->[0], $dump);
 391                 } else {
 392                         return ($results, $dump);
 393                 }
 394         }
 395
 396
 397         sub _reformat {
 398                 my $l = shift;
 399                 $l =~ s/\t/ /g;
 400                 $l =~ s/_/ /g;
 401                 return $l;
 402         }
 403
 404         my $out = '';
 405
 406         for my $f (sort keys %{ $h }) {
 407                 $out .= "$f: ";
 408
 409                 my ($r, $d) = $self->_unroll( $h->{$f} );
 410                 my $e;
 411                 if (ref($r) eq 'ARRAY') {
 412                         $e .= join(", ", map { _reformat( $_ ) } @$r);
 413                 } else {
 414                         $e .= _reformat( $r );
 415                 }
 416                 $e .= "\n\t$d" if ($d);
 417
 418                 $out .= $e . "\n";
 419         }
 420         return $out;
 421 }
 422
 423
 424 =head2 report
 425
 426 Produce nice humanly readable report of errors
 427
 428   print $validate->report;
 429
 430 =cut
 431
 432 sub report {
 433         my $self = shift;
 434         my $e = $self->{errors} || return;
 435
 436         my $out;
 437         foreach my $mfn (sort { $a <=> $b } keys %$e) {
 438                 $out .= "MFN $mfn\n" . $self->report_error( $e->{$mfn} ) . "\n";
 439         }
 440
 441         return $out;
 442
 443 }
 444
 445 =head2 delimiters_templates
 446
 447 Generate report of delimiter tamplates
 448
 449   my $report = $validate->delimiter_teplates(
 450         report => 1,
 451   );
 452
 453 Options:
 454
 455 =over 4
 456
 457 =item report
 458
 459 Generate humanly readable report with single fields
 460
 461 =back
 462
 463 =cut
 464
 465 sub delimiters_templates {
 466         my $self = shift;
 467
 468         my $args = {@_};
 469
 470         my $t = $self->{_delimiters_templates};
 471
 472         my $log = $self->_get_logger;
 473
 474         unless ($t) {
 475                 $log->error("called without delimiters");
 476                 return;
 477         }
 478
 479         my $out;
 480
 481         foreach my $f (sort { $a <=> $b } keys %$t) {
 482                 $out .= "$f\n" if ( $args->{report} );
 483                 foreach my $template (sort { $a cmp $b } keys %{ $t->{$f} }) {
 484                         my $count = $t->{$f}->{$template};
 485                         $out .=
 486                                 ( $count ? "" : "# " ) .
 487                                 ( $args->{report} ? "" : "$f" ) .
 488                                 "\t$count\t$template\n";
 489                 }
 490         }
 491
 492         return $out;
 493 }
 494
 495 =head2 save_delimiters_templates
 496
 497 =cut
 498
 499 sub save_delimiters_templates {
 500         my $self = shift;
 501
 502         my $path = $self->{delimiters_path};
 503
 504         return unless ( $path );
 505
 506         my $log = $self->_get_logger;
 507
 508         open(my $d, '>', $path) || $log->fatal("can't open $path: $!");
 509         print $d $self->delimiters_templates;
 510         close($d);
 511
 512         $log->info("new delimiters templates saved to $path");
 513 }
 514
 515 =head1 AUTHOR
 516
 517 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
 518
 519 =head1 COPYRIGHT & LICENSE
 520
 521 Copyright 2006 Dobrica Pavlinusic, All Rights Reserved.
 522
 523 This program is free software; you can redistribute it and/or modify it
 524 under the same terms as Perl itself.
 525
 526 =cut
 527
 528 1; # End of WebPAC::Validate