File Coverage

blib/lib/Data/FormValidator/Results.pm
Criterion Covered Total %
statement 472 532 88.7
branch 203 272 74.6
condition 84 112 75.0
subroutine 44 45 97.7
pod 0 20 0.0
total 803 981 81.8


line stmt bran cond sub pod time code
1             #
2             # Results.pm - Object which contains validation result.
3             #
4             # This file is part of FormValidator.
5             #
6             # Author: Francis J. Lacoste
7             # Maintainer: Mark Stosberg
8             #
9             # Copyright (C) 2000 iNsu Innovations Inc.
10             #
11             # This program is free software; you can redistribute it and/or modify
12             # it under the terms same terms as perl itself.
13             #
14 67     67   421 use strict;
  67         165  
  67         2453  
15              
16             package Data::FormValidator::Results;
17 66     66   350 use Carp;
  66         128  
  66         3464  
18 65     65   16050 use Symbol;
  65         37902  
  65         3774  
19 65     65   17482 use Data::FormValidator::Filters ':filters';
  65         177  
  65         12723  
20 64     64   21617 use Data::FormValidator::Constraints qw(:validators :matchers);
  64         177  
  64         398  
21             use overload
22 64         600 'bool' => \&_bool_overload_based_on_success,
23 64     64   52323 fallback => 1;
  64         49761  
24              
25             our $VERSION = 4.88;
26              
27             =pod
28              
29             =head1 NAME
30              
31             Data::FormValidator::Results - results of form input validation.
32              
33             =head1 SYNOPSIS
34              
35             my $results = Data::FormValidator->check(\%input_hash, \%dfv_profile);
36              
37             # Print the name of missing fields
38             if ( $results->has_missing ) {
39             for my $f ( $results->missing ) {
40             print $f, " is missing\n";
41             }
42             }
43              
44             # Print the name of invalid fields
45             if ( $results->has_invalid ) {
46             for my $f ( $results->invalid ) {
47             print $f, " is invalid: ", $results->invalid( $f ), "\n";
48             }
49             }
50              
51             # Print unknown fields
52             if ( $results->has_unknown ) {
53             for my $f ( $results->unknown ) {
54             print $f, " is unknown\n";
55             }
56             }
57              
58             # Print valid fields
59             for my $f ( $results->valid() ) {
60             print $f, " = ", $results->valid( $f ), "\n";
61             }
62              
63             =head1 DESCRIPTION
64              
65             This object is returned by the L C method.
66             It can be queried for information about the validation results.
67              
68             =cut
69              
70             sub new {
71 149     149 0 302 my $proto = shift;
72 149   33     671 my $class = ref $proto || $proto;
73 149         346 my ($profile, $data) = @_;
74              
75 149         341 my $self = bless {}, $class;
76              
77 149         539 $self->_process( $profile, $data );
78              
79 144         506 $self;
80             }
81              
82             sub _process {
83 149     149   329 my ($self, $profile, $data) = @_;
84              
85             # Copy data and assumes that all is valid to start with
86              
87 149         477 my %data = $self->_get_input_as_hash($data);
88 149         444 my %valid = %data;
89 149         284 my @missings = ();
90 149         274 my @unknown = ();
91              
92             # msgs() method will need access to the profile
93 149         310 $self->{profile} = $profile;
94              
95 149         222 my %imported_validators;
96              
97             # import valid_* subs from requested packages
98 149         564 for my $package (_arrayify($profile->{validator_packages})) {
99 13 50       42 if ( !exists $imported_validators{$package} ) {
100 13         67 local $SIG{__DIE__} = \&confess;
101 13         784 eval "require $package";
102 13 50       74 if ($@) {
103 0         0 die "Couldn't load validator package '$package': $@";
104             }
105              
106             # Perl will die with a nice error message if the package can't be found
107             # No need to go through extra effort here. -mls :)
108 13         64 my $package_ref = qualify_to_ref("${package}::");
109             my @subs = grep(/^(valid_|match_|filter_)/,
110 13         185 keys(%{*{$package_ref}}));
  13         20  
  13         281  
111 13         50 for my $sub (@subs) {
112             # is it a sub? (i.e. make sure it's not a scalar, hash, etc.)
113 81         971 my $subref = *{qualify_to_ref("${package}::$sub")}{CODE};
  81         183  
114 81 50       720 if (defined $subref) {
115 81         120 *{qualify_to_ref($sub)} = $subref;
  81         144  
116             }
117             }
118 13         249 $imported_validators{$package} = 1;
119             }
120             }
121              
122             # Apply unconditional filters
123 149         535 for my $filter (_arrayify($profile->{filters})) {
124 7 50       20 if (defined $filter) {
125             # Qualify symbolic references
126 7   100     19 $filter = (ref $filter eq 'CODE' ? $filter : *{qualify_to_ref("filter_$filter")}{CODE}) ||
127             die "No filter found named: '$filter'";
128 6         156 for my $field ( keys %valid ) {
129             # apply filter, modifying %valid by reference, skipping undefined values
130 13         37 _filter_apply(\%valid,$field,$filter);
131             }
132             }
133             }
134              
135             # Apply specific filters
136 148         327 while ( my ($field,$filters) = each %{$profile->{field_filters} }) {
  154         747  
137 7         21 for my $filter ( _arrayify($filters)) {
138 7 50       26 if (defined $filter) {
139             # Qualify symbolic references
140 7   100     28 $filter = (ref $filter eq 'CODE' ? $filter : *{qualify_to_ref("filter_$filter")}{CODE}) ||
141             die "No filter found named '$filter'";
142              
143             # apply filter, modifying %valid by reference
144 6         91 _filter_apply(\%valid,$field,$filter);
145             }
146             }
147             }
148              
149             # add in specific filters from the regexp map
150 147         291 while ( my ($re,$filters) = each %{$profile->{field_filter_regexp_map} }) {
  152         597  
151 6         22 my $sub = _create_sub_from_RE($re);
152              
153 6         16 for my $filter ( _arrayify($filters)) {
154 6 50       25 if (defined $filter) {
155             # Qualify symbolic references
156 6   100     17 $filter = (ref $filter eq 'CODE' ? $filter : *{qualify_to_ref("filter_$filter")}{CODE}) ||
157             die "No filter found named '$filter'";
158              
159 61     61   35706 no strict 'refs';
  61         140  
  61         256987  
160              
161             # find all the keys that match this RE and apply filters to them
162 5         144 for my $field (grep { $sub->($_) } (keys %valid)) {
  18         166  
163             # apply filter, modifying %valid by reference
164 7         19 _filter_apply(\%valid,$field,$filter);
165             }
166             }
167             }
168             }
169              
170             # store the filtered data away for later use
171 146         532 $self->{__FILTERED_DATA} = \%valid;
172              
173 146         403 my %required = map { $_ => 1 } _arrayify($profile->{required});
  230         608  
174 146         472 my %optional = map { $_ => 1 } _arrayify($profile->{optional});
  27         78  
175              
176             # loop through and add fields to %required and %optional based on regular expressions
177 146         546 my $required_re = _create_sub_from_RE($profile->{required_regexp});
178 146         440 my $optional_re = _create_sub_from_RE($profile->{optional_regexp});
179              
180 146         462 for my $k (keys %valid) {
181 312 100 100     706 if ($required_re && $required_re->($k)) {
182 1         2 $required{$k} = 1;
183             }
184              
185 312 100 100     854 if ($optional_re && $optional_re->($k)) {
186 6         12 $optional{$k} = 1;
187             }
188             }
189              
190             # handle "require_some"
191 146         292 while (my ($field, $dependent_require_some) = each %{$profile->{dependent_require_some}}) {
  146         603  
192 0 0       0 if (defined $valid{$field}) {
193 0 0       0 if (ref $dependent_require_some eq "CODE") {
194 0         0 for my $value (_arrayify($valid{$field})) {
195 0         0 my $returned_require_some = $dependent_require_some->($self, $value);
196              
197 0 0       0 if (ref($returned_require_some) eq 'HASH') {
198 0         0 foreach my $key (keys %$returned_require_some) {
199 0         0 $profile->{require_some}->{$key} = $returned_require_some->{$key};
200             }
201             }
202             }
203             } else {
204 0 0       0 if (ref($dependent_require_some) eq 'HASH') {
205 0         0 foreach my $key (keys %$dependent_require_some) {
206 0         0 $profile->{require_some}->{$key} = $dependent_require_some->{$key};
207             }
208             }
209             }
210             }
211             }
212              
213 146         263 my %require_some;
214 146         254 while ( my ( $field, $deps) = each %{$profile->{require_some}} ) {
  149         564  
215 3         7 for my $dep (_arrayify($deps)){
216 11         21 $require_some{$dep} = 1;
217             }
218             }
219              
220              
221             # Remove all empty fields
222 146         358 for my $field (keys %valid) {
223 312 100       653 if (ref $valid{$field}) {
224 56 100       125 if ( ref $valid{$field} eq 'ARRAY' ) {
225 18         38 for (my $i = 0; $i < scalar @{ $valid{$field} }; $i++) {
  56         121  
226 38 100 100     218 $valid{$field}->[$i] = undef unless (defined $valid{$field}->[$i] and length $valid{$field}->[$i] and $valid{$field}->[$i] !~ /^\x00$/);
      66        
227             }
228             # If all fields are empty, we delete it.
229 18 100       28 delete $valid{$field} unless grep { defined $_ } @{$valid{$field}};
  38         101  
  18         42  
230              
231             }
232             }
233             else {
234 256 100 100     3887 delete $valid{$field} unless (defined $valid{$field} and length $valid{$field} and $valid{$field} !~ /^\x00$/);
      66        
235             }
236             }
237              
238             # Check if the presence of some fields makes other optional fields required.
239 146         301 while ( my ( $field, $deps) = each %{$profile->{dependencies}} ) {
  162         649  
240 16 100       46 if (defined $valid{$field}) {
241 12 100       40 if (ref($deps) eq 'HASH') {
    100          
242 7         19 for my $key (keys %$deps) {
243             # Handle case of a key with a single value given as an arrayref
244             # There is probably a better, more general solution to this problem.
245 14         23 my $val_to_compare;
246 14 100 66     38 if ((ref $valid{$field} eq 'ARRAY') and (scalar @{ $valid{$field} } == 1)) {
  2         5  
247 2         4 $val_to_compare = $valid{$field}->[0];
248             }
249             else {
250 12         18 $val_to_compare = $valid{$field}
251             }
252              
253 14 100       33 if($val_to_compare eq $key){
254 7         16 for my $dep (_arrayify($deps->{$key})){
255 14         31 $required{$dep} = 1;
256             }
257             }
258             }
259             }
260             elsif (ref $deps eq "CODE") {
261 4         11 for my $val (_arrayify($valid{$field})) {
262 5         16 my $returned_deps = $deps->($self, $val);
263              
264 5         40 for my $dep (_arrayify($returned_deps)) {
265 2         8 $required{$dep} = 1;
266             }
267             }
268             }
269             else {
270 1         4 for my $dep (_arrayify($deps)){
271 2         10 $required{$dep} = 1;
272             }
273             }
274             }
275             }
276              
277             # check dependency groups
278             # the presence of any member makes them all required
279 146         259 for my $group (values %{ $profile->{dependency_groups} }) {
  146         442  
280 6         18 my $require_all = 0;
281 6         13 for my $field (_arrayify($group)) {
282 12 100       29 $require_all = 1 if $valid{$field};
283             }
284 6 50       14 if ($require_all) {
285 6         15 map { $required{$_} = 1 } _arrayify($group);
  12         30  
286             }
287             }
288              
289 146         280 my $dependency_re;
290              
291 146         226 foreach my $re (keys %{$profile->{dependencies_regexp}}) {
  146         421  
292 0         0 my $sub = _create_sub_from_RE($re);
293              
294             $dependency_re->{$re} = {
295             sub => $sub,
296 0         0 value => $profile->{dependencies_regexp}->{$re},
297             };
298             }
299              
300 146 50       408 if ($dependency_re) {
301 0         0 foreach my $k (keys %valid) {
302 0         0 foreach my $re (keys %$dependency_re) {
303 0 0       0 if ($dependency_re->{$re}->{sub}->($k)) {
304 0         0 my $deps = $dependency_re->{$re}->{value};
305              
306 0 0       0 if (ref($deps) eq 'HASH') {
    0          
307 0         0 for my $key (keys %$deps) {
308             # Handle case of a key with a single value given as an arrayref
309             # There is probably a better, more general solution to this problem.
310 0         0 my $val_to_compare;
311              
312 0 0 0     0 if ((ref $valid{$k} eq 'ARRAY') and (scalar @{ $valid{$k} } == 1)) {
  0         0  
313 0         0 $val_to_compare = $valid{$k}->[0];
314             } else {
315 0         0 $val_to_compare = $valid{$k}
316             }
317              
318 0 0       0 if($val_to_compare eq $key){
319 0         0 for my $dep (_arrayify($deps->{$key})){
320 0         0 $required{$dep} = 1;
321             }
322             }
323             }
324             } elsif (ref $deps eq "CODE") {
325 0         0 for my $val (_arrayify($valid{$k})) {
326 0         0 my $returned_deps = $deps->($self, $val, $k);
327              
328 0         0 for my $dep (_arrayify($returned_deps)) {
329 0         0 $required{$dep} = 1;
330             }
331             }
332             } else {
333 0         0 for my $dep (_arrayify($deps)){
334 0         0 $required{$dep} = 1;
335             }
336             }
337             }
338             }
339             }
340             }
341              
342             # Check if the presence of some fields makes other fields optional.
343 146         283 while (my ($field, $dependent_optional) = each %{$profile->{dependent_optionals}} ) {
  146         557  
344 0 0       0 if (defined $valid{$field}) {
345 0 0       0 if (ref $dependent_optional eq "CODE") {
346 0         0 for my $value (_arrayify($valid{$field})) {
347 0         0 my $returned_optionals = $dependent_optional->($self, $value);
348              
349              
350              
351 0         0 foreach my $optional (_arrayify($returned_optionals)) {
352 0         0 $optional{$optional} = 1;
353             }
354             }
355             } else {
356 0         0 foreach my $optional (_arrayify($dependent_optional)){
357 0         0 $optional{$optional} = 1;
358             }
359             }
360             }
361             }
362              
363             # Find unknown
364             @unknown =
365 146   100     386 grep { not (exists $optional{$_} or exists $required{$_} or exists $require_some{$_} ) } keys %valid;
  306         1433  
366             # and remove them from the list
367 146         350 for my $field ( @unknown ) {
368 58         121 delete $valid{$field};
369             }
370              
371             # Add defaults from defaults_regexp_map
372 146         214 my %private_defaults;
373 146         382 my @all_possible = keys %optional, keys %required, keys %require_some;
374 146         227 while ( my ($re,$value) = each %{$profile->{defaults_regexp_map}} ) {
  147         531  
375             # We only add defaults for known fields.
376 1         2 for (@all_possible) {
377 3 100       24 $private_defaults{$_} = $value if m/$re/;
378             }
379             }
380              
381             # Fill defaults
382             my %combined_defaults = (
383             %private_defaults,
384 146 100       285 %{ $profile->{defaults} || {} }
  146         705  
385             );
386 146         557 while ( my ($field,$value) = each %combined_defaults ) {
387 3 50       10 unless(exists $valid{$field}) {
388 3 100 66     10 if (ref($value) && ref($value) eq "CODE") {
389 1         4 $valid{$field} = $value->($self);
390             } else {
391 2         7 $valid{$field} = $value;
392             }
393             }
394             }
395              
396             # Check for required fields
397 146         373 for my $field ( keys %required ) {
398 261 100       599 push @missings, $field unless exists $valid{$field};
399             }
400              
401             # Check for the absence of require_some fields
402 146         248 while ( my ( $field, $deps) = each %{$profile->{require_some}} ) {
  149         483  
403 3         6 my $enough_required_fields = 0;
404 3         4 my @deps = _arrayify($deps);
405             # num fields to require is first element in array if looks like a digit, 1 otherwise.
406 3 100       13 my $num_fields_to_require = ($deps[0] =~ m/^\d+$/) ? $deps[0] : 1;
407 3         5 for my $dep (@deps){
408 11 100       21 $enough_required_fields++ if exists $valid{$dep};
409             }
410 3 100       8 push @missings, $field unless ($enough_required_fields >= $num_fields_to_require);
411             }
412              
413             # add in the constraints from the regexp maps
414             # We don't want to modify the profile, so we use a new variable.
415 146   100     571 $profile->{constraints} ||= {};
416             my $private_constraints = {
417 146         236 %{ $profile->{constraints} },
  146         584  
418             _add_constraints_from_map($profile,'constraint',\%valid),
419             };
420 146   100     689 $profile->{constraint_methods} ||= {};
421             my $private_constraint_methods = {
422 146         227 %{ $profile->{constraint_methods} },
  146         457  
423             _add_constraints_from_map($profile,'constraint_method',\%valid),
424             };
425              
426             #Decide which fields to untaint
427 146         293 my ($untaint_all, %untaint_hash);
428 146 100 66     1074 if (defined $profile->{untaint_regexp_map} or defined $profile->{untaint_constraint_fields} ) {
    100 66        
429             # first deal with untaint_constraint_fields
430 3 50       10 if (defined($profile->{untaint_constraint_fields})) {
431 3 50       14 if (ref $profile->{untaint_constraint_fields} eq "ARRAY") {
    0          
432 3         9 for my $field (@{$profile->{untaint_constraint_fields}}) {
  3         8  
433 3         10 $untaint_hash{$field} = 1;
434             }
435             }
436             elsif ($valid{$profile->{untaint_constraint_fields}}) {
437 0         0 $untaint_hash{$profile->{untaint_constraint_fields}} = 1;
438             }
439             }
440              
441             # now look at untaint_regexp_map
442 3 50       12 if(defined($profile->{untaint_regexp_map})) {
443 0         0 my @untaint_regexes;
444 0 0       0 if(ref $profile->{untaint_regexp_map} eq "ARRAY") {
445 0         0 @untaint_regexes = @{$profile->{untaint_regexp_map}};
  0         0  
446             }
447             else {
448 0         0 push(@untaint_regexes, $profile->{untaint_regexp_map});
449             }
450              
451 0         0 for my $regex (@untaint_regexes) {
452             # look at both constraints and constraint_methods
453 0         0 for my $field (keys %$private_constraints, keys %$private_constraint_methods) {
454 0 0       0 next if($untaint_hash{$field});
455 0 0       0 $untaint_hash{$field} = 1 if( $field =~ $regex );
456             }
457             }
458             }
459             }
460             elsif ((defined($profile->{untaint_all_constraints}))
461             && ($profile->{untaint_all_constraints} == 1)) {
462 10         23 $untaint_all = 1;
463             }
464              
465 146         641 $self->_check_constraints($private_constraints,\%valid,$untaint_all,\%untaint_hash);
466              
467 144         460 my $force_method_p = 1;
468 144         524 $self->_check_constraints($private_constraint_methods,\%valid,$untaint_all,\%untaint_hash, $force_method_p);
469              
470             # add back in missing optional fields from the data hash if we need to
471 144         411 for my $field ( keys %data ) {
472 306 100 100     829 if ($profile->{missing_optional_valid} and $optional{$field} and (not exists $valid{$field})) {
      100        
473 3         8 $valid{$field} = undef;
474             }
475             }
476              
477             # all invalid fields are removed from valid hash
478 144         286 for my $field (keys %{ $self->{invalid} }) {
  144         510  
479 85         203 delete $valid{$field};
480             }
481              
482 144         276 my ($missing,$invalid);
483              
484 144   50     809 $self->{valid} ||= {};
485 144         309 $self->{valid} = { %valid , %{$self->{valid}} };
  144         420  
486 144         473 $self->{missing} = { map { $_ => 1 } @missings };
  39         134  
487 144         781 $self->{unknown} = { map { $_ => $data{$_} } @unknown };
  54         325  
488              
489             }
490              
491             =pod
492              
493             =head1 success();
494              
495             This method returns true if there were no invalid or missing fields,
496             else it returns false.
497              
498             As a shorthand, When the $results object is used in boolean context, it is overloaded
499             to use the value of success() instead. That allows creation of a syntax like this one used
500             in C:
501              
502             my $results = $self->check_rm('form_display','_form_profile') || return $self->dfv_error_page;
503              
504             =cut
505              
506             sub success {
507 27     27 0 52 my $self = shift;
508 27   100     61 return !($self->has_invalid || $self->has_missing);
509             }
510              
511             =head1 valid( [[field] [, value]] );
512              
513             In list context with no arguments, it returns the list of fields which
514             contain valid values:
515              
516             @all_valid_field_names = $r->valid;
517              
518             In a scalar context with no arguments, it returns an hash reference which
519             contains the valid fields as keys and their input as values:
520              
521             $all_valid_href = $r->valid;
522              
523             If called with one argument in scalar context, it returns the value of that
524             C if it contains valid data, C otherwise. The value will be an
525             array ref if the field had multiple values:
526              
527             $value = $r->valid('field');
528              
529             If called with one argument in list context, it returns the values of C
530             as an array:
531              
532             @values = $r->valid('field');
533              
534             If called with two arguments, it sets C to C and returns C.
535             This form is useful to alter the results from within some constraints.
536             See the L documentation.
537              
538             $new_value = $r->valid('field',$new_value);
539              
540             =cut
541              
542             sub valid {
543 104     104 0 13349 my $self = shift;
544 104         197 my $key = shift;
545 104         167 my $val = shift;
546 104 50       294 $self->{valid}{$key} = $val if defined $val;
547              
548 104 100       270 if (defined $key) {
549 52 100       378 return wantarray ? _arrayify($self->{valid}{$key}) : $self->{valid}{$key};
550             }
551              
552             # If we got this far, there were no arguments passed.
553 52 100       235 return wantarray ? keys %{ $self->{valid} } : $self->{valid};
  1         12  
554             }
555              
556              
557             =pod
558              
559             =head1 has_missing()
560              
561             This method returns true if the results contain missing fields.
562              
563             =cut
564              
565             sub has_missing {
566 56     56 0 6590 return scalar keys %{$_[0]{missing}};
  56         232  
567             }
568              
569             =pod
570              
571             =head1 missing( [field] )
572              
573             In list context it returns the list of fields which are missing.
574             In a scalar context, it returns an array reference to the list of missing fields.
575              
576             If called with an argument, it returns true if that C is missing,
577             undef otherwise.
578              
579             =cut
580              
581             sub missing {
582 68 100   68 0 29475 return $_[0]{missing}{$_[1]} if (defined $_[1]);
583              
584 46 100       125 wantarray ? keys %{$_[0]{missing}} : [ keys %{$_[0]{missing}} ];
  1         7  
  45         254  
585             }
586              
587              
588             =pod
589              
590             =head1 has_invalid()
591              
592             This method returns true if the results contain fields with invalid
593             data.
594              
595             =cut
596              
597             sub has_invalid {
598 69     69 0 721 return scalar keys %{$_[0]{invalid}};
  69         267  
599             }
600              
601             =pod
602              
603             =head1 invalid( [field] )
604              
605             In list context, it returns the list of fields which contains invalid value.
606              
607             In a scalar context, it returns an hash reference which contains the invalid
608             fields as keys, and references to arrays of failed constraints as values.
609              
610             If called with an argument, it returns the reference to an array of failed
611             constraints for C.
612              
613             =cut
614              
615             sub invalid {
616 48     48 0 4725 my $self = shift;
617 48         97 my $field = shift;
618 48 100       150 return $self->{invalid}{$field} if defined $field;
619              
620 35 100       127 wantarray ? keys %{$self->{invalid}} : $self->{invalid};
  9         41  
621             }
622              
623             =pod
624              
625             =head1 has_unknown()
626              
627             This method returns true if the results contain unknown fields.
628              
629             =cut
630              
631             sub has_unknown {
632 0     0 0 0 return scalar keys %{$_[0]{unknown}};
  0         0  
633              
634             }
635              
636             =pod
637              
638             =head1 unknown( [field] )
639              
640             In list context, it returns the list of fields which are unknown.
641             In a scalar context, it returns an hash reference which contains the unknown
642             fields and their values.
643              
644             If called with an argument, it returns the value of that C if it
645             is unknown, undef otherwise.
646              
647             =cut
648              
649             sub unknown {
650 35 100   35 0 681 return (wantarray ? _arrayify($_[0]{unknown}{$_[1]}) : $_[0]{unknown}{$_[1]})
    100          
651             if (defined $_[1]);
652              
653 31 50       130 wantarray ? keys %{$_[0]{unknown}} : $_[0]{unknown};
  31         118  
654             }
655              
656              
657             =pod
658              
659             =head1 msgs([config parameters])
660              
661             This method returns a hash reference to error messages. The exact format
662             is determined by parameters in the C area of the validation profile,
663             described in the L documentation.
664              
665             B the C parameter in the profile can take a code reference as a
666             value, allowing complete control of how messages are generated. If such a code
667             reference was provided there, it will be called here instead of the usual
668             processing, described below. It will receive as arguments the L
669             object and a hash reference of control parameters.
670              
671             The hashref passed in should contain the same options that you can define in
672             the validation profile. This allows you to separate the controls for message
673             display from the rest of the profile. While validation profiles may be
674             different for every form, you may wish to format messages the same way across
675             many projects.
676              
677             Controls passed into the method will be applied first, followed by ones
678             applied in the profile. This allows you to keep the controls you pass to
679             C as "global" and override them in a specific profile if needed.
680              
681             =cut
682              
683             sub msgs {
684 17     17 0 2203 my $self = shift;
685 17   100     75 my $msgs = $self->{profile}{msgs} || {};
686 17 100       57 if ((ref $msgs eq 'CODE')) {
687 1         6 return $msgs->($self,@_);
688             } else {
689 16         55 return $self->_generate_msgs(@_);
690             }
691             }
692              
693              
694             sub _generate_msgs {
695 16     16   32 my $self = shift;
696 16   100     62 my $controls = shift || {};
697 16 50 33     85 if (defined $controls and ref $controls ne 'HASH') {
698 0         0 die "$0: parameter passed to msgs must be a hash ref";
699             }
700              
701              
702             # Allow msgs to be called more than one to accumulate error messages
703 16   100     125 $self->{msgs} ||= {};
704 16   100     51 $self->{profile}{msgs} ||= {};
705 16         33 $self->{msgs} = { %{ $self->{msgs} }, %$controls };
  16         49  
706              
707             # Legacy typo support.
708 16         47 for my $href ($self->{msgs}, $self->{profile}{msgs}) {
709 32 100 100     126 if (
710             (not defined $href->{invalid_separator})
711             && (defined $href->{invalid_seperator})
712             ) {
713 1         4 $href->{invalid_separator} = $href->{invalid_seperator};
714             }
715             }
716              
717             my %profile = (
718             prefix => '',
719             missing => 'Missing',
720             invalid => 'Invalid',
721             invalid_separator => ' ',
722              
723             format => '* %s',
724 16         31 %{ $self->{msgs} },
725 16         34 %{ $self->{profile}{msgs} },
  16         94  
726             );
727              
728              
729 16         35 my %msgs = ();
730              
731             # Add invalid messages to hash
732             # look at all the constraints, look up their messages (or provide a default)
733             # add field + formatted constraint message to hash
734 16 100       46 if ($self->has_invalid) {
735 9         31 my $invalid = $self->invalid;
736 9         30 for my $i ( keys %$invalid ) {
737             $msgs{$i} = join $profile{invalid_separator}, map {
738 18   66     95 _error_msg_fmt($profile{format},($profile{constraints}{$_} || $profile{invalid}))
739 14         30 } @{ $invalid->{$i} };
  14         36  
740             }
741             }
742              
743             # Add missing messages, if any
744 16 100       54 if ($self->has_missing) {
745 6         23 my $missing = $self->missing;
746 6         18 for my $m (@$missing) {
747 6         20 $msgs{$m} = _error_msg_fmt($profile{format},$profile{missing});
748             }
749             }
750              
751 16         54 my $msgs_ref = prefix_hash($profile{prefix},\%msgs);
752              
753 16 100       50 if (! $self->success) {
754 12 100       69 $msgs_ref->{ $profile{any_errors} } = 1 if defined $profile{any_errors};
755             }
756              
757 16         119 return $msgs_ref;
758              
759             }
760              
761             =pod
762              
763             =head1 meta()
764              
765             In a few cases, a constraint may discover meta data that is useful
766             to access later. For example, when using L, several bits of meta data are discovered about files in the process
767             of validating. These can include "bytes", "width", "height" and "extension".
768             The C function is used by constraint methods to set this data. It's
769             also used to access this data. Here are some examples.
770              
771             # return all field names that have meta data
772             my @fields = $results->meta();
773              
774             # To retrieve all meta data for a field:
775             $meta_href = $results->meta('img');
776              
777             # Access a particular piece:
778             $width = $results->meta('img')->{width};
779              
780             Here's how to set some meta data. This is useful to know if you are
781             writing your own complex constraint.
782              
783             $self->meta('img', {
784             width => '50',
785             height => '60',
786             });
787              
788             This function does not currently support multi-valued fields. If it
789             does in the future, the above syntax will still work.
790              
791             =cut
792              
793             sub meta {
794 60     60 0 5471 my $self = shift;
795 60         81 my $field = shift;
796 60         73 my $data = shift;
797              
798             # initialize if it's the first call
799 60   100     166 $self->{__META} ||= {};
800              
801 60 100       114 if ($data) {
802 26 50       59 (ref $data eq 'HASH') or die 'meta: data passed not a hash ref';
803 26         58 $self->{__META}{$field} = $data;
804             }
805              
806              
807             # If we are passed a field, return data for that field
808 60 50       103 if ($field) {
809 60         204 return $self->{__META}{$field};
810             }
811             # Otherwise return a list of all fields that have meta data
812             else {
813 0         0 return keys %{ $self->{__META} };
  0         0  
814             }
815             }
816              
817             # These are documented in ::Constraints, in the section
818             # on writing your own routines. It was more intuitive
819             # for the user to look there.
820              
821             sub get_input_data {
822 206     206 0 341 my $self = shift;
823 206         386 my %p = @_;
824 206 100       458 if ($p{as_hashref}) {
825 1         5 my %hash = $self->_get_input_as_hash( $self->{__INPUT_DATA} );
826 1         7 return \%hash;
827             }
828             else {
829 205         611 return $self->{__INPUT_DATA};
830             }
831             }
832              
833             sub get_filtered_data {
834 87     87 0 125 my $self = shift;
835 87         153 return $self->{__FILTERED_DATA};
836             }
837              
838             sub get_current_constraint_field {
839 79     79 0 104 my $self = shift;
840 79         156 return $self->{__CURRENT_CONSTRAINT_FIELD};
841             }
842              
843             sub get_current_constraint_value {
844 36     36 0 60 my $self = shift;
845 36         630 return $self->{__CURRENT_CONSTRAINT_VALUE};
846             }
847              
848             sub get_current_constraint_name {
849 38     38 0 63 my $self = shift;
850 38         157 return $self->{__CURRENT_CONSTRAINT_NAME};
851             }
852              
853             sub untainted_constraint_value {
854 16     16 0 23 my $self = shift;
855 16         146 my $match = shift;
856              
857 16 100       41 return undef unless defined $match;
858 12 100       1054 return $self->{__UNTAINT_THIS} ? $match : length $match;
859             }
860              
861             sub set_current_constraint_name {
862 19     19 0 28 my $self = shift;
863 19         26 my $value = shift;
864 19         36 $self->{__CURRENT_CONSTRAINT_NAME} = $value;
865             }
866             # same as above
867             sub name_this {
868 35     35 0 67 my $self = shift;
869 35         51 my $value = shift;
870 35         82 $self->{__CURRENT_CONSTRAINT_NAME} = $value;
871             }
872              
873             # INPUT: prefix_string, hash reference
874             # Copies the hash and prefixes all keys with prefix_string
875             # OUTPUT: hash reference
876             sub prefix_hash {
877 16     16 0 39 my ($pre,$href) = @_;
878 16 50       48 die "prefix_hash: need two arguments" unless (scalar @_ == 2);
879 16 50       46 die "prefix_hash: second argument must be a hash ref" unless (ref $href eq 'HASH');
880 16         94 my %out;
881 16         43 for (keys %$href) {
882 20         65 $out{$pre.$_} = $href->{$_};
883             }
884 16         42 return \%out;
885             }
886              
887              
888             # We tolerate two kinds of regular expression formats
889             # First, the preferred format made with "qr", matched using a leading paren
890             # Also, we accept the deprecated format given as strings: 'm/old/'
891             # (which must start with a slash or "m", not a paren)
892             sub _create_sub_from_RE {
893 340   100 340   1022 my $re = shift || return undef;
894 51         88 my $untaint_this = shift;
895 51         72 my $force_method_p = shift;
896              
897 51         80 my $sub;
898             # If it's "qr" style
899 51 100       170 if (substr($re,0,1) eq '(') {
900             $sub = sub {
901             # With methods, the value is the second argument
902 75 100   75   160 my $val = $force_method_p ? $_[1] : $_[0];
903 75         397 my ($match) = scalar ($val =~ $re);
904 75 100 66     210 if ($untaint_this && defined $match) {
905             # pass the value through a RE that matches anything to untaint it.
906 5         25 my ($untainted) = ($& =~ m/(.*)/s);
907 5         12 return $untainted;
908             }
909             else {
910 70         201 return $match;
911             }
912 41         203 };
913              
914             }
915             else {
916 10         54 local $SIG{__DIE__} = \&confess;
917 10 50       38 my $return_code = ($untaint_this) ? '; return ($& =~ m/(.*)/s)[0] if defined($`);' : '';
918             # With methods, the value is the second argument
919 10 50       36 if ($force_method_p) {
920 0         0 $sub = eval 'sub { $_[1] =~ '.$re.$return_code. '}';
921             }
922             else {
923 10         908 $sub = eval 'sub { $_[0] =~ '.$re.$return_code. '}';
924             }
925 10 50       54 die "Error compiling regular expression $re: $@" if $@;
926             }
927 51         136 return $sub;
928             }
929              
930              
931             sub _error_msg_fmt {
932 24     24   64 my ($fmt,$msg) = @_;
933 24   50     53 $fmt ||=
934             '* %s';
935 24 50       85 ($fmt =~ m/%s/) || die 'format must contain %s';
936 24         166 return sprintf $fmt, $msg;
937             }
938              
939              
940              
941             # takes string or array ref as input
942             # returns array
943             sub _arrayify {
944             # if the input is undefined, return an empty list
945 931     931   2979 my $val = shift;
946 931 100       2164 defined $val or return ();
947              
948             # if it's a reference, return an array unless it points to an empty array. -mls
949 495 100       1071 if ( ref $val eq 'ARRAY' ) {
950 228         773 local $^W = 0; # turn off warnings about undef
951 228 100       1172 return grep(defined, @$val) ? @$val : ();
952             }
953             # if it's a string, return an array unless the string is missing or empty. -mls
954             else {
955 267 50       959 return (length $val) ? ($val) : ();
956             }
957             }
958              
959             # apply filter, modifying %valid by reference
960             # We don't bother trying to filter undefined fields.
961             # This prevents warnings from Perl.
962             sub _filter_apply {
963 26     26   54 my ($valid,$field,$filter) = @_;
964 26 50       71 die 'wrong number of arguments passed to _filter_apply' unless (scalar @_ == 3);
965 26 100       66 if (ref $valid->{$field} eq 'ARRAY') {
966 7         12 for (my $i = 0; $i < @{ $valid->{$field} }; $i++) {
  29         67  
967 22 50       51 $valid->{$field}->[$i] = $filter->( $valid->{$field}->[$i] ) if defined $valid->{$field}->[$i];
968             }
969             }
970             else {
971 19 50       82 $valid->{$field} = $filter->( $valid->{$field} ) if defined $valid->{$field};
972             }
973             }
974              
975             # =head2 _constraint_hash_build()
976             #
977             # $constraint_href = $self->_constraint_hash_build($spec,$untaint_p)
978             #
979             # Input:
980             # - $spec # Any constraint valid in the profile
981             # - $untaint # bool for whether we could try to untaint the field.
982             # - $force_method_p # bool for if it's a method ?
983             #
984             # Output:
985             # - $constraint_hashref
986             # Keys are as follows:
987             # constraint - the constraint as coderef
988             # name - the constraint name, if we know it.
989             # params - 'params', as given in the hashref style of specifying a constraint
990             # is_method - bool for whether this was a 'constraint' or 'constraint_method'
991              
992             sub _constraint_hash_build {
993 189     189   429 my ($self,$constraint_spec,$untaint_this,$force_method_p) = @_;
994 189 50       475 die "_constraint_hash_build received wrong number of arguments" unless (scalar @_ == 4);
995              
996 189         530 my $c = {
997             name => undef,
998             constraint => $constraint_spec,
999             };
1000 189 100       497 $c->{name} = $constraint_spec if not ref $constraint_spec;
1001              
1002             # constraints can be passed in directly via hash
1003 189 100       526 if (ref $c->{constraint} eq 'HASH') {
1004 51   66     237 $c->{constraint} = ($constraint_spec->{constraint_method} || $constraint_spec->{constraint});
1005 51         105 $c->{name} = $constraint_spec->{name};
1006 51         90 $c->{params} = $constraint_spec->{params};
1007 51 100       139 $c->{is_method} = 1 if $constraint_spec->{constraint_method};
1008             }
1009              
1010             # Check for regexp constraint
1011 189 100 100     1410 if ((ref $c->{constraint} eq 'Regexp')
    100          
1012             or ( $c->{constraint} =~ m@^\s*(/.+/|m(.).+\2)[cgimosx]*\s*$@ )) {
1013 22         62 $c->{constraint} = _create_sub_from_RE($c->{constraint},$untaint_this,$force_method_p);
1014             }
1015             # check for code ref
1016             elsif (ref $c->{constraint} eq 'CODE') {
1017             # do nothing, it's already a code ref
1018             }
1019             else {
1020             # provide a default name for the constraint if we don't have one already
1021 74 50 66     256 if (not $c->{name} and not ref $c->{constraint}) {
1022 27   33     80 $c->{name} ||= $c->{constraint};
1023             }
1024              
1025             #If untaint is turned on call match_* sub directly.
1026 74 100       176 if ($untaint_this) {
1027 3         8 my $routine = 'match_'.$c->{constraint};
1028 3         5 my $match_sub = *{qualify_to_ref($routine)}{CODE};
  3         9  
1029 3 50       74 if ($match_sub) {
    100          
1030 0         0 $c->{constraint} = $match_sub;
1031             }
1032             # If the constraint name starts with RE_, try looking for it in the Regexp::Common package
1033             elsif ($c->{constraint} =~ m/^RE_/) {
1034 2         10 local $SIG{__DIE__} = \&confess;
1035 2         5 $c->{is_method} = 1;
1036 2   50     143 $c->{constraint} = eval 'sub { &_create_regexp_common_constraint(@_)}'
1037             || die "could not create Regexp::Common constraint: $@";
1038             } else {
1039 1         13 die "No untainting constraint found named $c->{constraint}";
1040             }
1041             }
1042             else {
1043             # try to use match_* first
1044 71         187 my $routine = 'match_'.$c->{constraint};
1045 71 100       113 if (defined *{qualify_to_ref($routine)}{CODE}) {
  71 100       273  
    100          
1046 53         1723 local $SIG{__DIE__} = \&confess;
1047 53     16   4130 $c->{constraint} = eval 'sub { no strict qw/refs/; return defined &{"match_'.$c->{constraint}.'"}(@_)}';
  16     12   95  
  16         29  
  16         754  
  12         150  
  12         32  
  12         665  
1048             }
1049             # match_* doesn't exist; if it is supposed to be from the
1050             # validator_package(s) there may be only valid_* defined
1051 18         437 elsif (my $valid_sub = *{qualify_to_ref('valid_'.$c->{constraint})}{CODE}) {
1052 12         218 $c->{constraint} = $valid_sub;
1053             }
1054             # Load it from Regexp::Common
1055             elsif ($c->{constraint} =~ m/^RE_/) {
1056 5         105 local $SIG{__DIE__} = \&confess;
1057 5         10 $c->{is_method} = 1;
1058 5   50     401 $c->{constraint} = eval 'sub { return defined &_create_regexp_common_constraint(@_)}' ||
1059             die "could not create Regexp::Common constraint: $@";
1060             }
1061             else {
1062 1         31 die "No constraint found named '$c->{name}'";
1063             }
1064             }
1065             }
1066              
1067             # Save the current constraint name for later
1068 187         1737 $self->{__CURRENT_CONSTRAINT_NAME} = $c->{name};
1069              
1070 187         401 return $c;
1071              
1072             }
1073              
1074             # =head2 _constraint_input_build()
1075             #
1076             # @params = $self->constraint_input_build($c,$value,$data);
1077             #
1078             # Build in the input that passed into the constraint.
1079             #
1080             # =cut
1081              
1082             sub _constraint_input_build {
1083 191     191   446 my ($self,$c,$value,$data) = @_;
1084 191 50       461 die "_constraint_input_build received wrong number of arguments" unless (scalar @_ == 4);
1085              
1086 191         287 my @params;
1087 191 100       422 if (defined $c->{params}) {
1088 37         97 for my $fname (_arrayify($c->{params})) {
1089             # If the value is passed by reference, we treat it literally
1090 61 100       189 push @params, (ref $fname) ? $fname : $data->{$fname}
1091             }
1092             }
1093             else {
1094 154         307 push @params, $value;
1095             }
1096              
1097 191 100       502 unshift @params, $self if $c->{is_method};
1098 191         476 return @params;
1099             }
1100              
1101             # =head2 _constraint_check_match()
1102             #
1103             # ($value,$failed_href) = $self->_constraint_check_match($c,\@params,$untaint_this);
1104             #
1105             # This is the routine that actually, finally, checks if a constraint passes or fails.
1106             #
1107             # Input:
1108             # - $c, a constraint hash, as returned by C<_constraint_hash_build()>.
1109             # - \@params, params to pass to the constraint, as prepared by C<_constraint_input_build()>.
1110             # - $untaint_this bool if we untaint successful constraints.
1111             #
1112             # Output:
1113             # - $value the value if successful
1114             # - $failed_href a hashref with the following keys:
1115             # - failed bool for failure or not
1116             # - name name of the failed constraint, if known.
1117              
1118             sub _constraint_check_match {
1119 191     191   389 my ($self,$c,$params,$untaint_this) = @_;
1120 191 50       426 die "_constraint_check_match received wrong number of arguments" unless (scalar @_ == 4);
1121              
1122             # Store whether or not we want untainting in the object so that constraints
1123             # can do the right thing conditionally.
1124 191         608 $self->{__UNTAINT_THIS} = $untaint_this;
1125              
1126 191         2067 my $match = $c->{constraint}->( @$params );
1127              
1128             # We need to make this distinction when untainting,
1129             # to allow untainting values that are defined but not true,
1130             # such as zero.
1131 191         4916 my $success;
1132 191 100       461 if (defined $match) {
1133 162 100       398 $success = ($untaint_this) ? length $match : $match;
1134             }
1135              
1136 191 100       459 my $failed = 1 unless $success;
1137             return (
1138             $match,
1139             {
1140             failed => $failed,
1141             name => $self->{__CURRENT_CONSTRAINT_NAME},
1142             },
1143 191         963 );
1144             }
1145              
1146             # Figure out whether the data is a hash reference of a param-capable object and return it has a hash
1147             sub _get_input_as_hash {
1148 338     338   754 my ($self,$data) = @_;
1149 338         2215 $self->{__INPUT_DATA} = $data;
1150              
1151 338         1818 require Scalar::Util;
1152              
1153             # This checks whether we have an object that supports param
1154 338 100 66     1806 if ( Scalar::Util::blessed($data) && $data->can('param') ) {
    50          
1155 46         76 my %return;
1156 46         133 for my $k ($data->param()){
1157             # we expect param to return an array if there are multiple values
1158 167         1046 my @v;
1159              
1160             # CGI::Simple requires us to call 'upload()' to get upload data,
1161             # while CGI/Apache::Request return it on calling 'param()'.
1162             #
1163             # This seems quirky, but there isn't a way for us to easily check if
1164             # "this field contains a file upload" or not.
1165 167 50       548 if ($data->isa('CGI::Simple')) {
1166 0   0     0 @v = $data->upload($k) || $data->param($k);
1167             }
1168             else {
1169             # insecure
1170 167         326 @v = $data->multi_param($k);
1171             }
1172              
1173             # we expect param to return an array if there are multiple values
1174 167 50       3971 $return{$k} = scalar(@v)>1 ? \@v : $v[0];
1175             }
1176 46         259 return %return;
1177             }
1178             # otherwise, it's already a hash reference
1179             elsif (ref $data eq 'HASH') {
1180             # be careful to actually copy array references
1181 292         1121 my %copy = %$data;
1182 292         780 for (grep { ref $data->{$_} eq 'ARRAY' } keys %$data) {
  763         1756  
1183 44         61 my @array_copy = @{ $data->{$_} };
  44         98  
1184 44         107 $copy{$_} = \@array_copy;
1185             }
1186              
1187 292         1416 return %copy;
1188             }
1189             else {
1190 0         0 die "Data::FormValidator->validate() or check() called with invalid input data structure.";
1191             }
1192             }
1193              
1194             # A newer version of this logic now exists in Constraints.pm in the AUTOLOADing section
1195             # This is is used to support the older param passing style. Eg:
1196             #
1197             # {
1198             # constraint => 'RE_foo_bar',
1199             # params => [ \'zoo' ]
1200             # }
1201             #
1202             # Still, it's possible, the two bits of logic could be refactored into one location if you cared
1203             # to do that.
1204              
1205             sub _create_regexp_common_constraint {
1206             # this should work most of the time and is useful for preventing warnings
1207              
1208             # prevent name space clashes
1209             package Data::FormValidator::Constraints::RegexpCommon;
1210              
1211 7     7   324 require Regexp::Common;
1212 7         1971 import Regexp::Common 'RE_ALL';
1213              
1214 7         136596 my $self = shift;
1215 7         26 my $re_name = $self->get_current_constraint_name;
1216             # deference all input
1217 7 100       17 my @params = map {$_ = $$_ if ref $_ } @_;
  9         46  
1218              
1219 61     61   641 no strict "refs";
  61         147  
  61         39682  
1220 7   50     32 my $re = &$re_name(-keep=>1,@params) || die 'no matching Regexp::Common routine found';
1221 7 100       485 return ($self->get_current_constraint_value =~ qr/^$re$/) ? $1 : undef;
1222             }
1223              
1224             # _add_constraints_from_map($profile,'constraint',\%valid);
1225             # Returns:
1226             # - a hash to add to either 'constraints' or 'constraint_methods'
1227              
1228             sub _add_constraints_from_map {
1229 292 50   292   686 die "_add_constraints_from_map: need 3 arguments" unless (scalar @_ == 3);
1230 292         610 my ($profile, $name, $valid) = @_;
1231 292 50       1298 ($name =~ m/^constraint(_method)?$/) || die "unexpected input.";
1232              
1233 292         720 my $key_name = $name.'s';
1234 292         517 my $map_name = $name.'_regexp_map';
1235              
1236 292         444 my %result = ();
1237 292         408 for my $re (keys %{ $profile->{$map_name} }) {
  292         847  
1238 20         53 my $sub = _create_sub_from_RE($re);
1239              
1240             # find all the keys that match this RE and add a constraint for them
1241 20         63 for my $key (keys %$valid) {
1242 54 100       407 if ($sub->($key)) {
1243 34         74 my $cur = $profile->{$key_name}{$key};
1244 34         68 my $new = $profile->{$map_name}{$re};
1245             # If they already have an arrayref of constraints, add to the list
1246 34 100       100 if (ref $cur eq 'ARRAY') {
    100          
1247 2         5 push @{ $result{$key} }, @$cur, $new;
  2         10  
1248             }
1249             # If they have a single constraint defined, create an array ref with with this plus the new one
1250             elsif ($cur) {
1251 1         4 $result{$key} = [$cur,$new];
1252             }
1253             # otherwise, a new constraint is created with this as the single constraint
1254             else {
1255 31         57 $result{$key} = $new;
1256             }
1257 34 50       179 warn "$map_name: $key matches\n" if $profile->{debug};
1258             }
1259             }
1260             }
1261 292         914 return %result;
1262             }
1263              
1264             sub _bool_overload_based_on_success {
1265 9     9   2725 my $results = shift;
1266 9         24 return $results->success()
1267             }
1268              
1269             # =head2 _check_constraints()
1270             #
1271             # $self->_check_constraints(
1272             # $profile->{constraint_methods},
1273             # \%valid,
1274             # $untaint_all
1275             # \%untaint_hash
1276             # $force_method_p
1277             #);
1278             #
1279             # Input:
1280             # - 'constraints' or 'constraint_methods' hashref
1281             # - hashref of valid data
1282             # - bool to try to untaint everything
1283             # - hashref of things to untaint
1284             # - bool if all constraints should be treated as methods.
1285              
1286             sub _check_constraints {
1287 290     290   676 my ($self,
1288             $constraint_href,
1289             $valid,
1290             $untaint_all,
1291             $untaint_href,
1292             $force_method_p) = @_;
1293              
1294 290         1035 while ( my ($field,$constraint_list) = each %$constraint_href ) {
1295 176 100       476 next unless exists $valid->{$field};
1296              
1297 171 100       492 my $is_constraint_list = 1 if (ref $constraint_list eq 'ARRAY');
1298 171   100     817 my $untaint_this = ($untaint_all || $untaint_href->{$field} || 0);
1299              
1300 171         300 my @invalid_list;
1301             # used to insure we only bother recording each failed constraint once
1302             my %constraints_seen;
1303 171         388 for my $constraint_spec (_arrayify($constraint_list)) {
1304              
1305             # set current constraint field for use by get_current_constraint_field
1306 189         447 $self->{__CURRENT_CONSTRAINT_FIELD} = $field;
1307              
1308             # Initialize the current constraint name to undef, to prevent it
1309             # from being accidently shared
1310 189         371 $self->{__CURRENT_CONSTRAINT_NAME} = undef;
1311              
1312 189         525 my $c = $self->_constraint_hash_build($constraint_spec,$untaint_this, $force_method_p);
1313 187 100       465 $c->{is_method} = 1 if $force_method_p;
1314              
1315 187 100       472 my $is_value_list = 1 if (ref $valid->{$field} eq 'ARRAY');
1316 187         506 my %param_data = ( $self->_get_input_as_hash($self->get_input_data) , %$valid );
1317 187 100       520 if ($is_value_list) {
1318 7         17 for (my $i = 0; $i < scalar @{ $valid->{$field}} ; $i++) {
  21         73  
1319 14 100       39 if( !exists $constraints_seen{\$c} ) {
1320              
1321 11         37 my @params = $self->_constraint_input_build($c,$valid->{$field}->[$i],\%param_data);
1322              
1323             # set current constraint field for use by get_current_constraint_value
1324 11         24 $self->{__CURRENT_CONSTRAINT_VALUE} = $valid->{$field}->[$i];
1325              
1326 11         25 my ($match,$failed) = $self->_constraint_check_match($c,\@params,$untaint_this);
1327 11 100       25 if ($failed->{failed}) {
1328 4         7 push @invalid_list, $failed;
1329 4         14 $constraints_seen{\$c} = 1;
1330             }
1331             else {
1332 7 50       31 $valid->{$field}->[$i] = $match if $untaint_this;
1333             }
1334             }
1335             }
1336             }
1337             else {
1338 180         545 my @params = $self->_constraint_input_build($c,$valid->{$field},\%param_data);
1339              
1340             # set current constraint field for use by get_current_constraint_value
1341 180         416 $self->{__CURRENT_CONSTRAINT_VALUE} = $valid->{$field};
1342              
1343 180         482 my ($match,$failed) = $self->_constraint_check_match($c,\@params,$untaint_this);
1344 180 100       509 if ($failed->{failed}) {
1345 89         707 push @invalid_list, $failed
1346             }
1347             else {
1348 91 100       574 $valid->{$field} = $match if $untaint_this;
1349             }
1350             }
1351             }
1352              
1353 169 100       695 if (@invalid_list) {
1354 85         225 my @failed = map { $_->{name} } @invalid_list;
  93         363  
1355 85         178 push @{ $self->{invalid}{$field} }, @failed;
  85         393  
1356             # the older interface to validate returned things differently
1357 85 100       163 push @{ $self->{validate_invalid} }, $is_constraint_list ? [$field, @failed] : $field;
  85         660  
1358             }
1359             }
1360             }
1361              
1362             1;
1363              
1364             __END__