File Coverage

lib/Data/Processor/Validator.pm
Criterion Covered Total %
statement 176 183 96.1
branch 68 80 85.0
condition 34 51 66.6
subroutine 17 17 100.0
pod 0 4 0.0
total 295 335 88.0


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;