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.07
  22
  23 =cut
  24
  25 our $VERSION = '0.07';
  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
  45 =head1 FUNCTIONS
  46
  47 =head2 new
  48
  49 Create new validation object
  50
  51   my $validate = new WebPAC::Validate(
  52         path => 'conf/validate/file',
  53   );
  54
  55 =cut
  56
  57 sub new {
  58         my $class = shift;
  59         my $self = {@_};
  60         bless($self, $class);
  61
  62         my $log = $self->_get_logger();
  63
  64         foreach my $p (qw/path/) {
  65                 $log->logconfess("need $p") unless ($self->{$p});
  66         }
  67
  68         my $v_file = read_file( $self->{path} ) ||
  69                 $log->logdie("can't open validate path $self->{path}: $!");
  70
  71         my $v;
  72         my $curr_line = 1;
  73
  74         foreach my $l (split(/[\n\r]+/, $v_file)) {
  75                 $curr_line++;
  76
  77                 # skip comments and whitespaces
  78                 next if ($l =~ /^#/ || $l =~ /^\s*$/);
  79
  80                 $l =~ s/^\s+//;
  81                 $l =~ s/\s+$//;
  82
  83                 my @d = split(/\s+/, $l);
  84
  85                 my $fld = shift @d;
  86
  87                 if ($fld =~ s/!$//) {
  88                         $self->{must_exist}->{$fld}++;
  89                 }
  90
  91                 $log->logdie("need field name in line $curr_line: $l") unless (defined($fld));
  92
  93                 if (@d) {
  94                         $v->{$fld} = [ map {
  95                                 my $sf = $_;
  96                                 if ( $sf =~ s/!(\*)?$/$1/ ) {
  97                                         $self->{must_exist_sf}->{ $fld }->{ $sf }++;
  98                                 };
  99                                 $sf;
 100                         } @d ];
 101                 } else {
 102                         $v->{$fld} = 1;
 103                 }
 104
 105         }
 106
 107         $log->debug("current validation rules: ", dump($v));
 108
 109         $self->{rules} = $v;
 110
 111         $log->info("validation uses rules from $self->{path}");
 112
 113         $self ? return $self : return undef;
 114 }
 115
 116 =head2 validate_errors
 117
 118 Validate record and return errors
 119
 120   my @errors = $validate->validate_errors( $rec, $rec_dump );
 121
 122 =cut
 123
 124 sub validate_errors {
 125         my $self = shift;
 126
 127         my $log = $self->_get_logger();
 128
 129         my $rec = shift || $log->logdie("validate_errors need record");
 130         my $rec_dump = shift;
 131
 132         $log->logdie("rec isn't HASH") unless (ref($rec) eq 'HASH');
 133         $log->logdie("can't find validation rules") unless (my $r = $self->{rules});
 134
 135         my $errors;
 136
 137         $log->debug("rec = ", sub { dump($rec) }, "keys = ", keys %{ $rec });
 138
 139         my $fields;
 140
 141         foreach my $f (keys %{ $rec }) {
 142
 143                 next if (!defined($f) || $f eq '' || $f eq '000');
 144
 145                 $fields->{$f}++;
 146
 147                 if ( ! defined($r->{$f}) ) {
 148                         $errors->{field}->{ $f }->{unexpected} = "this field is not expected";
 149                         next;
 150                 }
 151
 152
 153                 if (ref($rec->{$f}) ne 'ARRAY') {
 154                         $errors->{field}->{ $f }->{not_repeatable} = "probably bug in parsing input data";
 155                         next;
 156                 }
 157
 158                 foreach my $v (@{ $rec->{$f} }) {
 159                         # can we have subfields?
 160                         if (ref($r->{$f}) eq 'ARRAY') {
 161                                 # are values hashes? (has subfields)
 162                                 if (! defined($v)) {
 163 #                                       $errors->{field}->{$f}->{empty} = undef;
 164 #                                       $errors->{dump} = $rec_dump if ($rec_dump);
 165                                 } elsif (ref($v) ne 'HASH') {
 166                                         $errors->{field}->{$f}->{missing_subfield} = join(",", @{ $r->{$f} }) . " required";
 167                                         next;
 168                                 } else {
 169
 170                                         my $h = dclone( $v );
 171
 172                                         my $sf_repeatable;
 173
 174                                         delete($v->{subfields}) if (defined($v->{subfields}));
 175
 176                                         my $subfields;
 177
 178                                         foreach my $sf (keys %{ $v }) {
 179
 180                                                 $subfields->{ $sf }++;
 181
 182                                                 # is non-repeatable but with multiple values?
 183                                                 if ( ! first { $_ eq $sf.'*' } @{$r->{$f}} ) {
 184                                                         if ( ref($v->{$sf}) eq 'ARRAY' ) {
 185                                                                 $sf_repeatable->{$sf}++;
 186                                                         };
 187                                                         if (! first { $_ eq $sf } @{ $r->{$f} }) {
 188                                                                 $errors->{field}->{ $f }->{subfield}->{extra}->{$sf}++;
 189                                                         }
 190                                                 }
 191
 192                                         }
 193                                         if (my @r_sf = sort keys( %$sf_repeatable )) {
 194
 195                                                 foreach my $sf (@r_sf) {
 196                                                         $errors->{field}->{$f}->{subfield}->{extra_repeatable}->{$sf}++;
 197                                                         $errors->{field}->{$f}->{dump} =
 198                                                                 join('', _pack_subfields_hash( $h, 1 ) );
 199                                                 }
 200
 201                                         }
 202
 203                                         if ( defined( $self->{must_exist_sf}->{$f} ) ) {
 204                                                 foreach my $sf (sort keys %{ $self->{must_exist_sf}->{$f} }) {
 205 #warn "====> $f $sf must exist\n";
 206                                                         $errors->{field}->{$f}->{subfield}->{missing}->{$sf}++
 207                                                                 unless defined( $subfields->{$sf} );
 208                                                 }
 209                                         }
 210
 211                                 }
 212                         } elsif (ref($v) eq 'HASH') {
 213                                 $errors->{field}->{$f}->{unexpected_subfields}++;
 214                                 $errors->{field}->{$f}->{dump} =
 215                                         join('', _pack_subfields_hash( $v, 1 ) );
 216                         }
 217                 }
 218         }
 219
 220         foreach my $must (sort keys %{ $self->{must_exist} }) {
 221                 next if ($fields->{$must});
 222                 $errors->{field}->{$must}->{missing}++;
 223                 $errors->{dump} = $rec_dump if ($rec_dump);
 224         }
 225
 226         if ($errors) {
 227                 $log->debug("errors: ", sub { dump( $errors ) } );
 228
 229                 my $mfn = $rec->{'000'}->[0] || $log->logconfess("record ", dump( $rec ), " doesn't have MFN");
 230                 $self->{errors}->{$mfn} = $errors;
 231         }
 232
 233         #$log->logcluck("return from this function is ARRAY") unless wantarray;
 234
 235         return $errors;
 236 }
 237
 238 =head2 reset_errors
 239
 240 Clean all accumulated errors for this input
 241
 242   $validate->reset_errors;
 243
 244 =cut
 245
 246 sub reset_errors {
 247         my $self = shift;
 248         delete ($self->{errors});
 249 }
 250
 251 =head2 all_errors
 252
 253 Return hash with all errors
 254
 255   print dump( $validate->all_errors );
 256
 257 =cut
 258
 259 sub all_errors {
 260         my $self = shift;
 261         return $self->{errors};
 262 }
 263
 264 =head2 report
 265
 266 Produce nice humanly readable report of errors
 267
 268   print $validate->report;
 269
 270 =cut
 271
 272 sub report {
 273         my $self = shift;
 274
 275         sub unroll {
 276                 my ($rest,$o, $dump) = @_;
 277
 278 #warn "# rest: $rest o: $o\n";
 279
 280                 return unless ($rest);
 281
 282                 if (ref($rest) ne 'HASH') {
 283                         $o .= "($rest)";
 284                         return ($o,$dump);
 285                 }
 286
 287                 foreach my $k (sort keys %{ $rest }) {
 288
 289                         if ($k eq 'dump') {
 290                                 $dump = $rest->{dump};
 291                                 warn "## dump: $dump\n";
 292                                 next;
 293                         }
 294                         my $u;
 295                         ($u, $dump) = unroll($rest->{$k}, $o, $dump);
 296                         $o .= "$k $u";
 297
 298
 299                 }
 300                 return ($o,$dump);
 301         }
 302
 303         my $out = '';
 304
 305         foreach my $mfn (sort keys %{ $self->{errors} }) {
 306                 my ($msg,$dump) = unroll( $self->{errors}->{$mfn}, '', '' );
 307                 $out .= "MFN $mfn\n$msg\t$dump\n\n";
 308         }
 309
 310         return $out;
 311 }
 312
 313 =head1 AUTHOR
 314
 315 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
 316
 317 =head1 COPYRIGHT & LICENSE
 318
 319 Copyright 2006 Dobrica Pavlinusic, All Rights Reserved.
 320
 321 This program is free software; you can redistribute it and/or modify it
 322 under the same terms as Perl itself.
 323
 324 =cut
 325
 326 1; # End of WebPAC::Validate