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::Dumper;
  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.04
  22
  23 =cut
  24
  25 our $VERSION = '0.04';
  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: ", Dumper($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 );
 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
 131         $log->logdie("rec isn't HASH") unless (ref($rec) eq 'HASH');
 132         $log->logdie("can't find validation rules") unless (my $r = $self->{rules});
 133
 134         my @errors;
 135
 136         $log->debug("rec = ", sub { Dumper($rec) }, "keys = ", keys %{ $rec });
 137
 138         my $fields;
 139
 140         foreach my $f (keys %{ $rec }) {
 141
 142                 next if (!defined($f) || $f eq '' || $f eq '000');
 143
 144                 $fields->{$f}++;
 145
 146                 if ( ! defined($r->{$f}) ) {
 147                         push @errors, "field '$f' shouldn't exists";
 148                         next;
 149                 }
 150
 151
 152                 if (ref($rec->{$f}) ne 'ARRAY') {
 153                         push @errors, "field '$f' isn't repetable, probably bug in parsing input data";
 154                         next;
 155                 }
 156
 157                 foreach my $v (@{ $rec->{$f} }) {
 158                         # can we have subfields?
 159                         if (ref($r->{$f}) eq 'ARRAY') {
 160                                 # are values hashes? (has subfields)
 161                                 if (ref($v) ne 'HASH') {
 162                                         push @errors, "$f has value without subfields: $v";
 163                                         next;
 164                                 } else {
 165
 166                                         my $h = dclone( $v );
 167
 168                                         my $sf_repeatable;
 169
 170                                         delete($v->{subfields}) if (defined($v->{subfields}));
 171
 172                                         my $subfields;
 173
 174                                         foreach my $sf (keys %{ $v }) {
 175
 176                                                 $subfields->{ $sf }++;
 177
 178                                                 # is non-repeatable but with multiple values?
 179                                                 if ( ! first { $_ eq $sf.'*' } @{$r->{$f}} ) {
 180                                                         if ( ref($v->{$sf}) eq 'ARRAY' ) {
 181                                                                 $sf_repeatable->{$sf}++;
 182                                                         };
 183                                                         if (! first { $_ eq $sf } @{ $r->{$f} }) {
 184                                                                 push @errors, "$f has unknown subfield: $sf";
 185                                                         }
 186                                                 }
 187
 188                                         }
 189                                         if (my @r_sf = sort keys( %$sf_repeatable )) {
 190                                                 my $plural = $#r_sf > 0 ? 1 : 0;
 191
 192                                                 push @errors, "$f subfield" .
 193                                                 ( $plural ? 's ' : ' ' ) .
 194                                                 join(', ', @r_sf) .
 195                                                 ( $plural ? ' are ' : ' is ' ) .
 196                                                 'repeatable in: ' .
 197                                                 join('', _pack_subfields_hash( $h, 1) );
 198                                         }
 199
 200                                         if ( defined( $self->{must_exist_sf}->{$f} ) ) {
 201                                                 foreach my $sf (sort keys %{ $self->{must_exist_sf}->{$f} }) {
 202 #warn "====> $f $sf must exist\n";
 203                                                         push @errors, "$f missing required subfield $sf"
 204                                                                 unless (
 205                                                                         defined( $subfields->{$sf} )
 206                                                                 )
 207                                                 }
 208                                         }
 209
 210                                 }
 211                         } elsif (ref($v) eq 'HASH') {
 212                                 push @errors, "$f has subfields which is not valid";
 213                         }
 214                 }
 215         }
 216
 217         foreach my $must (sort keys %{ $self->{must_exist} }) {
 218                 next if ($fields->{$must});
 219                 push @errors,
 220                         "field $must should exist, but it doesn't";
 221         }
 222
 223         #$log->logcluck("return from this function is ARRAY") unless wantarray;
 224
 225         $log->debug("errors: ", join(", ", @errors)) if (@errors);
 226
 227         return @errors;
 228 }
 229
 230 =head1 AUTHOR
 231
 232 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
 233
 234 =head1 COPYRIGHT & LICENSE
 235
 236 Copyright 2006 Dobrica Pavlinusic, All Rights Reserved.
 237
 238 This program is free software; you can redistribute it and/or modify it
 239 under the same terms as Perl itself.
 240
 241 =cut
 242
 243 1; # End of WebPAC::Validate