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