line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
19
|
|
|
19
|
|
216
|
use 5.10.1; |
|
19
|
|
|
|
|
48
|
|
2
|
19
|
|
|
19
|
|
79
|
use strict; |
|
19
|
|
|
|
|
26
|
|
|
19
|
|
|
|
|
336
|
|
3
|
19
|
|
|
19
|
|
73
|
use warnings; |
|
19
|
|
|
|
|
26
|
|
|
19
|
|
|
|
|
535
|
|
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
package Data::Processor::Validator; |
6
|
|
|
|
|
|
|
|
7
|
19
|
|
|
19
|
|
382
|
use Carp; |
|
19
|
|
|
|
|
28
|
|
|
19
|
|
|
|
|
992
|
|
8
|
19
|
|
|
19
|
|
88
|
use Scalar::Util qw(blessed); |
|
19
|
|
|
|
|
34
|
|
|
19
|
|
|
|
|
650
|
|
9
|
|
|
|
|
|
|
|
10
|
19
|
|
|
19
|
|
109
|
use Data::Processor::Error::Collection; |
|
19
|
|
|
|
|
28
|
|
|
19
|
|
|
|
|
877
|
|
11
|
19
|
|
|
19
|
|
5718
|
use Data::Processor::Transformer; |
|
19
|
|
|
|
|
39
|
|
|
19
|
|
|
|
|
38718
|
|
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
# XXX document this with pod. (if standalone) |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
# Data::Processor::Validator - Validate Data Against a Schema |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
sub new { |
19
|
212
|
|
|
212
|
0
|
351
|
my $class = shift; |
20
|
212
|
|
|
|
|
218
|
my $schema = shift; |
21
|
212
|
|
|
|
|
524
|
my %p = @_; |
22
|
|
|
|
|
|
|
my $self = { |
23
|
|
|
|
|
|
|
schema => $schema // confess ('cannot validate without "schema"'), |
24
|
|
|
|
|
|
|
data => $p{data} // undef, |
25
|
|
|
|
|
|
|
verbose=> $p{verbose} // undef, |
26
|
|
|
|
|
|
|
errors => $p{errors} // Data::Processor::Error::Collection->new(), |
27
|
|
|
|
|
|
|
depth => $p{depth} // 0, |
28
|
|
|
|
|
|
|
indent => $p{indent} // 4, |
29
|
212
|
|
33
|
|
|
1656
|
parent_keys => $p{parent_keys} // ['root'], |
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
30
|
|
|
|
|
|
|
transformer => Data::Processor::Transformer->new(), |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
}; |
33
|
212
|
|
|
|
|
334
|
bless ($self, $class); |
34
|
212
|
|
|
|
|
894
|
return $self; |
35
|
|
|
|
|
|
|
} |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
# (recursively) checks data, or a section thereof, |
38
|
|
|
|
|
|
|
# by instantiating D::P::V objects and calling validate on them |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
sub validate { |
41
|
209
|
|
|
209
|
0
|
872
|
my $self = shift; |
42
|
209
|
|
|
|
|
318
|
$self->{data} = shift; |
43
|
209
|
100
|
|
|
|
518
|
croak ('cannot validate without "data"') unless $self->{data}; |
44
|
208
|
|
|
|
|
394
|
$self->{errors} = Data::Processor::Error::Collection->new(); |
45
|
|
|
|
|
|
|
# caching 'schema_key' to avoid running _schema_twin_key multiple |
46
|
|
|
|
|
|
|
# times since errors will be added to the collection |
47
|
|
|
|
|
|
|
$self->{schema_keys} = { |
48
|
208
|
|
|
|
|
241
|
map { $_ => $self->_schema_twin_key($_) } keys %{$self->{data}} |
|
307
|
|
|
|
|
494
|
|
|
208
|
|
|
|
|
551
|
|
49
|
|
|
|
|
|
|
}; |
50
|
|
|
|
|
|
|
|
51
|
208
|
|
|
|
|
493
|
$self->_add_defaults_and_transform(); |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
my $order = sub { |
54
|
125
|
|
|
125
|
|
204
|
my ($a, $b) = @_; |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
return 1 if !$self->{schema_keys}->{$a} |
57
|
125
|
50
|
66
|
|
|
548
|
|| !$self->{schema}->{$self->{schema_keys}->{$a}}->{order}; |
58
|
|
|
|
|
|
|
return -1 if !$self->{schema_keys}->{$b} |
59
|
0
|
0
|
0
|
|
|
0
|
|| !$self->{schema}->{$self->{schema_keys}->{$b}}->{order}; |
60
|
|
|
|
|
|
|
return $self->{schema}->{$self->{schema_keys}->{$a}}->{order} |
61
|
0
|
|
|
|
|
0
|
<=> $self->{schema}->{$self->{schema_keys}->{$b}}->{order}; |
62
|
208
|
|
|
|
|
746
|
}; |
63
|
|
|
|
|
|
|
|
64
|
208
|
|
|
|
|
253
|
for my $key (sort { $order->($a, $b) } keys %{$self->{data}}) { |
|
125
|
|
|
|
|
166
|
|
|
208
|
|
|
|
|
557
|
|
65
|
309
|
|
|
|
|
756
|
$self->explain (">>'$key'"); |
66
|
|
|
|
|
|
|
|
67
|
309
|
100
|
|
|
|
539
|
my $schema_key = $self->{schema_keys}->{$key} or next; |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
# validate |
70
|
299
|
|
|
|
|
561
|
$self->__value_is_valid( $key ); |
71
|
299
|
|
|
|
|
579
|
$self->__validator_returns_undef($key, $schema_key); |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
# skip if explicitly asked for |
75
|
299
|
50
|
|
|
|
491
|
if ($self->{schema}->{$schema_key}->{no_descend_into}){ |
76
|
0
|
|
|
|
|
0
|
$self->explain ( |
77
|
|
|
|
|
|
|
">>skipping '$key' because schema explicitly says so.\n"); |
78
|
0
|
|
|
|
|
0
|
next; |
79
|
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
# skip data branch if schema key is empty. |
81
|
299
|
100
|
|
|
|
269
|
if (! %{$self->{schema}->{$schema_key}}){ |
|
299
|
|
|
|
|
495
|
|
82
|
7
|
|
|
|
|
19
|
$self->explain (">>skipping '$key' because schema key is empty\n'"); |
83
|
7
|
|
|
|
|
11
|
next; |
84
|
|
|
|
|
|
|
} |
85
|
292
|
100
|
|
|
|
451
|
if (! $self->{schema}->{$schema_key}->{members}){ |
86
|
186
|
|
|
|
|
424
|
$self->explain ( |
87
|
|
|
|
|
|
|
">>not descending into '$key'. No members specified\n" |
88
|
|
|
|
|
|
|
); |
89
|
186
|
|
|
|
|
305
|
next; |
90
|
|
|
|
|
|
|
} |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
# recursion if we reach this point. |
93
|
106
|
|
|
|
|
245
|
$self->explain (">>descending into '$key'\n"); |
94
|
|
|
|
|
|
|
|
95
|
106
|
100
|
66
|
|
|
319
|
if (ref $self->{data}->{$key} eq ref {} ){ |
|
|
100
|
|
|
|
|
|
96
|
101
|
|
|
|
|
276
|
$self->explain |
97
|
|
|
|
|
|
|
(">>'$key' is not a leaf and we descend into it\n"); |
98
|
|
|
|
|
|
|
my $e = Data::Processor::Validator->new( |
99
|
|
|
|
|
|
|
$self->{schema}->{$schema_key}->{members}, |
100
|
101
|
|
|
|
|
318
|
parent_keys => [@{$self->{parent_keys}}, $key], |
101
|
|
|
|
|
|
|
depth => $self->{depth}+1, |
102
|
|
|
|
|
|
|
verbose => $self->{verbose}, |
103
|
|
|
|
|
|
|
|
104
|
101
|
|
|
|
|
161
|
) ->validate($self->{data}->{$key}); |
105
|
101
|
|
|
|
|
548
|
$self->{errors}->add_collection($e); |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
} |
108
|
|
|
|
|
|
|
elsif ((ref $self->{data}->{$key} eq ref []) |
109
|
|
|
|
|
|
|
&& $self->{schema}->{$schema_key}->{array}){ |
110
|
|
|
|
|
|
|
|
111
|
2
|
|
|
|
|
9
|
$self->explain( |
112
|
|
|
|
|
|
|
">>'$key' is an array reference so we check all elements\n"); |
113
|
2
|
|
|
|
|
4
|
for my $member (@{$self->{data}->{$key}}){ |
|
2
|
|
|
|
|
5
|
|
114
|
|
|
|
|
|
|
next if !defined $member |
115
|
5
|
50
|
66
|
|
|
15
|
&& $self->{schema}->{$schema_key}->{allow_empty}; |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
my $e = Data::Processor::Validator->new( |
118
|
|
|
|
|
|
|
$self->{schema}->{$schema_key}->{members}, |
119
|
4
|
|
|
|
|
12
|
parent_keys => [@{$self->{parent_keys}}, $key], |
120
|
|
|
|
|
|
|
depth => $self->{depth}+1, |
121
|
|
|
|
|
|
|
verbose => $self->{verbose}, |
122
|
|
|
|
|
|
|
|
123
|
4
|
|
|
|
|
7
|
) ->validate($member); |
124
|
4
|
|
|
|
|
20
|
$self->{errors}->add_collection($e); |
125
|
|
|
|
|
|
|
} |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
# Make sure that key in data is a leaf in schema. |
128
|
|
|
|
|
|
|
# We cannot descend into a non-existing branch in data |
129
|
|
|
|
|
|
|
# but it might be required by the schema. |
130
|
|
|
|
|
|
|
else { |
131
|
3
|
|
|
|
|
14
|
$self->explain(">>checking data key '$key' which is a leaf.."); |
132
|
3
|
50
|
|
|
|
7
|
if ($self->{schema}->{$schema_key}->{members}){ |
133
|
3
|
|
|
|
|
7
|
$self->explain("but schema requires members.\n"); |
134
|
3
|
|
|
|
|
10
|
$self->error("'$key' should have members"); |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
else { |
137
|
0
|
|
|
|
|
0
|
$self->explain("schema key is also a leaf. ok.\n"); |
138
|
|
|
|
|
|
|
} |
139
|
|
|
|
|
|
|
} |
140
|
|
|
|
|
|
|
} |
141
|
|
|
|
|
|
|
# look for missing non-optional keys in schema |
142
|
|
|
|
|
|
|
# this is only done on this level. |
143
|
|
|
|
|
|
|
# Otherwise "mandatory" inherited "upwards". |
144
|
208
|
|
|
|
|
410
|
$self->_check_mandatory_keys(); |
145
|
208
|
|
|
|
|
1076
|
return $self->{errors}; |
146
|
|
|
|
|
|
|
} |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
################# |
149
|
|
|
|
|
|
|
# internal methods |
150
|
|
|
|
|
|
|
################# |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
# add an error |
153
|
|
|
|
|
|
|
sub error { |
154
|
40
|
|
|
40
|
0
|
55
|
my $self = shift; |
155
|
40
|
|
|
|
|
68
|
my $string = shift; |
156
|
|
|
|
|
|
|
$self->{errors}->add( |
157
|
|
|
|
|
|
|
message => $string, |
158
|
|
|
|
|
|
|
path => $self->{parent_keys}, |
159
|
40
|
|
|
|
|
128
|
); |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
# explains what we are doing. |
163
|
|
|
|
|
|
|
sub explain { |
164
|
4314
|
|
|
4314
|
0
|
3959
|
my $self = shift; |
165
|
4314
|
|
|
|
|
3741
|
my $string = shift; |
166
|
4314
|
|
|
|
|
5003
|
my $indent = ' ' x ($self->{depth}*$self->{indent}); |
167
|
4314
|
|
|
|
|
6418
|
$string =~ s/>>/$indent/; |
168
|
4314
|
100
|
|
|
|
7906
|
print $string if $self->{verbose}; |
169
|
|
|
|
|
|
|
} |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
# add defaults and transform. Go over all keys *on that level* |
173
|
|
|
|
|
|
|
# and if there is not a value (or, most oftenly, a key) in data, |
174
|
|
|
|
|
|
|
# add the key and the default value. |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
sub _add_defaults_and_transform { |
177
|
208
|
|
|
208
|
|
213
|
my $self = shift; |
178
|
|
|
|
|
|
|
|
179
|
208
|
|
|
|
|
199
|
for my $key (keys %{$self->{schema}}){ |
|
208
|
|
|
|
|
584
|
|
180
|
1442
|
100
|
|
|
|
2023
|
next unless defined $self->{schema}->{$key}->{default}; |
181
|
|
|
|
|
|
|
$self->{data}->{$key} = $self->{schema}->{$key}->{default} |
182
|
4
|
100
|
|
|
|
9
|
unless defined $self->{data}->{$key}; |
183
|
|
|
|
|
|
|
} |
184
|
|
|
|
|
|
|
|
185
|
208
|
|
|
|
|
265
|
for my $key (keys %{$self->{data}}){ |
|
208
|
|
|
|
|
327
|
|
186
|
309
|
100
|
|
|
|
505
|
my $schema_key = $self->{schema_keys}->{$key} or next; |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
# transformer |
189
|
299
|
|
|
|
|
540
|
my $e = $self->{transformer}->transform($key, $schema_key, $self); |
190
|
299
|
100
|
|
|
|
512
|
$self->error($e) if $e; |
191
|
|
|
|
|
|
|
} |
192
|
|
|
|
|
|
|
} |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
# check mandatory: look for mandatory fields in all hashes 1 level |
195
|
|
|
|
|
|
|
# below current level (in schema) |
196
|
|
|
|
|
|
|
# for each check if $data has a key. |
197
|
|
|
|
|
|
|
sub _check_mandatory_keys{ |
198
|
208
|
|
|
208
|
|
213
|
my $self = shift; |
199
|
|
|
|
|
|
|
|
200
|
208
|
|
|
|
|
181
|
for my $key (keys %{$self->{schema}}){ |
|
208
|
|
|
|
|
515
|
|
201
|
1442
|
|
|
|
|
2543
|
$self->explain(">>Checking if '$key' is mandatory: "); |
202
|
1442
|
100
|
66
|
|
|
3459
|
unless ($self->{schema}->{$key}->{optional} |
203
|
|
|
|
|
|
|
and $self->{schema}->{$key}->{optional}){ |
204
|
|
|
|
|
|
|
|
205
|
88
|
|
|
|
|
172
|
$self->explain("true\n"); |
206
|
88
|
100
|
|
|
|
177
|
next if defined $self->{data}->{$key}; |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
# regex-keys never directly occur. |
209
|
20
|
100
|
|
|
|
36
|
if ($self->{schema}->{$key}->{regex}){ |
210
|
10
|
|
|
|
|
45
|
$self->explain(">>regex enabled key found. "); |
211
|
10
|
|
|
|
|
21
|
$self->explain("Checking data keys.. "); |
212
|
10
|
|
|
|
|
14
|
my $c = 0; |
213
|
|
|
|
|
|
|
# look which keys match the regex |
214
|
10
|
|
|
|
|
11
|
for my $c_key (keys %{$self->{data}}){ |
|
10
|
|
|
|
|
19
|
|
215
|
19
|
100
|
|
|
|
124
|
$c++ if $c_key =~ /$key/; |
216
|
|
|
|
|
|
|
} |
217
|
10
|
|
|
|
|
58
|
$self->explain("$c matching occurencies found\n"); |
218
|
10
|
100
|
|
|
|
38
|
next if $c > 0; |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
# should only get here in case of error. |
222
|
11
|
|
|
|
|
14
|
my $error_msg = ''; |
223
|
|
|
|
|
|
|
$error_msg = $self->{schema}->{$key}->{error_msg} |
224
|
11
|
100
|
|
|
|
35
|
if $self->{schema}->{$key}->{error_msg}; |
225
|
|
|
|
|
|
|
|
226
|
11
|
|
|
|
|
15
|
my $error_clause = ''; |
227
|
11
|
100
|
|
|
|
16
|
if( $error_msg ){ |
228
|
4
|
|
|
|
|
8
|
$error_clause = " Error msg: '$error_msg'"; |
229
|
|
|
|
|
|
|
} |
230
|
|
|
|
|
|
|
|
231
|
11
|
|
|
|
|
36
|
$self->error("mandatory key '$key' missing.".$error_clause); |
232
|
|
|
|
|
|
|
} |
233
|
|
|
|
|
|
|
else{ |
234
|
1354
|
|
|
|
|
1625
|
$self->explain("false\n"); |
235
|
|
|
|
|
|
|
} |
236
|
|
|
|
|
|
|
} |
237
|
|
|
|
|
|
|
} |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
# find key to validate (section of) data against |
240
|
|
|
|
|
|
|
sub _schema_twin_key{ |
241
|
307
|
|
|
307
|
|
306
|
my $self = shift; |
242
|
307
|
|
|
|
|
307
|
my $key = shift; |
243
|
|
|
|
|
|
|
|
244
|
307
|
|
|
|
|
264
|
my $schema_key; |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
# direct match: exact declaration |
247
|
307
|
100
|
|
|
|
487
|
if ($self->{schema}->{$key}){ |
248
|
201
|
|
|
|
|
312
|
$self->explain(" ok\n"); |
249
|
201
|
|
|
|
|
201
|
$schema_key = $key; |
250
|
|
|
|
|
|
|
} |
251
|
|
|
|
|
|
|
# match against a pattern |
252
|
|
|
|
|
|
|
else { |
253
|
106
|
|
|
|
|
104
|
my $match; |
254
|
106
|
|
|
|
|
105
|
for my $match_key (keys %{$self->{schema}}){ |
|
106
|
|
|
|
|
236
|
|
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
# only try to match a key if it has the property |
257
|
|
|
|
|
|
|
# _regex_ set |
258
|
|
|
|
|
|
|
next unless exists $self->{schema}->{$match_key} |
259
|
148
|
100
|
66
|
|
|
466
|
and $self->{schema}->{$match_key}->{regex}; |
260
|
|
|
|
|
|
|
|
261
|
104
|
100
|
|
|
|
664
|
if ($key =~ /$match_key/){ |
262
|
98
|
|
|
|
|
318
|
$self->explain("'$key' matches $match_key\n"); |
263
|
98
|
|
|
|
|
165
|
$schema_key = $match_key; |
264
|
|
|
|
|
|
|
} |
265
|
|
|
|
|
|
|
} |
266
|
|
|
|
|
|
|
} |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
# if $schema_key is still undef we were unable to |
269
|
|
|
|
|
|
|
# match it against a key in the schema. |
270
|
307
|
100
|
|
|
|
449
|
unless ($schema_key){ |
271
|
8
|
|
|
|
|
46
|
$self->explain(">>$key not in schema, keys available: "); |
272
|
8
|
|
|
|
|
13
|
$self->explain(join (", ", (keys %{$self->{schema}}))); |
|
8
|
|
|
|
|
32
|
|
273
|
8
|
|
|
|
|
18
|
$self->explain("\n"); |
274
|
8
|
|
|
|
|
30
|
$self->error("key '$key' not found in schema\n"); |
275
|
|
|
|
|
|
|
} |
276
|
307
|
|
|
|
|
827
|
return $schema_key |
277
|
|
|
|
|
|
|
} |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
# 'validator' specified gets this called to call the callback :-) |
280
|
|
|
|
|
|
|
sub __validator_returns_undef { |
281
|
299
|
|
|
299
|
|
284
|
my $self = shift; |
282
|
299
|
|
|
|
|
277
|
my $key = shift; |
283
|
299
|
|
|
|
|
279
|
my $schema_key = shift; |
284
|
299
|
100
|
|
|
|
520
|
return unless $self->{schema}->{$schema_key}->{validator}; |
285
|
153
|
|
50
|
|
|
575
|
$self->explain("running validator for '$key': ".($self->{data}->{$key} // '(undefined)').": \n"); |
286
|
|
|
|
|
|
|
|
287
|
153
|
100
|
100
|
|
|
508
|
if (ref $self->{data}->{$key} eq ref [] |
288
|
|
|
|
|
|
|
&& $self->{schema}->{$schema_key}->{array}){ |
289
|
|
|
|
|
|
|
|
290
|
3
|
|
|
|
|
5
|
my $counter = 0; |
291
|
3
|
|
|
|
|
13
|
for my $elem (@{$self->{data}{$key}}){ |
|
3
|
|
|
|
|
17
|
|
292
|
|
|
|
|
|
|
next if !defined $elem |
293
|
7
|
0
|
33
|
|
|
31
|
&& $self->{schema}{$schema_key}{allow_empty}; |
294
|
|
|
|
|
|
|
|
295
|
7
|
|
|
|
|
46
|
my $return_value = $self->{schema}{$schema_key}{validator}($elem, $self->{data}); |
296
|
7
|
100
|
|
|
|
56
|
if ($return_value){ |
297
|
3
|
|
|
|
|
11
|
$self->explain("validator error: $return_value (element $counter)\n"); |
298
|
3
|
|
|
|
|
11
|
$self->error("Execution of validator for '$key' element $counter returns with error: $return_value"); |
299
|
|
|
|
|
|
|
} |
300
|
|
|
|
|
|
|
else { |
301
|
4
|
|
|
|
|
13
|
$self->explain("successful validation for key '$key' element $counter\n"); |
302
|
|
|
|
|
|
|
} |
303
|
7
|
|
|
|
|
12
|
$counter++; |
304
|
|
|
|
|
|
|
} |
305
|
|
|
|
|
|
|
} |
306
|
|
|
|
|
|
|
else { |
307
|
150
|
|
|
|
|
193
|
my $validator = $self->{schema}->{$schema_key}->{validator}; |
308
|
150
|
|
|
|
|
144
|
my $return_value; |
309
|
150
|
100
|
|
|
|
321
|
if (defined blessed $validator){ |
310
|
6
|
|
|
|
|
17
|
$return_value = $validator->validate($self->{data}{$key}); |
311
|
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
else { |
313
|
144
|
|
|
|
|
336
|
$return_value = $validator->($self->{data}->{$key}, $self->{data}); |
314
|
|
|
|
|
|
|
} |
315
|
150
|
100
|
|
|
|
6979
|
if ($return_value){ |
316
|
12
|
|
|
|
|
38
|
$self->explain("validator error: $return_value\n"); |
317
|
12
|
|
|
|
|
39
|
$self->error("Execution of validator for '$key' returns with error: $return_value"); |
318
|
|
|
|
|
|
|
} |
319
|
|
|
|
|
|
|
else { |
320
|
138
|
|
|
|
|
306
|
$self->explain("successful validation for key '$key'\n"); |
321
|
|
|
|
|
|
|
} |
322
|
|
|
|
|
|
|
} |
323
|
|
|
|
|
|
|
} |
324
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
# called by validate to check if a value is in line with definitions |
326
|
|
|
|
|
|
|
# in the schema. |
327
|
|
|
|
|
|
|
sub __value_is_valid{ |
328
|
299
|
|
|
299
|
|
292
|
my $self = shift; |
329
|
299
|
|
|
|
|
310
|
my $key = shift; |
330
|
|
|
|
|
|
|
|
331
|
299
|
100
|
100
|
|
|
877
|
if (exists $self->{schema}->{$key} |
332
|
|
|
|
|
|
|
and $self->{schema}->{$key}->{value}){ |
333
|
14
|
|
|
|
|
41
|
$self->explain('>>'.ref($self->{schema}->{$key}->{value})."\n"); |
334
|
|
|
|
|
|
|
|
335
|
|
|
|
|
|
|
# currently, 2 type of restrictions are supported: |
336
|
|
|
|
|
|
|
# (callback) code and regex |
337
|
14
|
50
|
|
|
|
48
|
if (ref($self->{schema}->{$key}->{value}) eq 'CODE'){ |
|
|
50
|
|
|
|
|
|
338
|
|
|
|
|
|
|
# possibly never implement this because of new "validator" |
339
|
|
|
|
|
|
|
} |
340
|
|
|
|
|
|
|
elsif (ref($self->{schema}->{$key}->{value}) eq 'Regexp'){ |
341
|
14
|
100
|
66
|
|
|
87
|
if (ref $self->{data}->{$key} eq ref [] |
342
|
|
|
|
|
|
|
&& $self->{schema}{$key}{array}){ |
343
|
|
|
|
|
|
|
|
344
|
1
|
|
|
|
|
2
|
for my $elem (@{$self->{data}{$key}}){ |
|
1
|
|
|
|
|
4
|
|
345
|
|
|
|
|
|
|
next if !defined $elem |
346
|
5
|
0
|
33
|
|
|
10
|
&& $self->{schema}{$key}{allow_empty}; |
347
|
|
|
|
|
|
|
|
348
|
5
|
|
|
|
|
24
|
$self->explain(">>match '$elem' against '$self->{schema}->{$key}->{value}'"); |
349
|
|
|
|
|
|
|
|
350
|
5
|
100
|
|
|
|
62
|
if ($elem =~ m/^$self->{schema}{$key}{value}$/){ |
351
|
4
|
|
|
|
|
10
|
$self->explain(" ok.\n"); |
352
|
|
|
|
|
|
|
} |
353
|
|
|
|
|
|
|
else{ |
354
|
|
|
|
|
|
|
# XXX never reach this? |
355
|
1
|
|
|
|
|
4
|
$self->explain(" no.\n"); |
356
|
1
|
|
|
|
|
5
|
$self->error("$elem does not match ^$self->{schema}->{$key}->{value}\$"); |
357
|
|
|
|
|
|
|
} |
358
|
|
|
|
|
|
|
} |
359
|
|
|
|
|
|
|
} |
360
|
|
|
|
|
|
|
# XXX this was introduced to support arrays. |
361
|
|
|
|
|
|
|
else { |
362
|
13
|
|
|
|
|
58
|
$self->explain(">>match '$self->{data}->{$key}' against '$self->{schema}->{$key}->{value}'"); |
363
|
|
|
|
|
|
|
|
364
|
13
|
100
|
|
|
|
208
|
if ($self->{data}->{$key} =~ m/^$self->{schema}->{$key}->{value}$/){ |
365
|
12
|
|
|
|
|
40
|
$self->explain(" ok.\n"); |
366
|
|
|
|
|
|
|
} |
367
|
|
|
|
|
|
|
else{ |
368
|
|
|
|
|
|
|
# XXX never reach this? |
369
|
1
|
|
|
|
|
3
|
$self->explain(" no.\n"); |
370
|
1
|
|
|
|
|
4
|
$self->error("$self->{data}->{$key} does not match ^$self->{schema}->{$key}->{value}\$"); |
371
|
|
|
|
|
|
|
} |
372
|
|
|
|
|
|
|
} |
373
|
|
|
|
|
|
|
} |
374
|
|
|
|
|
|
|
else{ |
375
|
|
|
|
|
|
|
# XXX match literally? How much sense does this make?! |
376
|
|
|
|
|
|
|
# also, this is not tested |
377
|
|
|
|
|
|
|
|
378
|
0
|
|
|
|
|
|
$self->explain("neither CODE nor Regexp\n"); |
379
|
0
|
|
|
|
|
|
$self->error("'$key' not CODE nor Regexp"); |
380
|
|
|
|
|
|
|
} |
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
} |
383
|
|
|
|
|
|
|
} |
384
|
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
1; |