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