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
  13 =head1 NAME
  14
  15 WebPAC::Validate - provide simple validation for records
  16
  17 =head1 VERSION
  18
  19 Version 0.01
  20
  21 =cut
  22
  23 our $VERSION = '0.01';
  24
  25 =head1 SYNOPSIS
  26
  27 This module provide a simple way to validate your file against a simple
  28 configuration file in following format:
  29
  30   # field 10 doesn't have any subfields
  31   10
  32   # same with 101
  33   101
  34   # field 200 have valid subfields a-g
  35   200 a b c d e f g
  36   # field 205 can have only subfield a
  37   205 a
  38   # while 210 can have a c or d
  39   210 a c d
  40
  41 =head1 FUNCTIONS
  42
  43 =head2 new
  44
  45 Create new validation object
  46
  47   my $validate = new WebPAC::Validate(
  48         path => '/path/to/input/validate_file',
  49   );
  50
  51 =cut
  52
  53 sub new {
  54         my $class = shift;
  55         my $self = {@_};
  56         bless($self, $class);
  57
  58         my $log = $self->_get_logger();
  59
  60         foreach my $p (qw/path/) {
  61                 $log->logconfess("need $p") unless ($self->{$p});
  62         }
  63
  64         my $v_file = read_file( $self->{path} ) ||
  65                 $log->logdie("can't open validate path $self->{path}: $!");
  66
  67         my $v;
  68         my $curr_line = 1;
  69
  70         foreach my $l (split(/[\n\r]+/, $v_file)) {
  71                 $curr_line++;
  72
  73                 # skip comments and whitespaces
  74                 next if ($l =~ /^#/ || $l =~ /^\s*$/);
  75
  76                 $l =~ s/^\s+//;
  77                 $l =~ s/\s+$//;
  78
  79                 my @d = split(/\s+/, $l);
  80
  81                 my $fld = shift @d;
  82
  83                 $log->logdie("need field name in line $curr_line: $l") unless (defined($fld));
  84
  85                 if (@d) {
  86                         $v->{$fld} = \@d;
  87                 } else {
  88                         $v->{$fld} = 1;
  89                 }
  90
  91         }
  92
  93         $log->debug("current validation rules: ", Dumper($v));
  94
  95         $self->{rules} = $v;
  96
  97         $log->info("validation uses rules from $self->{path}");
  98
  99         $self ? return $self : return undef;
 100 }
 101
 102 =head2 validate_errors
 103
 104 Validate record and return errors
 105
 106   my @errors = $validate->validate_errors( $rec );
 107
 108 =cut
 109
 110 sub validate_errors {
 111         my $self = shift;
 112
 113         my $log = $self->_get_logger();
 114
 115         my $rec = shift || $log->logdie("validate_errors need record");
 116
 117         $log->logdie("rec isn't HASH") unless (ref($rec) eq 'HASH');
 118         $log->logdie("can't find validation rules") unless (my $r = $self->{rules});
 119
 120         my @errors;
 121
 122         $log->debug("rec = ", sub { Dumper($rec) }, "keys = ", keys %{ $rec });
 123
 124         foreach my $f (keys %{ $rec }) {
 125
 126                 next if (!defined($f) || $f eq '' || $f eq '000');
 127
 128                 if (! defined($r->{$f})) {
 129                         push @errors, "field '$f' shouldn't exists";
 130                         next;
 131                 }
 132
 133                 if (ref($rec->{$f}) ne 'ARRAY') {
 134                         push @errors, "field '$f' isn't repetable, probably bug in parsing input data";
 135                         next;
 136                 }
 137
 138                 foreach my $v (@{ $rec->{$f} }) {
 139                         # can we have subfields?
 140                         if (ref($r->{$f}) eq 'ARRAY') {
 141                                 # are values hashes? (has subfields)
 142                                 if (ref($v) ne 'HASH') {
 143                                         push @errors, "$f has value without subfields: $v";
 144                                         next;
 145                                 } else {
 146                                         foreach my $sf (keys %{ $v }) {
 147                                                 # permited subfield?
 148                                                 if (! first { $_ eq $sf } @{ $r->{$f} }) {
 149                                                         push @errors, "$f has unknown subfield: $sf";
 150                                                 }
 151                                         }
 152                                 }
 153                         } elsif (ref($v) eq 'HASH') {
 154                                 push @errors, "$f has subfields which is not valid";
 155                         }
 156                 }
 157         }
 158
 159         #$log->logcluck("return from this function is ARRAY") unless wantarray;
 160
 161         $log->debug("errors: ", join(", ", @errors)) if (@errors);
 162
 163         return @errors;
 164 }
 165
 166 =head1 AUTHOR
 167
 168 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
 169
 170 =head1 COPYRIGHT & LICENSE
 171
 172 Copyright 2006 Dobrica Pavlinusic, All Rights Reserved.
 173
 174 This program is free software; you can redistribute it and/or modify it
 175 under the same terms as Perl itself.
 176
 177 =cut
 178
 179 1; # End of WebPAC::Validate