File Coverage

blib/lib/Validation/Class/Directive/Multiples.pm
Criterion Covered Total %
statement 67 67 100.0
branch 18 22 81.8
condition 9 17 52.9
subroutine 9 9 100.0
pod 0 5 0.0
total 103 120 85.8


line stmt bran cond sub pod time code
1             # ABSTRACT: Multiples Directive for Validation Class Field Definitions
2              
3             package Validation::Class::Directive::Multiples;
4              
5 109     109   57369 use strict;
  109         282  
  109         3186  
6 109     109   612 use warnings;
  109         268  
  109         2993  
7              
8 109     109   577 use base 'Validation::Class::Directive';
  109         269  
  109         10553  
9              
10 109     109   771 use Validation::Class::Util;
  109         549  
  109         720  
11              
12             our $VERSION = '7.900059'; # VERSION
13              
14              
15             has 'mixin' => 0;
16             has 'field' => 1;
17             has 'multi' => 0;
18             has 'message' => '%s does not support multiple values';
19             # ensure most core directives execute before this one
20             has 'dependencies' => sub {{
21             normalization => [],
22             validation => [qw(
23             alias
24             between
25             depends_on
26             error
27             errors
28             filtering
29             filters
30             label
31             length
32             matches
33             max_alpha
34             max_digits
35             max_length
36             max_sum
37             min_alpha
38             min_digits
39             min_length
40             min_sum
41             mixin
42             mixin_field
43             name
44             options
45             pattern
46             readonly
47             required
48             toggle
49             )]
50             }};
51              
52             sub after_validation {
53              
54 560     560 0 1225 my $self = shift;
55              
56 560         1319 my ($proto, $field, $param) = @_;
57              
58 560 100 66     2605 if (defined $field->{multiples} && defined $param) {
59              
60 517         1630 $self->after_validation_delete_clones($proto, $field, $param);
61              
62             }
63              
64 560         1646 return $self;
65              
66             }
67              
68             sub after_validation_delete_clones {
69              
70 517     517 0 961 my $self = shift;
71              
72 517         1203 my ($proto, $field, $param) = @_;
73              
74 517         1285 my $name = $field->name;
75              
76             # this will add additional processing overhead which we hate, but is how we
77             # will currently prevent the reaping of strangely named fields that appear
78             # to be clones/clonable but are not in-fact ... so we'll check if the field
79             # is in the clones array
80 8 100       42 return unless grep { defined $_ and $name eq $_ }
81 517 100       1010 @{$proto->stash->{'directive.validation.clones'}}
  517         1510  
82             ;
83              
84 4         35 my ($key, $index) = $name =~ /^(.*)\:(\d+)$/;
85              
86 4 50 33     46 if ($key && defined $index) {
87              
88 4         17 my $value = $proto->params->delete($name);
89              
90 4   100     12 $proto->params->{$key} ||= [];
91              
92 4         14 $proto->params->{$key}->[$index] = $value;
93              
94             # inherit errors from clone
95              
96 4 50 33     16 if ($proto->fields->has($key) && $proto->fields->has($name)) {
97              
98 4         16 $proto->fields->get($key)->errors->add(
99              
100             $proto->fields->get($name)->errors->list
101              
102             );
103              
104             }
105              
106             # remove clone permenantly
107              
108 4         32 $proto->fields->delete($name);
109              
110 4         16 delete $proto->stash->{'directive.validation.clones'}->[$index];
111              
112             }
113              
114 4         12 return $self;
115              
116             }
117              
118             sub before_validation {
119              
120 560     560 0 1187 my $self = shift;
121              
122 560         1615 my ($proto, $field, $param) = @_;
123              
124 560 100 66     2920 if (defined $field->{multiples} && defined $param) {
125              
126 517         1660 $self->before_validation_create_clones($proto, $field, $param);
127              
128             }
129              
130 560         1414 return $self;
131              
132             }
133              
134             sub before_validation_create_clones {
135              
136 517     517 0 1252 my $self = shift;
137              
138 517         1313 my ($proto, $field, $param) = @_;
139              
140             # clone fields to handle parameters with multi-values
141              
142 517 100       1416 if (isa_arrayref($param)) {
143              
144             # is cloning allowed? .. in the U.S it is currently illegal :}
145              
146 3 100       21 return $self->error(@_) if ! $field->{multiples};
147              
148             # clone deterministically
149              
150 2         9 my $name = $field->name;
151              
152 2         7 for (my $i=0; $i < @{$param}; $i++) {
  6         24  
153              
154 4         15 my $clone = "$name:$i";
155              
156 4         12 $proto->params->add($clone => $param->[$i]);
157              
158 4   33     26 my $label = ($field->label || $name);
159 4         25 my $options = {label => "$label #".($i+1), multiples => 0};
160              
161 4         51 $proto->clone_field($name, $clone => $options);
162              
163             # add clones to field list to be validated
164 4         12 push @{$proto->stash->{'validation.fields'}}, $clone
165 4 50       9 if grep { $_ eq $name } @{$proto->stash->{'validation.fields'}}
  6         24  
  4         12  
166             ;
167              
168             # record clones (to be reaped later)
169 4         8 push @{$proto->stash->{'directive.validation.clones'}}, $clone;
  4         11  
170              
171             }
172              
173 2         8 $proto->params->delete($name);
174              
175             # remove the field the clones are based on from the fields list
176 2         4 @{$proto->stash->{'validation.fields'}} =
177 6         15 grep { $_ ne $name } @{$proto->stash->{'validation.fields'}}
  2         17  
178 2 50       4 if @{$proto->stash->{'validation.fields'}}
  2         7  
179             ;
180              
181             }
182              
183 516         1259 return $self;
184              
185             }
186              
187             sub normalize {
188              
189 1009     1009 0 2071 my $self = shift;
190              
191 1009         2355 my ($proto, $field, $param) = @_;
192              
193             # set a default value for the multiples directives
194             # ... the default policy is deny,allow
195              
196 1009 100       3053 $field->{multiples} = 0 if ! defined $field->{multiples};
197              
198 1009         2605 return $self;
199              
200             }
201              
202             1;
203              
204             __END__