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                 # skip comments
  73                 next if ($l =~ m/^#/);
  74
  75                 $l =~ s/^\s+//;
  76                 $l =~ s/\s+$//;
  77
  78                 my @d = split(/\s+/, $l);
  79
  80                 my $fld = shift @d || $log->logdie("need field name in line $curr_line: $l");
  81
  82                 if (@d) {
  83                         $v->{$fld} = \@d;
  84                 } else {
  85                         $v->{$fld} = 1;
  86                 }
  87
  88         }
  89
  90         $log->debug("current validation rules: ", Dumper($v));
  91
  92         $self->{rules} = $v;
  93
  94         $self ? return $self : return undef;
  95 }
  96
  97 =head2 validate_errors
  98
  99 Validate record and return errors
 100
 101   my @errors = $validate->validate_errors( $rec );
 102
 103 =cut
 104
 105 sub validate_errors {
 106         my $self = shift;
 107
 108         my $log = $self->_get_logger();
 109
 110         my $rec = shift || $log->logdie("validate_errors need record");
 111
 112         $log->logdie("rec isn't HASH") unless (ref($rec) eq 'HASH');
 113         $log->logdie("can't find validation rules") unless (my $r = $self->{rules});
 114
 115         my @errors;
 116
 117         $log->debug("rec = ", sub { Dumper($rec) }, "keys = ", keys %{ $rec });
 118
 119         foreach my $f (keys %{ $rec }) {
 120
 121                 next if (!defined($f) || $f eq '');
 122
 123                 if (! defined($r->{$f})) {
 124                         push @errors, "field '$f' shouldn't exists";
 125                         next;
 126                 }
 127
 128                 if (ref($rec->{$f}) ne 'ARRAY') {
 129                         push @errors, "field '$f' isn't repetable, probably bug in parsing input data";
 130                         next;
 131                 }
 132
 133                 foreach my $v (@{ $rec->{$f} }) {
 134                         # can we have subfields?
 135                         if (ref($r->{$f}) eq 'ARRAY') {
 136                                 # are values hashes? (has subfields)
 137                                 if (ref($v) ne 'HASH') {
 138                                         push @errors, "$f has value without subfields: $v";
 139                                         next;
 140                                 } else {
 141                                         foreach my $sf (keys %{ $v }) {
 142                                                 # permited subfield?
 143                                                 if (! first { $_ eq $sf } @{ $r->{$f} }) {
 144                                                         push @errors, "$f has unknown subfield: $sf";
 145                                                 }
 146                                         }
 147                                 }
 148                         } elsif (ref($v) eq 'HASH') {
 149                                 push @errors, "$f has subfields which is not valid";
 150                         }
 151                 }
 152         }
 153
 154         #$log->logcluck("return from this function is ARRAY") unless wantarray;
 155
 156         $log->debug("errors: ", join(", ", @errors)) if (@errors);
 157
 158         return @errors;
 159 }
 160
 161 =head1 AUTHOR
 162
 163 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
 164
 165 =head1 COPYRIGHT & LICENSE
 166
 167 Copyright 2006 Dobrica Pavlinusic, All Rights Reserved.
 168
 169 This program is free software; you can redistribute it and/or modify it
 170 under the same terms as Perl itself.
 171
 172 =cut
 173
 174 1; # End of WebPAC::Validate