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 }
 192
 193 =head2 validate_rec
 194
 195 Validate record and return errors
 196
 197   my @errors = $validate->validate_rec( $rec, $rec_dump );
 198
 199 =cut
 200
 201 sub validate_rec {
 202         my $self = shift;
 203
 204         my $log = $self->_get_logger();
 205
 206         my $rec = shift || $log->logdie("validate_rec need record");
 207         my $rec_dump = shift;
 208
 209         $log->logdie("rec isn't HASH") unless (ref($rec) eq 'HASH');
 210 #       $log->logdie("can't find validation rules") unless (my $r = $self->{rules});
 211         my $r = $self->{rules};
 212
 213         my $errors;
 214
 215         $log->debug("rec = ", sub { dump($rec) }, "keys = ", keys %{ $rec });
 216
 217         my $fields;
 218
 219         foreach my $f (keys %{ $rec }) {
 220
 221                 next if (!defined($f) || $f eq '' || $f eq '000');
 222
 223                 # first check delimiters
 224                 if ( my $regex = $self->{delimiters_regex} ) {
 225
 226                         foreach my $v (@{ $rec->{$f} }) {
 227                                 my $l = _pack_subfields_hash( $v, 1 );
 228                                 my $subfield_dump = $l;
 229                                 my $template = '';
 230                                 $l =~ s/$regex/$template.=$1/eg;
 231                                 #warn "## template: $template\n";
 232
 233                                 if ( $template ) {
 234                                         $self->{_delimiters_templates}->{$f}->{$template}++;
 235
 236                                         if ( my $v = $self->{_validate_delimiters_templates} ) {
 237                                                 if ( ! defined( $v->{$f}->{$template} ) ) {
 238                                                         $errors->{$f}->{potentially_invalid_combination} = $template;
 239                                                         $errors->{$f}->{dump} = $subfield_dump;
 240                                                 #} else {
 241                                                 #       warn "## $f $template ok\n";
 242                                                 }
 243                                         }
 244                                 }
 245                         }
 246                 }
 247
 248                 next unless ( $r );     # skip validation of no rules are specified
 249
 250                 next if (defined( $self->{dont_validate}->{$f} ));
 251
 252                 # track field usage
 253                 $fields->{$f}++;
 254
 255                 if ( ! defined($r->{$f}) ) {
 256                         $errors->{ $f }->{unexpected} = "this field is not expected";
 257                         next;
 258                 }
 259
 260
 261                 if (ref($rec->{$f}) ne 'ARRAY') {
 262                         $errors->{ $f }->{not_repeatable} = "probably bug in parsing input data";
 263                         next;
 264                 }
 265
 266                 foreach my $v (@{ $rec->{$f} }) {
 267                         # can we have subfields?
 268                         if (ref($r->{$f}) eq 'ARRAY') {
 269                                 # are values hashes? (has subfields)
 270                                 if (! defined($v)) {
 271 #                                       $errors->{$f}->{empty} = undef;
 272 #                                       $errors->{dump} = $rec_dump if ($rec_dump);
 273                                 } elsif (ref($v) ne 'HASH') {
 274                                         $errors->{$f}->{missing_subfield} = join(",", @{ $r->{$f} }) . " required";
 275                                         next;
 276                                 } else {
 277
 278                                         my $h = dclone( $v );
 279
 280                                         my $sf_repeatable;
 281
 282                                         delete($v->{subfields}) if (defined($v->{subfields}));
 283
 284                                         my $subfields;
 285
 286                                         foreach my $sf (keys %{ $v }) {
 287
 288                                                 $subfields->{ $sf }++;
 289
 290                                                 # is non-repeatable but with multiple values?
 291                                                 if ( ! first { $_ eq $sf.'*' } @{$r->{$f}} ) {
 292                                                         if ( ref($v->{$sf}) eq 'ARRAY' ) {
 293                                                                 $sf_repeatable->{$sf}++;
 294                                                         };
 295                                                         if (! first { $_ eq $sf } @{ $r->{$f} }) {
 296                                                                 $errors->{ $f }->{subfield}->{extra}->{$sf}++;
 297                                                         }
 298                                                 }
 299
 300                                         }
 301                                         if (my @r_sf = sort keys( %$sf_repeatable )) {
 302
 303                                                 foreach my $sf (@r_sf) {
 304                                                         $errors->{$f}->{subfield}->{extra_repeatable}->{$sf}++;
 305                                                         $errors->{$f}->{dump} = _pack_subfields_hash( $h, 1 );
 306                                                 }
 307
 308                                         }
 309
 310                                         if ( defined( $self->{must_exist_sf}->{$f} ) ) {
 311                                                 foreach my $sf (sort keys %{ $self->{must_exist_sf}->{$f} }) {
 312 #warn "====> $f $sf must exist\n";
 313                                                         $errors->{$f}->{subfield}->{missing}->{$sf}++
 314                                                                 unless defined( $subfields->{$sf} );
 315                                                 }
 316                                         }
 317
 318                                 }
 319                         } elsif (ref($v) eq 'HASH') {
 320                                 $errors->{$f}->{unexpected_subfields}++;
 321                                 $errors->{$f}->{dump} = _pack_subfields_hash( $v, 1 );
 322                         }
 323                 }
 324         }
 325
 326         $log->debug("_delimiters_templates = ", sub { dump( $self->{_delimiters_templates} ) } );
 327
 328         foreach my $must (sort keys %{ $self->{must_exist} }) {
 329                 next if ($fields->{$must});
 330                 $errors->{$must}->{missing}++;
 331                 $errors->{dump} = $rec_dump if ($rec_dump);
 332         }
 333
 334         if ($errors) {
 335                 $log->debug("errors: ", $self->report_error( $errors ) );
 336
 337                 my $mfn = $rec->{'000'}->[0] || $log->logconfess("record ", sub { dump( $rec ) }, " doesn't have MFN");
 338                 $self->{errors}->{$mfn} = $errors;
 339         }
 340
 341         #$log->logcluck("return from this function is ARRAY") unless wantarray;
 342
 343         return $errors;
 344 }
 345
 346 =head2 reset
 347
 348 Clean all accumulated errors for this input and remember delimiter templates
 349 for L<save_delimiters_templates>
 350
 351   $validate->reset;
 352
 353 This function B<must> be called after each input to provide accurate statistics.
 354
 355 =cut
 356
 357 sub reset {
 358         my $self = shift;
 359
 360         my $log = $self->_get_logger;
 361
 362         delete ($self->{errors});
 363
 364         if ( ! $self->{_delimiters_templates} ) {
 365                 $log->debug("called without _delimiters_templates?");
 366                 return;
 367         }
 368
 369         foreach my $f ( keys %{ $self->{_delimiters_templates} } ) {
 370                 foreach my $t ( keys %{ $self->{_delimiters_templates}->{$f} } ) {
 371                         $self->{_accumulated_delimiters_templates}->{$f}->{$t} +=
 372                                 $self->{_delimiters_templates}->{$f}->{$t};
 373                 }
 374         }
 375         $log->debug("_accumulated_delimiters_templates = ", sub { dump( $self->{_accumulated_delimiter_templates} ) } );
 376         delete ($self->{_delimiters_templates});
 377 }
 378
 379 =head2 all_errors
 380
 381 Return hash with all errors
 382
 383   print dump( $validate->all_errors );
 384
 385 =cut
 386
 387 sub all_errors {
 388         my $self = shift;
 389         return $self->{errors};
 390 }
 391
 392 =head2 report_error
 393
 394 Produce nice humanly readable report of single error
 395
 396   print $validate->report_error( $error_hash );
 397
 398 =cut
 399
 400 sub report_error {
 401         my $self = shift;
 402
 403         my $h = shift || die "no hash?";
 404
 405         sub _unroll {
 406                 my ($self, $tree, $accumulated) = @_;
 407
 408                 my $log = $self->_get_logger();
 409
 410                 $log->debug("# ",
 411                         ( $tree                 ? "tree: $tree "                                        : '' ),
 412                         ( $accumulated  ? "accumulated: $accumulated "          : '' ),
 413                 );
 414
 415                 my $results;
 416
 417                 if (ref($tree) ne 'HASH') {
 418                         return ("$accumulated\t($tree)", undef);
 419                 }
 420
 421                 my $dump;
 422
 423                 foreach my $k (sort keys %{ $tree }) {
 424
 425                         if ($k eq 'dump') {
 426                                 $dump = $tree->{dump};
 427                                 #warn "## dump ",dump($dump),"\n";
 428                                 next;
 429                         }
 430
 431                         $log->debug("current: $k");
 432
 433                         my ($new_results, $new_dump) = $self->_unroll($tree->{$k},
 434                                 $accumulated ? "$accumulated\t$k" : $k
 435                         );
 436
 437                         $log->debug( "new_results: ", sub { dump($new_results) } ) if ( $new_results );
 438
 439                         push @$results, $new_results if ($new_results);
 440                         $dump = $new_dump if ($new_dump);
 441
 442                 }
 443
 444                 $log->debug( "results: ", sub { dump($results) } ) if ( $results );
 445
 446                 if ($#$results == 0) {
 447                         return ($results->[0], $dump);
 448                 } else {
 449                         return ($results, $dump);
 450                 }
 451         }
 452
 453
 454         sub _reformat {
 455                 my $l = shift;
 456                 $l =~ s/\t/ /g;
 457                 $l =~ s/_/ /g;
 458                 return $l;
 459         }
 460
 461         my $out = '';
 462
 463         for my $f (sort keys %{ $h }) {
 464                 $out .= "$f: ";
 465
 466                 my ($r, $d) = $self->_unroll( $h->{$f} );
 467                 my $e;
 468                 if (ref($r) eq 'ARRAY') {
 469                         $e .= join(", ", map { _reformat( $_ ) } @$r);
 470                 } else {
 471                         $e .= _reformat( $r );
 472                 }
 473                 $e .= "\n\t$d" if ($d);
 474
 475                 $out .= $e . "\n";
 476         }
 477         return $out;
 478 }
 479
 480
 481 =head2 report
 482
 483 Produce nice humanly readable report of errors
 484
 485   print $validate->report;
 486
 487 =cut
 488
 489 sub report {
 490         my $self = shift;
 491         my $e = $self->{errors} || return;
 492
 493         my $out;
 494         foreach my $mfn (sort { $a <=> $b } keys %$e) {
 495                 $out .= "MFN $mfn\n" . $self->report_error( $e->{$mfn} ) . "\n";
 496         }
 497
 498         return $out;
 499
 500 }
 501
 502 =head2 delimiters_templates
 503
 504 Generate report of delimiter tamplates
 505
 506   my $report = $validate->delimiter_teplates(
 507         report => 1,
 508         current_input => 1,
 509   );
 510
 511 Options:
 512
 513 =over 4
 514
 515 =item report
 516
 517 Generate humanly readable report with single fields
 518
 519 =item current_input
 520
 521 Report just current_input and not accumulated data
 522
 523 =back
 524
 525 =cut
 526
 527 sub delimiters_templates {
 528         my $self = shift;
 529
 530         my $args = {@_};
 531
 532         my $t = $self->{_accumulated_delimiters_templates};
 533         $t = $self->{_delimiters_templates} if ( $args->{current_input} );
 534
 535         my $log = $self->_get_logger;
 536
 537         unless ($t) {
 538                 $log->error("called without delimiters");
 539                 return;
 540         }
 541
 542         my $out;
 543
 544         foreach my $f (sort { $a <=> $b } keys %$t) {
 545                 $out .= "$f\n" if ( $args->{report} );
 546                 foreach my $template (sort { $a cmp $b } keys %{ $t->{$f} }) {
 547                         my $count = $t->{$f}->{$template};
 548                         $out .=
 549                                 ( $count ? "" : "# " ) .
 550                                 ( $args->{report} ? "" : "$f" ) .
 551                                 "\t$count\t$template\n";
 552                 }
 553         }
 554
 555         return $out;
 556 }
 557
 558 =head2 save_delimiters_templates
 559
 560 Save accumulated delimiter templates
 561
 562   $validator->save_delimiters_template( '/path/to/validate/delimiters' );
 563
 564 =cut
 565
 566 sub save_delimiters_templates {
 567         my $self = shift;
 568
 569         my $path = $self->{delimiters_path};
 570
 571         return unless ( $path );
 572
 573         my $log = $self->_get_logger;
 574
 575         if ( ! $self->{_accumulated_delimiters_templates} ) {
 576                 $log->error('no _accumulated_delimiters_templates found, reset');
 577                 $self->reset;
 578         }
 579
 580         if ( ! $self->{_delimiters_templates} ) {
 581                 $log->error('found _delimiters_templates, calling reset');
 582                 $self->reset;
 583         }
 584
 585         $path .= '.new' if ( -e $path );
 586
 587         open(my $d, '>', $path) || $log->fatal("can't open $path: $!");
 588         print $d $self->delimiters_templates;
 589         close($d);
 590
 591         $log->info("new delimiters templates saved to $path");
 592 }
 593
 594 =head1 AUTHOR
 595
 596 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
 597
 598 =head1 COPYRIGHT & LICENSE
 599
 600 Copyright 2006 Dobrica Pavlinusic, All Rights Reserved.
 601
 602 This program is free software; you can redistribute it and/or modify it
 603 under the same terms as Perl itself.
 604
 605 =cut
 606
 607 1; # End of WebPAC::Validate