File Coverage

lib/Data/Validation.pm
Criterion Covered Total %
statement 57 57 100.0
branch 13 14 92.8
condition 13 20 65.0
subroutine 16 16 100.0
pod 2 2 100.0
total 101 109 92.6


line stmt bran cond sub pod time code
1             package Data::Validation;
2              
3 1     1   631 use 5.010001;
  1         2  
4 1     1   4 use namespace::autoclean;
  1         1  
  1         8  
5 1     1   59 use version; our $VERSION = qv( sprintf '0.26.%d', q$Rev: 1 $ =~ /\d+/gmx );
  1         1  
  1         5  
6              
7 1     1   440 use Data::Validation::Constants qw( EXCEPTION_CLASS FALSE HASH NUL SPC );
  1         2  
  1         7  
8 1     1   701 use Data::Validation::Constraints;
  1         2  
  1         32  
9 1     1   392 use Data::Validation::Filters;
  1         2  
  1         24  
10 1     1   5 use Data::Validation::Utils qw( throw );
  1         2  
  1         3  
11 1     1   142 use List::Util qw( first );
  1         2  
  1         63  
12 1     1   5 use Try::Tiny;
  1         1  
  1         47  
13 1     1   4 use Unexpected::Functions qw( FieldComparison ValidationErrors );
  1         1  
  1         9  
14 1     1   240 use Unexpected::Types qw( HashRef NonZeroPositiveInt );
  1         2  
  1         4  
15 1     1   393 use Moo;
  1         1  
  1         4  
16              
17             has 'constraints' => is => 'ro', isa => HashRef, default => sub { {} };
18              
19             has 'fields' => is => 'ro', isa => HashRef, default => sub { {} };
20              
21             has 'filters' => is => 'ro', isa => HashRef, default => sub { {} };
22              
23             has 'level' => is => 'ro', isa => NonZeroPositiveInt, default => 1;
24              
25             # Private functions
26             my $_comparisons = sub {
27             return { 'eq' => sub { $_[ 0 ] eq $_[ 1 ] },
28             '==' => sub { $_[ 0 ] == $_[ 1 ] },
29             'ne' => sub { $_[ 0 ] ne $_[ 1 ] },
30             '!=' => sub { $_[ 0 ] != $_[ 1 ] },
31             '>' => sub { $_[ 0 ] > $_[ 1 ] },
32             '>=' => sub { $_[ 0 ] >= $_[ 1 ] },
33             '<' => sub { $_[ 0 ] < $_[ 1 ] },
34             '<=' => sub { $_[ 0 ] <= $_[ 1 ] }, };
35             };
36              
37             my $_get_methods = sub {
38             return split SPC, $_[ 0 ] // NUL;
39             };
40              
41             my $_should_compare = sub {
42             return first { $_ eq 'compare' } $_get_methods->( $_[ 0 ]->{validate} );
43             };
44              
45             # Private methods
46             my $_filter = sub {
47             my ($self, $filters, $id, $v) = @_;
48              
49             for my $method ($_get_methods->( $filters )) {
50             my $attr = { %{ $self->filters->{ $id } // {} }, method => $method, };
51             my $dvf_obj = Data::Validation::Filters->new_from_method( $attr );
52              
53             $v = $dvf_obj->filter( $v );
54             }
55              
56             return $v;
57             };
58              
59             my $_compare_fields = sub {
60             my ($self, $prefix, $form, $lhs_name) = @_;
61              
62             my $id = $prefix.$lhs_name;
63             my $constraint = $self->constraints->{ $id } // {};
64             my $rhs_name = $constraint->{other_field}
65             or throw 'Constraint [_1] has no comparison field', [ $id ];
66             my $op = $constraint->{operator} // 'eq';
67             my $compare = $_comparisons->()->{ $op }
68             or throw 'Constraint [_1] unknown comparison operator [_2]', [ $id, $op ];
69             my $lhs = $form->{ $lhs_name } // NUL;
70             my $rhs = $form->{ $rhs_name } // NUL;
71              
72             $compare->( $lhs, $rhs ) and return;
73              
74             $lhs_name = $self->fields->{ $prefix.$lhs_name }->{label} // $lhs_name;
75             $rhs_name = $self->fields->{ $prefix.$rhs_name }->{label} // $rhs_name;
76             throw FieldComparison, [ $lhs_name, $op, $rhs_name ], level => $self->level;
77             };
78              
79             my $_validate = sub {
80             my ($self, $valids, $id, $v) = @_;
81              
82             $valids !~ m{ isMandatory }mx and (not defined $v or not length $v)
83             and return;
84              
85             my $label = $self->fields->{ $id }->{label} // $id;
86              
87             for my $methods (grep { $_ ne 'compare' } $_get_methods->( $valids )) {
88             my @fails;
89              
90             for my $method (split m{ [|] }mx, $methods) {
91             my $constraint = Data::Validation::Constraints->new_from_method
92             ( { %{ $self->constraints->{ $id } // {} }, method => $method, } );
93             (my $class = $method) =~ s{ \A is }{}mx;
94              
95             if ($constraint->validate( $v )) { @fails = (); last }
96              
97             push @fails, $class;
98             }
99              
100             @fails == 1 and throw sub { $fails[ 0 ] }, [ $label ],
101             level => $self->level;
102             @fails > 1 and throw 'Field [_1] is none of [_2]',
103             [ $label, join ' | ', @fails ],
104             level => $self->level;
105             }
106              
107             return;
108             };
109              
110             # Public methods
111             sub check_form { # Validate all fields on a form by repeated calling check_field
112 6   100 6 1 5200 my ($self, $prefix, $form) = @_; my @errors = (); $prefix ||= NUL;
  6         10  
  6         15  
113              
114 6 100 66     34 ($form and ref $form eq HASH) or throw 'Form parameter not a hash ref';
115              
116 5         3 for my $name (sort keys %{ $form }) {
  5         29  
117 30         291 my $id = $prefix.$name; my $conf = $self->fields->{ $id };
  30         61  
118              
119 30 50 33     140 ($conf and ($conf->{filters} or $conf->{validate})) or next;
      33        
120              
121             try {
122 30     30   642 $form->{ $name } = $self->check_field( $id, $form->{ $name } );
123 29 100       50 $_should_compare->( $conf )
124             and $self->$_compare_fields( $prefix, $form, $name );
125             }
126 30     3   136 catch { push @errors, $_ };
  3         3221  
127             }
128              
129 5 100       54 @errors and throw ValidationErrors, \@errors, level => 2;
130              
131 2         5 return $form;
132             }
133              
134             sub check_field { # Validate a single form field value
135 113     113 1 9911 my ($self, $id, $v) = @_; my $conf;
  113         129  
136              
137 113 100 100     916 unless ($id and $conf = $self->fields->{ $id }
      66        
      66        
138             and ($conf->{filters} or $conf->{validate})) {
139 2         7 throw 'Field [_1] validation configuration not found', [ $id, $v ];
140             }
141              
142 111 100       200 $conf->{filters } and $v = $self->$_filter( $conf->{filters }, $id, $v );
143 110 100       285 $conf->{validate} and $self->$_validate( $conf->{validate}, $id, $v );
144              
145 71         140 return $v;
146             }
147              
148             1;
149              
150             __END__