line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package TUWF::Validate; |
2
|
|
|
|
|
|
|
|
3
|
3
|
|
|
3
|
|
116977
|
use strict; |
|
3
|
|
|
|
|
15
|
|
|
3
|
|
|
|
|
74
|
|
4
|
3
|
|
|
3
|
|
11
|
use warnings; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
96
|
|
5
|
3
|
|
|
3
|
|
16
|
use Carp 'croak'; |
|
3
|
|
|
|
|
4
|
|
|
3
|
|
|
|
|
153
|
|
6
|
3
|
|
|
3
|
|
17
|
use Exporter 'import'; |
|
3
|
|
|
|
|
4
|
|
|
3
|
|
|
|
|
97
|
|
7
|
3
|
|
|
3
|
|
13
|
use Scalar::Util 'blessed'; |
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
8166
|
|
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
our @EXPORT_OK = qw/compile validate/; |
10
|
|
|
|
|
|
|
our $VERSION = '1.4'; |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
# Unavailable as custom validation names |
14
|
|
|
|
|
|
|
my %builtin = map +($_,1), qw/ |
15
|
|
|
|
|
|
|
type |
16
|
|
|
|
|
|
|
required default |
17
|
|
|
|
|
|
|
rmwhitespace |
18
|
|
|
|
|
|
|
values scalar sort unique |
19
|
|
|
|
|
|
|
keys unknown |
20
|
|
|
|
|
|
|
func |
21
|
|
|
|
|
|
|
/; |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
sub _length { |
25
|
99
|
|
|
99
|
|
162
|
my($exp, $min, $max) = @_; |
26
|
|
|
|
|
|
|
+{ _analyze_minlength => $min, _analyze_maxlength => $max, func => sub { |
27
|
94
|
100
|
|
94
|
|
238
|
my $got = ref $_[0] eq 'HASH' ? keys %{$_[0]} : ref $_[0] eq 'ARRAY' ? @{$_[0]} : length $_[0]; |
|
6
|
100
|
|
|
|
14
|
|
|
4
|
|
|
|
|
5
|
|
28
|
94
|
100
|
100
|
|
|
443
|
(!defined $min || $got >= $min) && (!defined $max || $got <= $max) ? 1 : { expected => $exp, got => $got }; |
29
|
|
|
|
|
|
|
}} |
30
|
99
|
|
|
|
|
561
|
} |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
# Basically the same as ( regex => $arg ), but hides the regex error |
33
|
|
|
|
|
|
|
sub _reg { |
34
|
27
|
|
|
27
|
|
36
|
my $reg = $_[0]; |
35
|
27
|
100
|
|
124
|
|
150
|
( type => 'scalar', _analyze_regex => "$reg", func => sub { $_[0] =~ $reg ? 1 : { got => $_[0] } } ); |
|
124
|
|
|
|
|
879
|
|
36
|
|
|
|
|
|
|
} |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
our $re_num = qr/^-?(?:0|[1-9]\d*)(?:\.\d+)?(?:[eE][+-]?\d+)?$/; |
40
|
|
|
|
|
|
|
my $re_int = qr/^-?(?:0|[1-9]\d*)$/; |
41
|
|
|
|
|
|
|
our $re_uint = qr/^(?:0|[1-9]\d*)$/; |
42
|
|
|
|
|
|
|
my $re_fqdn = qr/(?:[a-zA-Z0-9][\w-]*\.)+[a-zA-Z][a-zA-Z0-9-]{1,25}\.?/; |
43
|
|
|
|
|
|
|
my $re_ip4_digit = qr/(?:0|[1-9]|[1-9][0-9]|1[0-9]{2}|2[0-4][0-9]|25[0-5])/; |
44
|
|
|
|
|
|
|
my $re_ip4 = qr/($re_ip4_digit\.){3}$re_ip4_digit/; |
45
|
|
|
|
|
|
|
# This monstrosity is based on http://stackoverflow.com/questions/53497/regular-expression-that-matches-valid-ipv6-addresses |
46
|
|
|
|
|
|
|
# Doesn't allow IPv4-mapped-IPv6 addresses or other fancy stuff. |
47
|
|
|
|
|
|
|
my $re_ip6 = qr/(?:[0-9a-fA-F]{1,4}:){7,7}[0-9a-fA-F]{1,4}|(?:[0-9a-fA-F]{1,4}:){1,7}:|(?:[0-9a-fA-F]{1,4}:){1,6}:[0-9a-fA-F]{1,4}|(?:[0-9a-fA-F]{1,4}:){1,5}(?::[0-9a-fA-F]{1,4}){1,2}|(?:[0-9a-fA-F]{1,4}:){1,4}(?::[0-9a-fA-F]{1,4}){1,3}|(?:[0-9a-fA-F]{1,4}:){1,3}(?::[0-9a-fA-F]{1,4}){1,4}|(?:[0-9a-fA-F]{1,4}:){1,2}(?::[0-9a-fA-F]{1,4}){1,5}|[0-9a-fA-F]{1,4}:(?:(?::[0-9a-fA-F]{1,4}){1,6})|:(?:(?::[0-9a-fA-F]{1,4}){1,7}|:)/; |
48
|
|
|
|
|
|
|
my $re_ip = qr/(?:$re_ip4|$re_ip6)/; |
49
|
|
|
|
|
|
|
my $re_domain = qr/(?:$re_fqdn|$re_ip4|\[$re_ip6\])/; |
50
|
|
|
|
|
|
|
# Also used by the TUWF::Misc::kv_validate() |
51
|
|
|
|
|
|
|
our $re_email = qr/^[-\+\.#\$=\w]+\@$re_domain$/; |
52
|
|
|
|
|
|
|
our $re_weburl = qr/^https?:\/\/$re_domain(?::[1-9][0-9]{0,5})?(?:\/[^\s<>"]*)$/; |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
our %default_validations = ( |
56
|
|
|
|
|
|
|
regex => sub { |
57
|
|
|
|
|
|
|
my $reg = shift; |
58
|
|
|
|
|
|
|
# Error objects should be plain data structures so that they can easily |
59
|
|
|
|
|
|
|
# be converted to JSON for debugging. We have to stringify $reg in the |
60
|
|
|
|
|
|
|
# error object to ensure that. |
61
|
|
|
|
|
|
|
+{ type => 'scalar', _analyze_regex => "$reg", func => sub { $_[0] =~ $reg ? 1 : { regex => "$reg", got => $_[0] } } } |
62
|
|
|
|
|
|
|
}, |
63
|
|
|
|
|
|
|
enum => sub { |
64
|
|
|
|
|
|
|
my @l = ref $_[0] eq 'HASH' ? sort keys %{$_[0]} : ref $_[0] eq 'ARRAY' ? @{$_[0]} : ($_[0]); |
65
|
|
|
|
|
|
|
my %opts = map +($_,1), @l; |
66
|
|
|
|
|
|
|
+{ type => 'scalar', func => sub { $opts{ (my $v = $_[0]) } ? 1 : { expected => \@l, got => $_[0] } } } |
67
|
|
|
|
|
|
|
}, |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
minlength => sub { _length $_[0], $_[0] }, |
70
|
|
|
|
|
|
|
maxlength => sub { _length $_[0], undef, $_[0] }, |
71
|
|
|
|
|
|
|
length => sub { _length($_[0], ref $_[0] eq 'ARRAY' ? @{$_[0]} : ($_[0], $_[0])) }, |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
anybool => { type => 'any', required => 0, default => 0, func => sub { $_[0] = $_[0] ? 1 : 0; 1 } }, |
74
|
|
|
|
|
|
|
jsonbool => { type => 'any', func => sub { |
75
|
|
|
|
|
|
|
my $r = $_[0]; |
76
|
|
|
|
|
|
|
blessed $r && ( |
77
|
|
|
|
|
|
|
$r->isa('JSON::PP::Boolean') |
78
|
|
|
|
|
|
|
|| $r->isa('JSON::XS::Boolean') |
79
|
|
|
|
|
|
|
|| $r->isa('Types::Serialiser::Boolean') |
80
|
|
|
|
|
|
|
|| $r->isa('Cpanel::JSON::XS::Boolean') |
81
|
|
|
|
|
|
|
|| $r->isa('boolean') |
82
|
|
|
|
|
|
|
) ? 1 : {}; |
83
|
|
|
|
|
|
|
} }, |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
# JSON number format, regex from http://stackoverflow.com/questions/13340717/json-numbers-regular-expression |
86
|
|
|
|
|
|
|
num => { _reg $re_num }, |
87
|
|
|
|
|
|
|
int => { _reg $re_int }, # implies num |
88
|
|
|
|
|
|
|
uint => { _reg $re_uint }, # implies num |
89
|
|
|
|
|
|
|
min => sub { |
90
|
|
|
|
|
|
|
my $min = shift; |
91
|
|
|
|
|
|
|
+{ num => 1, _analyze_min => $min, func => sub { $_[0] >= $min ? 1 : { expected => $min, got => $_[0] } } } |
92
|
|
|
|
|
|
|
}, |
93
|
|
|
|
|
|
|
max => sub { |
94
|
|
|
|
|
|
|
my $max = shift; |
95
|
|
|
|
|
|
|
+{ num => 1, _analyze_max => $max, func => sub { $_[0] <= $max ? 1 : { expected => $max, got => $_[0] } } } |
96
|
|
|
|
|
|
|
}, |
97
|
|
|
|
|
|
|
range => sub { +{ min => $_[0][0], max => $_[0][1] } }, |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
ascii => { _reg qr/^[\x20-\x7E]*$/ }, |
100
|
|
|
|
|
|
|
ipv4 => { _reg $re_ip4 }, |
101
|
|
|
|
|
|
|
ipv6 => { _reg $re_ip6 }, |
102
|
|
|
|
|
|
|
ip => { _reg $re_ip }, |
103
|
|
|
|
|
|
|
email => { _reg($re_email), maxlength => 254 }, |
104
|
|
|
|
|
|
|
weburl => { _reg($re_weburl), maxlength => 65536 }, # the maxlength is a bit arbitrary, but better than unlimited |
105
|
|
|
|
|
|
|
); |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
# Loads a hashref of validations and a schema definition, and converts it into |
109
|
|
|
|
|
|
|
# an object with: |
110
|
|
|
|
|
|
|
# { |
111
|
|
|
|
|
|
|
# name => $name_or_undef, |
112
|
|
|
|
|
|
|
# validations => [ $recursive_compiled_object, .. ], |
113
|
|
|
|
|
|
|
# schema => $modified_schema_without_validations, |
114
|
|
|
|
|
|
|
# known_keys => { $key => 1, .. } # Extracted from 'keys', Used for the 'unknown' validation |
115
|
|
|
|
|
|
|
# } |
116
|
|
|
|
|
|
|
sub _compile { |
117
|
963
|
|
|
963
|
|
1300
|
my($validations, $schema, $rec) = @_; |
118
|
|
|
|
|
|
|
|
119
|
963
|
|
|
|
|
1053
|
my(%top, @val); |
120
|
963
|
100
|
|
|
|
1540
|
my @keys = keys %{$schema->{keys}} if $schema->{keys}; |
|
45
|
|
|
|
|
135
|
|
121
|
|
|
|
|
|
|
|
122
|
963
|
|
|
|
|
2488
|
for(sort keys %$schema) { |
123
|
1850
|
100
|
100
|
|
|
4771
|
if($builtin{$_} || /^_analyze_/) { |
124
|
1306
|
|
|
|
|
1814
|
$top{$_} = $schema->{$_}; |
125
|
1306
|
|
|
|
|
1676
|
next; |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
|
128
|
544
|
|
100
|
|
|
1251
|
my $t = $validations->{$_} || $default_validations{$_}; |
129
|
544
|
100
|
|
|
|
907
|
croak "Unknown validation: $_" if !$t; |
130
|
542
|
100
|
|
|
|
1358
|
croak "Recursion limit exceeded while resolving validation '$_'" if $rec < 1; |
131
|
540
|
100
|
|
|
|
1016
|
$t = ref $t eq 'HASH' ? $t : $t->($schema->{$_}); |
132
|
|
|
|
|
|
|
|
133
|
540
|
|
|
|
|
1147
|
my $v = _compile($validations, $t, $rec-1); |
134
|
412
|
|
|
|
|
633
|
$v->{name} = $_; |
135
|
412
|
|
|
|
|
797
|
push @val, $v; |
136
|
|
|
|
|
|
|
} |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
# Inherit some builtin options from validations |
139
|
831
|
|
|
|
|
1177
|
for my $t (@val) { |
140
|
412
|
100
|
100
|
|
|
801
|
if($top{type} && $t->{schema}{type} && $top{type} ne $t->{schema}{type}) { |
|
|
|
100
|
|
|
|
|
141
|
2
|
50
|
|
|
|
137
|
croak "Incompatible types, the schema specifies '$top{type}' but validation '$t->{name}' requires '$t->{schema}{type}'" if $schema->{type}; |
142
|
0
|
|
|
|
|
0
|
croak "Incompatible types, '$t->[0]' requires '$t->{schema}{type}', but another validation requires '$top{type}'"; |
143
|
|
|
|
|
|
|
} |
144
|
410
|
|
100
|
|
|
3017
|
exists $t->{schema}{$_} and $top{$_} //= delete $t->{schema}{$_} for qw/required default rmwhitespace type scalar unknown sort unique/; |
|
|
|
66
|
|
|
|
|
145
|
|
|
|
|
|
|
|
146
|
410
|
|
|
|
|
481
|
push @keys, keys %{ delete $t->{known_keys} }; |
|
410
|
|
|
|
|
673
|
|
147
|
410
|
100
|
|
|
|
877
|
push @keys, keys %{ $t->{schema}{keys} } if $t->{schema}{keys}; |
|
16
|
|
|
|
|
41
|
|
148
|
|
|
|
|
|
|
} |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
# Compile sub-schemas |
151
|
829
|
100
|
|
|
|
1252
|
$top{keys} = { map +($_, compile($validations, $top{keys}{$_})), keys %{$top{keys}} } if $top{keys}; |
|
45
|
|
|
|
|
135
|
|
152
|
828
|
100
|
|
|
|
1178
|
$top{values} = compile($validations, $top{values}) if $top{values}; |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
# XXX: Flattening recursive validations would be faster and may simplify |
155
|
|
|
|
|
|
|
# the code a bit, but makes error objects harder to interpret. |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
# XXX: As an optimization, it's possible to remove double validations (e.g. |
158
|
|
|
|
|
|
|
# multiple invocations of the same validation with the same options due to |
159
|
|
|
|
|
|
|
# validations calling each other). Care must be taken that this won't |
160
|
|
|
|
|
|
|
# affect error objects (i.e. only subsequent invocations should be |
161
|
|
|
|
|
|
|
# removed). |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
return { |
164
|
828
|
|
|
|
|
3153
|
validations => \@val, |
165
|
|
|
|
|
|
|
schema => \%top, |
166
|
|
|
|
|
|
|
known_keys => { map +($_,1), @keys }, |
167
|
|
|
|
|
|
|
}; |
168
|
|
|
|
|
|
|
} |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
sub compile { |
172
|
423
|
|
|
423
|
0
|
21662
|
my($validations, $schema) = @_; |
173
|
|
|
|
|
|
|
|
174
|
423
|
50
|
|
|
|
901
|
return $schema if ref $schema eq __PACKAGE__; |
175
|
|
|
|
|
|
|
|
176
|
423
|
|
|
|
|
767
|
my $c = _compile $validations, $schema, 64; |
177
|
|
|
|
|
|
|
|
178
|
416
|
|
100
|
|
|
1054
|
$c->{schema}{type} //= 'scalar'; |
179
|
416
|
|
100
|
|
|
1121
|
$c->{schema}{required} //= 1; |
180
|
416
|
|
100
|
|
|
1184
|
$c->{schema}{rmwhitespace} //= 1; |
181
|
416
|
|
100
|
|
|
1194
|
$c->{schema}{unknown} //= 'remove'; |
182
|
|
|
|
|
|
|
|
183
|
416
|
100
|
|
|
|
676
|
if(exists $c->{schema}{sort}) { |
184
|
10
|
|
|
|
|
12
|
my $s = $c->{schema}{sort}; |
185
|
|
|
|
|
|
|
$c->{schema}{sort} = |
186
|
|
|
|
|
|
|
ref $s eq 'CODE' ? $s |
187
|
6
|
|
|
6
|
|
13
|
: $s eq 'str' ? sub { $_[0] cmp $_[1] } |
188
|
22
|
|
|
22
|
|
60
|
: $s eq 'num' ? sub { $_[0] <=> $_[1] } |
189
|
10
|
50
|
|
|
|
53
|
: croak "Unknown value for 'sort': $c->{schema}{sort}"; |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
190
|
|
|
|
|
|
|
} |
191
|
416
|
100
|
100
|
12
|
|
713
|
$c->{schema}{unique} = sub { $_[0] } if $c->{schema}{unique} && !ref $c->{schema}{unique} && !$c->{schema}{sort}; |
|
12
|
|
100
|
|
|
38
|
|
192
|
|
|
|
|
|
|
|
193
|
416
|
|
|
|
|
1054
|
bless $c, __PACKAGE__; |
194
|
|
|
|
|
|
|
} |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
sub _validate_rec { |
198
|
632
|
|
|
632
|
|
809
|
my($c, $input) = @_; |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
# hash keys |
201
|
632
|
100
|
|
|
|
971
|
if($c->{schema}{keys}) { |
202
|
30
|
|
|
|
|
34
|
my @err; |
203
|
30
|
|
|
|
|
33
|
for my $k (keys %{$c->{schema}{keys}}) { |
|
30
|
|
|
|
|
65
|
|
204
|
|
|
|
|
|
|
# We need to overload the '!exists && !required && !default' |
205
|
|
|
|
|
|
|
# scenario a bit, because in that case we should not create the key |
206
|
|
|
|
|
|
|
# in the output. All other cases will be handled just fine by |
207
|
|
|
|
|
|
|
# passing an implicit 'undef'. |
208
|
42
|
|
|
|
|
64
|
my $s = $c->{schema}{keys}{$k}; |
209
|
42
|
100
|
100
|
|
|
143
|
next if !exists $input->{$k} && !$s->{schema}{required} && !exists $s->{schema}{default}; |
|
|
|
100
|
|
|
|
|
210
|
|
|
|
|
|
|
|
211
|
28
|
|
|
|
|
53
|
my $r = _validate($s, $input->{$k}); |
212
|
28
|
|
|
|
|
50
|
$input->{$k} = $r->[0]; |
213
|
28
|
100
|
|
|
|
60
|
if($r->[1]) { |
214
|
8
|
|
|
|
|
14
|
$r->[1]{key} = $k; |
215
|
8
|
|
|
|
|
32
|
push @err, $r->[1]; |
216
|
|
|
|
|
|
|
} |
217
|
|
|
|
|
|
|
} |
218
|
30
|
100
|
|
|
|
81
|
return [$input, { validation => 'keys', errors => \@err }] if @err; |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
# array values |
222
|
624
|
100
|
|
|
|
917
|
if($c->{schema}{values}) { |
223
|
8
|
|
|
|
|
10
|
my @err; |
224
|
8
|
|
|
|
|
24
|
for my $i (0..$#$input) { |
225
|
16
|
|
|
|
|
33
|
my $r = _validate($c->{schema}{values}, $input->[$i]); |
226
|
16
|
|
|
|
|
21
|
$input->[$i] = $r->[0]; |
227
|
16
|
100
|
|
|
|
30
|
if($r->[1]) { |
228
|
2
|
|
|
|
|
3
|
$r->[1]{index} = $i; |
229
|
2
|
|
|
|
|
5
|
push @err, $r->[1]; |
230
|
|
|
|
|
|
|
} |
231
|
|
|
|
|
|
|
} |
232
|
8
|
100
|
|
|
|
22
|
return [$input, { validation => 'values', errors => \@err }] if @err; |
233
|
|
|
|
|
|
|
} |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
# validations |
236
|
622
|
|
|
|
|
657
|
for (@{$c->{validations}}) { |
|
622
|
|
|
|
|
946
|
|
237
|
332
|
|
|
|
|
452
|
my $r = _validate_rec($_, $input); |
238
|
332
|
|
|
|
|
477
|
$input = $r->[0]; |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
return [$input, { |
241
|
|
|
|
|
|
|
# If the error was a custom 'func' object, then make that the primary cause. |
242
|
|
|
|
|
|
|
# This makes it possible for validations to provide their own error objects. |
243
|
96
|
|
|
|
|
476
|
$r->[1]{validation} eq 'func' && (!exists $r->[1]{result} || keys %{$r->[1]} > 2) ? %{$r->[1]} : (error => $r->[1]), |
244
|
|
|
|
|
|
|
validation => $_->{name}, |
245
|
332
|
100
|
100
|
|
|
957
|
}] if $r->[1]; |
|
|
100
|
|
|
|
|
|
246
|
|
|
|
|
|
|
} |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
# func |
249
|
506
|
100
|
|
|
|
769
|
if($c->{schema}{func}) { |
250
|
294
|
|
|
|
|
495
|
my $r = $c->{schema}{func}->($input); |
251
|
294
|
100
|
|
|
|
943
|
return [$input, { %$r, validation => 'func' }] if ref $r eq 'HASH'; |
252
|
198
|
100
|
|
|
|
329
|
return [$input, { validation => 'func', result => $r }] if !$r; |
253
|
|
|
|
|
|
|
} |
254
|
|
|
|
|
|
|
|
255
|
408
|
|
|
|
|
651
|
return [$input] |
256
|
|
|
|
|
|
|
} |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
sub _validate_array { |
260
|
192
|
|
|
192
|
|
285
|
my($c, $input) = @_; |
261
|
|
|
|
|
|
|
|
262
|
192
|
100
|
|
|
|
824
|
return [$input] if $c->{schema}{type} ne 'array'; |
263
|
|
|
|
|
|
|
|
264
|
40
|
100
|
|
|
|
78
|
$input = [sort { $c->{schema}{sort}->($a,$b) } @$input ] if $c->{schema}{sort}; |
|
26
|
|
|
|
|
46
|
|
265
|
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
# Key-based uniqueness |
267
|
40
|
100
|
100
|
|
|
118
|
if($c->{schema}{unique} && ref $c->{schema}{unique} eq 'CODE') { |
|
|
100
|
|
|
|
|
|
268
|
8
|
|
|
|
|
9
|
my %h; |
269
|
8
|
|
|
|
|
15
|
for my $i (0..$#$input) { |
270
|
24
|
|
|
|
|
40
|
my $k = $c->{schema}{unique}->($input->[$i]); |
271
|
24
|
100
|
|
|
|
92
|
return [$input, { validation => 'unique', index_a => $h{$k}, value_a => $input->[$h{$k}], index_b => $i, value_b => $input->[$i], key => $k }] if exists $h{$k}; |
272
|
20
|
|
|
|
|
29
|
$h{$k} = $i; |
273
|
|
|
|
|
|
|
} |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
# Comparison-based uniqueness |
276
|
|
|
|
|
|
|
} elsif($c->{schema}{unique}) { |
277
|
4
|
|
|
|
|
12
|
for my $i (0..$#$input-1) { |
278
|
|
|
|
|
|
|
return [$input, { validation => 'unique', index_a => $i, value_a => $input->[$i], index_b => $i+1, value_b => $input->[$i+1] }] |
279
|
8
|
100
|
|
|
|
12
|
if $c->{schema}{sort}->($input->[$i], $input->[$i+1]) == 0 |
280
|
|
|
|
|
|
|
} |
281
|
|
|
|
|
|
|
} |
282
|
|
|
|
|
|
|
|
283
|
34
|
|
|
|
|
115
|
return [$input] |
284
|
|
|
|
|
|
|
} |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
sub _validate { |
288
|
347
|
|
|
347
|
|
493
|
my($c, $input) = @_; |
289
|
|
|
|
|
|
|
|
290
|
|
|
|
|
|
|
# rmwhitespace (needs to be done before the 'required' test) |
291
|
347
|
100
|
100
|
|
|
1485
|
if(defined $input && !ref $input && $c->{schema}{type} eq 'scalar' && $c->{schema}{rmwhitespace}) { |
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
292
|
206
|
|
|
|
|
422
|
$input =~ s/\r//g; |
293
|
206
|
|
|
|
|
717
|
$input =~ s/^\s*//; |
294
|
206
|
|
|
|
|
1026
|
$input =~ s/\s*$//; |
295
|
|
|
|
|
|
|
} |
296
|
|
|
|
|
|
|
|
297
|
|
|
|
|
|
|
# required & default |
298
|
347
|
100
|
100
|
|
|
1156
|
if(!defined $input || (!ref $input && $input eq '')) { |
|
|
|
100
|
|
|
|
|
299
|
|
|
|
|
|
|
# XXX: This will return undef if !required and no default is set, even for hash and array types. Should those get an empty hash or array? |
300
|
34
|
100
|
|
|
|
121
|
return [exists $c->{schema}{default} ? $c->{schema}{default} : $input] if !$c->{schema}{required}; |
|
|
100
|
|
|
|
|
|
301
|
18
|
|
|
|
|
68
|
return [$input, { validation => 'required' }]; |
302
|
|
|
|
|
|
|
} |
303
|
|
|
|
|
|
|
|
304
|
313
|
100
|
|
|
|
656
|
if($c->{schema}{type} eq 'scalar') { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
305
|
206
|
100
|
|
|
|
330
|
return [$input, { validation => 'type', expected => 'scalar', got => lc ref $input }] if ref $input; |
306
|
|
|
|
|
|
|
|
307
|
|
|
|
|
|
|
} elsif($c->{schema}{type} eq 'hash') { |
308
|
42
|
100
|
100
|
|
|
118
|
return [$input, { validation => 'type', expected => 'hash', got => lc ref $input || 'scalar' }] if ref $input ne 'HASH'; |
309
|
|
|
|
|
|
|
|
310
|
|
|
|
|
|
|
# unknown |
311
|
36
|
100
|
|
|
|
79
|
if($c->{schema}{unknown} eq 'remove') { |
|
|
100
|
|
|
|
|
|
312
|
18
|
|
|
|
|
58
|
$input = { map +($_, $input->{$_}), grep $c->{known_keys}{$_}, keys %$input }; |
313
|
|
|
|
|
|
|
} elsif($c->{schema}{unknown} eq 'reject') { |
314
|
2
|
|
|
|
|
8
|
my @err = grep !$c->{known_keys}{$_}, keys %$input; |
315
|
2
|
50
|
|
|
|
8
|
return [$input, { validation => 'unknown', keys => \@err, expected => [ sort keys %{$c->{known_keys}} ] }] if @err; |
|
2
|
|
|
|
|
13
|
|
316
|
|
|
|
|
|
|
} else { |
317
|
|
|
|
|
|
|
# Make a shallow copy of the hash, so that further validations can |
318
|
|
|
|
|
|
|
# perform in-place modifications without affecting the input. |
319
|
|
|
|
|
|
|
# (The other two if clauses above also ensure this) |
320
|
16
|
|
|
|
|
42
|
$input = { %$input }; |
321
|
|
|
|
|
|
|
} |
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
} elsif($c->{schema}{type} eq 'array') { |
324
|
46
|
100
|
66
|
|
|
87
|
$input = [$input] if $c->{schema}{scalar} && !ref $input; |
325
|
46
|
50
|
50
|
|
|
87
|
return [$input, { validation => 'type', expected => $c->{schema}{scalar} ? 'array or scalar' : 'array', got => lc ref $input || 'scalar' }] if ref $input ne 'ARRAY'; |
|
|
100
|
|
|
|
|
|
326
|
44
|
|
|
|
|
81
|
$input = [@$input]; # Create a shallow copy to prevent in-place modification. |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
} elsif($c->{schema}{type} eq 'any') { |
329
|
|
|
|
|
|
|
# No need to do anything here. |
330
|
|
|
|
|
|
|
|
331
|
|
|
|
|
|
|
} else { |
332
|
1
|
|
|
|
|
70
|
croak "Unknown type '$c->{schema}{type}'"; # Should be checked in _compile(), preferably. |
333
|
|
|
|
|
|
|
} |
334
|
|
|
|
|
|
|
|
335
|
300
|
|
|
|
|
497
|
my $r = _validate_rec($c, $input); |
336
|
300
|
100
|
|
|
|
820
|
return $r if $r->[1]; |
337
|
192
|
|
|
|
|
270
|
$input = $r->[0]; |
338
|
|
|
|
|
|
|
|
339
|
192
|
|
|
|
|
339
|
_validate_array($c, $input); |
340
|
|
|
|
|
|
|
} |
341
|
|
|
|
|
|
|
|
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
sub validate { |
344
|
303
|
100
|
|
303
|
0
|
66761
|
my($c, $input) = ref $_[0] eq __PACKAGE__ ? @_ : (compile($_[0], $_[1]), $_[2]); |
345
|
303
|
|
|
|
|
510
|
bless _validate($c, $input), 'TUWF::Validate::Result'; |
346
|
|
|
|
|
|
|
} |
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
|
349
|
|
|
|
|
|
|
sub analyze { |
350
|
41
|
|
|
41
|
0
|
180
|
require TUWF::Validate::Interop; |
351
|
41
|
|
|
|
|
104
|
TUWF::Validate::Interop::analyze($_[0]); |
352
|
|
|
|
|
|
|
} |
353
|
|
|
|
|
|
|
|
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
package TUWF::Validate::Result; |
357
|
|
|
|
|
|
|
|
358
|
3
|
|
|
3
|
|
22
|
use strict; |
|
3
|
|
|
|
|
8
|
|
|
3
|
|
|
|
|
59
|
|
359
|
3
|
|
|
3
|
|
13
|
use warnings; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
98
|
|
360
|
3
|
|
|
3
|
|
15
|
use Carp 'croak'; |
|
3
|
|
|
|
|
9
|
|
|
3
|
|
|
|
|
193
|
|
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
# A result object contains: [$data, $error] |
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
# In boolean context, returns whether the validation succeeded. |
365
|
3
|
|
|
3
|
|
2996
|
use overload bool => sub { !$_[0][1] }; |
|
3
|
|
|
151
|
|
2504
|
|
|
3
|
|
|
|
|
23
|
|
|
151
|
|
|
|
|
1166
|
|
366
|
|
|
|
|
|
|
|
367
|
|
|
|
|
|
|
# Returns the validation errors, or undef if validation succeeded |
368
|
302
|
|
|
302
|
|
18247
|
sub err { $_[0][1] } |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
# Returns the validated and normalized input, dies if validation didn't succeed. |
371
|
|
|
|
|
|
|
sub data { |
372
|
151
|
100
|
|
151
|
|
338
|
if($_[0][1]) { |
373
|
67
|
|
|
|
|
950
|
require Data::Dumper; |
374
|
67
|
|
|
|
|
5839
|
my $s = Data::Dumper->new([$_[0][1]])->Terse(1)->Pair(':')->Indent(0)->Sortkeys(1)->Dump; |
375
|
67
|
|
|
|
|
11565
|
croak "Validation failed: $s"; |
376
|
|
|
|
|
|
|
} |
377
|
84
|
|
|
|
|
315
|
$_[0][0] |
378
|
|
|
|
|
|
|
} |
379
|
|
|
|
|
|
|
|
380
|
|
|
|
|
|
|
# Same as 'data', but returns partially validated and normalized data if validation failed. |
381
|
302
|
|
|
302
|
|
134660
|
sub unsafe_data { $_[0][0] } |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
# TODO: Human-readable error message formatting |
384
|
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
1; |