File Coverage

blib/lib/HTML/FormHandler/Validate.pm
Criterion Covered Total %
statement 145 154 94.1
branch 103 120 85.8
condition 47 57 82.4
subroutine 13 13 100.0
pod 0 4 0.0
total 308 348 88.5


line stmt bran cond sub pod time code
1             package HTML::FormHandler::Validate;
2             # ABSTRACT: validation role (internal)
3             $HTML::FormHandler::Validate::VERSION = '0.40067';
4              
5 143     143   84372 use Moose::Role;
  143         225  
  143         1067  
6 143     143   504700 use Carp;
  143         228  
  143         138039  
7              
8             has 'required' => ( isa => 'Bool', is => 'rw', default => '0' );
9             has 'required_when' => ( is => 'rw', isa => 'HashRef', predicate => 'has_required_when' );
10             has 'required_message' => (
11             isa => 'ArrayRef|Str',
12             is => 'rw',
13             );
14             has 'unique' => ( isa => 'Bool', is => 'rw', predicate => 'has_unique' );
15             has 'unique_message' => ( isa => 'Str', is => 'rw' );
16             has 'range_start' => ( isa => 'Int|Undef', is => 'rw' );
17             has 'range_end' => ( isa => 'Int|Undef', is => 'rw' );
18              
19             sub test_ranges {
20 935     935 0 922 my $field = shift;
21 935 100 100     6404 return 1 if $field->can('options') || $field->has_errors;
22              
23 733         1608 my $value = $field->value;
24              
25 733 50       1412 return 1 unless defined $value;
26              
27 733         18048 my $low = $field->range_start;
28 733         17603 my $high = $field->range_end;
29              
30 733 100 100     1711 if ( defined $low && defined $high ) {
31             return
32 31 100 100     198 $value >= $low && $value <= $high ? 1 :
33             $field->add_error( $field->get_message('range_incorrect'), $low, $high );
34             }
35              
36 702 100       1190 if ( defined $low ) {
37             return
38 2 100       7 $value >= $low ? 1 :
39             $field->add_error( $field->get_message('range_too_low'), $low );
40             }
41              
42 700 50       1160 if ( defined $high ) {
43             return
44 0 0       0 $value <= $high ? 1 :
45             $field->add_error( $field->get_message('range_too_high'), $high );
46             }
47              
48 700         776 return 1;
49             }
50              
51             sub validate_field {
52 1072     1072 0 1555 my $field = shift;
53              
54 1072 50       27321 return unless $field->has_result;
55 1072         4282 $field->clear_errors; # this is only here for testing convenience
56              
57             # if the 'fields_for_input_without_param' flag is set, and the field doesn't have input,
58             # copy the value to the input.
59 1072 100 66     3143 if ( !$field->has_input && $field->form && $field->form->use_fields_for_input_without_param ) {
      100        
60 12         313 $field->result->_set_input($field->value);
61             }
62             # handle required and required_when processing, and transfer input to value
63 1072         2046 my $continue_validation = 1;
64 1072 100 66     25801 if ( ( $field->required ||
    100 100        
    100 100        
    100          
65             ( $field->has_required_when && $field->match_when($field->required_when) ) ) &&
66             ( !$field->has_input || !$field->input_defined ) ) {
67 32         266 $field->missing(1);
68 32         216 $field->add_error( $field->get_message('required'), $field->loc_label );
69 32 100       102 if( $field->has_input ) {
70 14 50       1122 $field->not_nullable ? $field->_set_value($field->input) : $field->_set_value(undef);
71             }
72 32         58 $continue_validation = 0;
73             }
74             elsif ( $field->DOES('HTML::FormHandler::Field::Repeatable') ) { }
75             elsif ( !$field->has_input ) {
76 57         96 $continue_validation = 0;
77             }
78             elsif ( !$field->input_defined ) {
79 49 100 100     1332 if ( $field->not_nullable ) {
    100          
80 12         40 $field->_set_value($field->input);
81             # handles the case where a compound field value needs to have empty subfields
82 12 100       55 $continue_validation = 0 unless $field->has_flag('is_compound');
83             }
84             elsif ( $field->no_value_if_empty || $field->has_flag('is_contains') ) {
85 3         6 $continue_validation = 0;
86             }
87             else {
88 34         158 $field->_set_value(undef);
89 34         53 $continue_validation = 0;
90             }
91             }
92 1072 50 66     6589 return if ( !$continue_validation && !$field->validate_when_empty );
93              
94             # do building of node
95 935 100       14461 if ( $field->DOES('HTML::FormHandler::Fields') ) {
96 132         9765 $field->_fields_validate;
97             }
98             else {
99 803         29879 my $input = $field->input;
100 803 100       23902 $input = $field->inflate( $input ) if $field->has_inflate_method;
101 803         3144 $field->_set_value( $input );
102             }
103              
104 935         3362 $field->_inner_validate_field();
105 935         2884 $field->_apply_actions;
106 935         2258 $field->validate( $field->value );
107 935         2495 $field->test_ranges;
108 935 50 33     2903 $field->_validate($field) # form field validation method
109             if ( $field->has_value && defined $field->value );
110             # validation done, if everything validated, do deflate_value for
111             # final $form->value
112 935 100 66     28625 if( $field->has_deflate_value_method && !$field->has_errors ) {
113 5         21 $field->_set_value( $field->deflate_value($field->value) );
114             }
115              
116 935         3506 return !$field->has_errors;
117             }
118              
119       257     sub _inner_validate_field { }
120              
121 844     844 0 7224 sub validate { 1 }
122              
123             has 'actions' => (
124             traits => ['Array'],
125             isa => 'ArrayRef',
126             is => 'rw',
127             default => sub { [] },
128             handles => {
129             add_action => 'push',
130             num_actions =>'count',
131             has_actions => 'count',
132             clear_actions => 'clear',
133             }
134             );
135              
136             sub _build_apply_list {
137 1159     1159   1323 my $self = shift;
138 1159         1242 my @apply_list;
139 1159         3863 foreach my $sc ( reverse $self->meta->linearized_isa ) {
140 4932         57446 my $meta = $sc->meta;
141 4932 50       60773 if ( $meta->can('calculate_all_roles') ) {
142 4932         9988 foreach my $role ( $meta->calculate_all_roles ) {
143 9553 50 66     181164 if ( $role->can('apply_list') && $role->has_apply_list ) {
144 0         0 foreach my $apply_def ( @{ $role->apply_list } ) {
  0         0  
145 0         0 my %new_apply = %{$apply_def}; # copy hashref
  0         0  
146 0         0 push @apply_list, \%new_apply;
147             }
148             }
149             }
150             }
151 4932 100 100     205184 if ( $meta->can('apply_list') && $meta->has_apply_list ) {
152 61         77 foreach my $apply_def ( @{ $meta->apply_list } ) {
  61         1645  
153 130         125 my %new_apply = %{$apply_def}; # copy hashref
  130         410  
154 130         261 push @apply_list, \%new_apply;
155             }
156             }
157             }
158 1159         35327 $self->add_action(@apply_list);
159             }
160              
161             sub _apply_actions {
162 935     935   996 my $self = shift;
163              
164 935         780 my $error_message;
165             local $SIG{__WARN__} = sub {
166 6     6   22 my $error = shift;
167 6         8 $error_message = $error;
168 6         44 return 1;
169 935         5791 };
170              
171             my $is_type = sub {
172 1323 100   1323   5806 my $class = blessed shift or return;
173 109   66     372 return $class eq 'MooseX::Types::TypeDecorator' || $class->isa('Type::Tiny');
174 935         2277 };
175              
176 935 50       954 for my $action ( @{ $self->actions || [] } ) {
  935         25069  
177 1230         1164 $error_message = undef;
178             # the first time through value == input
179 1230         2637 my $value = $self->value;
180 1230         1322 my $new_value = $value;
181             # Moose constraints
182 1230 100 100     3687 if ( !ref $action || $is_type->($action) ) {
183 28         103 $action = { type => $action };
184             }
185 1230 100       2519 if ( my $when = $action->{when} ) {
186 6 100       14 next unless $self->match_when($when);
187             }
188 1227 100       6006 if ( exists $action->{type} ) {
    100          
    100          
    100          
    50          
189 101         98 my $tobj;
190 101 100       125 if ( $is_type->($action->{type}) ) {
191 89         178 $tobj = $action->{type};
192             }
193             else {
194 12         20 my $type = $action->{type};
195 12 50       52 $tobj = Moose::Util::TypeConstraints::find_type_constraint($type) or
196             die "Cannot find type constraint $type";
197             }
198 101 100 100     1741 if ( $tobj->has_coercion && $tobj->validate($value) ) {
199 18         4853 eval { $new_value = $tobj->coerce($value) };
  18         85  
200 18 100       1813 if ($@) {
201 1 50       1398 if ( $tobj->has_message ) {
202 1         27 $error_message = $tobj->message->($value);
203             }
204             else {
205 0         0 $error_message = $@;
206             }
207             }
208             else {
209 17         55 $self->_set_value($new_value);
210             }
211              
212             }
213 101   100     26021 $error_message ||= $tobj->validate($new_value);
214             }
215             # now maybe: http://search.cpan.org/~rgarcia/perl-5.10.0/pod/perlsyn.pod#Smart_matching_in_detail
216             # actions in a hashref
217             elsif ( ref $action->{check} eq 'CODE' ) {
218 81 100       238 if ( !$action->{check}->($value, $self) ) {
219 13         75 $error_message = $self->get_message('wrong_value');
220             }
221             }
222             elsif ( ref $action->{check} eq 'Regexp' ) {
223 6 100       24 if ( $value !~ $action->{check} ) {
224 5         22 $error_message = [$self->get_message('no_match'), $value];
225             }
226             }
227             elsif ( ref $action->{check} eq 'ARRAY' ) {
228 17 100       19 if ( !grep { $value eq $_ } @{ $action->{check} } ) {
  5         13  
  17         67  
229 16         81 $error_message = [$self->get_message('not_allowed'), $value];
230             }
231             }
232             elsif ( ref $action->{transform} eq 'CODE' ) {
233 1022         1188 $new_value = eval {
234 143     143   801 no warnings 'all';
  143         260  
  143         55084  
235 1022         2512 $action->{transform}->($value, $self);
236             };
237 1022 100       2923 if ($@) {
238 1   33     6 $error_message = $@ || $self->get_message('error_occurred');
239             }
240             else {
241 1021         2717 $self->_set_value($new_value);
242             }
243             }
244 1227 100       11390 if ( defined $error_message ) {
245 79 100       252 my @message = ref $error_message eq 'ARRAY' ? @$error_message : ($error_message);
246 79 100       182 if ( defined $action->{message} ) {
247 40         63 my $act_msg = $action->{message};
248 40 100       101 if ( ref $act_msg eq 'CODE' ) {
249 17         49 $act_msg = $act_msg->($value, $self, $error_message);
250             }
251 40 100       151 if ( ref $act_msg eq 'ARRAY' ) {
    50          
252 7         8 @message = @{$act_msg};
  7         16  
253             }
254             elsif ( ref \$act_msg eq 'SCALAR' ) {
255 33         57 @message = ($act_msg);
256             }
257             }
258 79         288 $self->add_error(@message);
259             }
260             }
261             }
262              
263             sub match_when {
264 12     12 0 15 my ( $self, $when ) = @_;
265              
266 12         10 my $matched = 0;
267 12         27 foreach my $key ( keys %$when ) {
268 12         13 my $check_against = $when->{$key};
269 12         25 my $from_form = ( $key =~ /^\+/ );
270 12         15 $key =~ s/^\+//;
271 12 100       290 my $field = $from_form ? $self->form->field($key) : $self->parent->subfield( $key );
272 12 50       23 unless ( $field ) {
273 0         0 warn "field '$key' not found processing 'when' for '" . $self->full_name . "'";
274 0         0 next;
275             }
276 12 50       34 my $field_fif = defined $field->fif ? $field->fif : '';
277 12 100       38 if ( ref $check_against eq 'CODE' ) {
    100          
    100          
278 4 100       13 $matched++
279             if $check_against->($field_fif, $self);
280             }
281             elsif ( ref $check_against eq 'ARRAY' ) {
282 2         4 foreach my $value ( @$check_against ) {
283 6 100       13 $matched++ if ( $value eq $field_fif );
284             }
285             }
286             elsif ( $check_against eq $field_fif ) {
287 3         6 $matched++;
288             }
289             else {
290 3         5 $matched = 0;
291 3         20 last;
292             }
293             }
294 12         114 return $matched;
295             }
296              
297 143     143   847 use namespace::autoclean;
  143         498  
  143         1140  
298             1;
299              
300             __END__
301              
302             =pod
303              
304             =encoding UTF-8
305              
306             =head1 NAME
307              
308             HTML::FormHandler::Validate - validation role (internal)
309              
310             =head1 VERSION
311              
312             version 0.40067
313              
314             =head1 SYNOPSIS
315              
316             This is a role that contains validation and transformation code
317             used by L<HTML::FormHandler::Field>.
318              
319             =head1 AUTHOR
320              
321             FormHandler Contributors - see HTML::FormHandler
322              
323             =head1 COPYRIGHT AND LICENSE
324              
325             This software is copyright (c) 2016 by Gerda Shank.
326              
327             This is free software; you can redistribute it and/or modify it under
328             the same terms as the Perl 5 programming language system itself.
329              
330             =cut