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__ |