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.03
  22
  23 =cut
  24
  25 our $VERSION = '0.03';
  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} = \@d;
  95                 } else {
  96                         $v->{$fld} = 1;
  97                 }
  98
  99         }
 100
 101         $log->debug("current validation rules: ", Dumper($v));
 102
 103         $self->{rules} = $v;
 104
 105         $log->info("validation uses rules from $self->{path}");
 106
 107         $self ? return $self : return undef;
 108 }
 109
 110 =head2 validate_errors
 111
 112 Validate record and return errors
 113
 114   my @errors = $validate->validate_errors( $rec );
 115
 116 =cut
 117
 118 sub validate_errors {
 119         my $self = shift;
 120
 121         my $log = $self->_get_logger();
 122
 123         my $rec = shift || $log->logdie("validate_errors need record");
 124
 125         $log->logdie("rec isn't HASH") unless (ref($rec) eq 'HASH');
 126         $log->logdie("can't find validation rules") unless (my $r = $self->{rules});
 127
 128         my @errors;
 129
 130         $log->debug("rec = ", sub { Dumper($rec) }, "keys = ", keys %{ $rec });
 131
 132         my $fields;
 133
 134         foreach my $f (keys %{ $rec }) {
 135
 136                 next if (!defined($f) || $f eq '' || $f eq '000');
 137
 138                 $fields->{$f}++;
 139
 140                 if ( ! defined($r->{$f}) ) {
 141                         push @errors, "field '$f' shouldn't exists";
 142                         next;
 143                 }
 144
 145
 146                 if (ref($rec->{$f}) ne 'ARRAY') {
 147                         push @errors, "field '$f' isn't repetable, probably bug in parsing input data";
 148                         next;
 149                 }
 150
 151                 foreach my $v (@{ $rec->{$f} }) {
 152                         # can we have subfields?
 153                         if (ref($r->{$f}) eq 'ARRAY') {
 154                                 # are values hashes? (has subfields)
 155                                 if (ref($v) ne 'HASH') {
 156                                         push @errors, "$f has value without subfields: $v";
 157                                         next;
 158                                 } else {
 159
 160                                         my $h = dclone( $v );
 161
 162                                         my $sf_repeatable;
 163
 164                                         delete($v->{subfields}) if (defined($v->{subfields}));
 165
 166                                         foreach my $sf (keys %{ $v }) {
 167
 168                                                 # is non-repeatable but with multiple values?
 169                                                 if ( ! first { $_ eq $sf.'*' } @{$r->{$f}} ) {
 170                                                         if ( ref($v->{$sf}) eq 'ARRAY' ) {
 171                                                                 $sf_repeatable->{$sf}++;
 172                                                         };
 173                                                         if (! first { $_ eq $sf } @{ $r->{$f} }) {
 174                                                                 push @errors, "$f has unknown subfield: $sf";
 175                                                         }
 176                                                 }
 177
 178                                         }
 179                                         if (my @r_sf = sort keys( %$sf_repeatable )) {
 180                                                 my $plural = $#r_sf > 0 ? 1 : 0;
 181
 182                                                 push @errors, "$f subfield" .
 183                                                 ( $plural ? 's ' : ' ' ) .
 184                                                 join(', ', @r_sf) .
 185                                                 ( $plural ? ' are ' : ' is ' ) .
 186                                                 'repeatable in: ' .
 187                                                 join('', _pack_subfields_hash( $h, 1) );
 188                                         }
 189                                 }
 190                         } elsif (ref($v) eq 'HASH') {
 191                                 push @errors, "$f has subfields which is not valid";
 192                         }
 193                 }
 194         }
 195
 196         foreach my $must (sort keys %{ $self->{must_exist} }) {
 197                 next if ($fields->{$must});
 198                 push @errors,
 199                         "field $must should exist, but it doesn't";
 200         }
 201
 202         #$log->logcluck("return from this function is ARRAY") unless wantarray;
 203
 204         $log->debug("errors: ", join(", ", @errors)) if (@errors);
 205
 206         return @errors;
 207 }
 208
 209 =head1 AUTHOR
 210
 211 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
 212
 213 =head1 COPYRIGHT & LICENSE
 214
 215 Copyright 2006 Dobrica Pavlinusic, All Rights Reserved.
 216
 217 This program is free software; you can redistribute it and/or modify it
 218 under the same terms as Perl itself.
 219
 220 =cut
 221
 222 1; # End of WebPAC::Validate