File Coverage

lib/JSV/Compiler.pm
Criterion Covered Total %
statement 381 438 86.9
branch 132 186 70.9
condition 103 163 63.1
subroutine 36 36 100.0
pod 3 3 100.0
total 655 826 79.3


line stmt bran cond sub pod time code
1             package JSV::Compiler;
2 8     8   1046616 use strict;
  8         59  
  8         233  
3 8     8   45 use warnings;
  8         15  
  8         195  
4 8     8   4143 use JSON;
  8         66741  
  8         41  
5 8     8   4032 use JSON::Pointer;
  8         82207  
  8         245  
6 8     8   4201 use URI;
  8         20914  
  8         247  
7 8     8   6268 use Path::Tiny;
  8         86739  
  8         443  
8 8     8   69 use Carp;
  8         16  
  8         432  
9 8     8   5112 use Storable 'dclone';
  8         24986  
  8         509  
10 8     8   66 use Data::Dumper;
  8         23  
  8         427  
11 8     8   4193 use Regexp::Common('RE_ALL', 'Email::Address', 'URI', 'time');
  8         20743  
  8         34  
12 8     8   1547604 use Scalar::Util qw(looks_like_number blessed weaken reftype);
  8         24  
  8         43928  
13              
14             our $VERSION = "0.06";
15              
16             sub new {
17 8     8 1 715 my ($class, %args) = @_;
18 8         118 bless {
19             original_schema => {},
20             full_schema => {},
21             }, $class;
22             }
23              
24             sub load_schema {
25 26     26 1 41031 my ($self, $file) = @_;
26 26 50       91 if ('HASH' eq ref $file) {
27 26         82 $self->{original_schema} = $file;
28             } else {
29 0 0       0 croak "Unreadable file" if !-r $file;
30 0 0 0     0 if ($file =~ /\.yaml$/i || $file =~ /\.yml$/i) {
    0          
31 0         0 require YAML::XS;
32 0         0 $self->{original_schema} = YAML::XS::LoadFile($file);
33             } elsif ($file =~ /\.json/i) {
34 0         0 $self->{original_schema} = decode_json(path($file)->slurp_raw);
35             } else {
36 0         0 croak "Unknown file type: must be .json or .yaml";
37             }
38             }
39 26         79 return $self->_resolve_references;
40             }
41              
42             sub _deep_walk {
43 26     26   55 my $visitor = shift;
44 26         37 my $recurse;
45             ## no critic (Variables::RequireInitializationForLocalVars)
46 26         41 local $_;
47             $recurse = sub {
48 137     137   221 my ($cnode) = @_;
49 137         301 my $ctype = reftype $cnode;
50 137 100       327 if ($ctype eq 'ARRAY') {
    50          
51 37         56 my $index = 0;
52 37         68 for (@$cnode) {
53 70         137 my $dtype = reftype $_;
54 70 100 66     219 if ($dtype && ($dtype eq 'HASH' || $dtype eq 'ARRAY')) {
      66        
55 21         50 $recurse->($_, $cnode);
56             }
57 70         130 $visitor->($ctype, $cnode, $index++);
58             }
59             } elsif ($ctype eq 'HASH') {
60 100         248 for my $k (keys %$cnode) {
61 157         260 local $_ = $cnode->{$k};
62 157         319 my $dtype = reftype $_;
63 157 100 100     456 if ($dtype && ($dtype eq 'HASH' || $dtype eq 'ARRAY')) {
      100        
64 90         212 $recurse->($_, $cnode);
65             }
66 157         260 $visitor->($ctype, $cnode, $k);
67             }
68             }
69 26         92 };
70 26         77 $recurse->($_[0]);
71 26         47 $_ = $_[0];
72 26         67 $visitor->('ARRAY', \@_, 0);
73             }
74              
75             sub _resolve_references { ## no critic (Subroutines::ProhibitExcessComplexity)
76 26     26   43 my $self = $_[0];
77 26         2062 $self->{full_schema} = dclone $self->{original_schema};
78 26   66     184 my $base_uri = $self->{full_schema}{id} || $self->{full_schema}{'$id'};
79 26 100       71 if ($base_uri) {
80 1         5 $base_uri = URI->new($base_uri)->canonical();
81 1 50       164 $base_uri->fragment("") if not $base_uri->fragment;
82 1         31 $self->{schemas}{$base_uri} = $self->{full_schema};
83             }
84 26         51 my @unresolved;
85             my %unresolved;
86             my $resolve = sub {
87 10     10   19 my ($ref) = @_;
88 10 100       38 my $uri = $base_uri ? URI->new_abs($ref, $base_uri)->canonical : URI->new($ref)->canonical;
89 10 100       10291 return $self->{schemas}{$uri} if $self->{schemas}{$uri};
90 8         59 my $su = $uri->clone;
91 8         57 $su->fragment("");
92 8 100       162 if ($self->{schemas}{$su}) {
93 4         23 my $rs = JSON::Pointer->get($self->{schemas}{$su}, $uri->fragment);
94 4 50       763 return $rs if $rs;
95             }
96 4 100       24 push @unresolved, "$su" if not $unresolved{$su}++;
97 4         48 return undef;
98 26         153 };
99             _deep_walk(
100             sub {
101 253     253   442 my ($ctype, $cnode, $index) = @_;
102 253 100 100     1279 if ( $ctype eq 'ARRAY'
    100 100        
      100        
      66        
103             && 'HASH' eq ref $_
104             && keys %$_ == 1
105             && $_->{'$ref'}
106             && !ref($_->{'$ref'}))
107             {
108 4         11 weaken($cnode->[$index] = $resolve->($_->{'$ref'}));
109             } elsif ('HASH' eq ref $_) {
110 96         238 for my $k (keys %$_) {
111 153         239 my $v = $_->{$k};
112 153 100 100     1029 if ('HASH' eq ref($v) && keys(%$v) == 1 && $v->{'$ref'} && !ref($v->{'$ref'})) {
    100 100        
    100 66        
      66        
      66        
      66        
113 2         7 weaken($_->{$k} = $resolve->($v->{'$ref'}));
114             } elsif ($k eq '$ref' && !ref($_->{$k})) {
115 4         9 my $r = $resolve->($_->{$k});
116 4 100 66     38 if ($r && 'HASH' eq ref $r) {
117 2         14 weaken($cnode->{$index} = $r);
118             }
119             } elsif (($k eq 'id' || $k eq '$id') && !ref($v)) {
120 1 50       5 my $id = $base_uri ? URI->new_abs($v, $base_uri)->canonical : URI->new($v)->canonical;
121 1 50       194 weaken($self->{schemas}{$id} = $_) if not $self->{schemas}{$id};
122             }
123             }
124             }
125             },
126             $self->{full_schema}
127 26         150 );
128 26 100       138 return wantarray ? @unresolved : $self;
129             }
130              
131             sub compile {
132 27     27 1 3470 my ($self, %opts) = @_;
133             ## no critic (Variables::ProhibitLocalVars)
134 27   66     186 local $self->{coercion} = $opts{coercion} // $opts{coersion} // 0;
      100        
135 27   50     116 local $self->{to_json} = $opts{to_json} // 0;
136 27         74 $self->{required_modules} = {};
137 27   50     102 my $input_sym = $opts{input_symbole} // '$_[0]';
138 27         77 my $schema = _norm_schema($self->{full_schema});
139 27   66     90 my $type = $schema->{type} // _guess_schema_type($schema);
140 27   100     139 my $is_required = $opts{is_required} // $type eq 'object' || 0;
141 27         68 my $val_func = "_validate_$type";
142 27         102 my $val_expr = $self->$val_func($input_sym, $schema, "", $is_required);
143             return
144             wantarray
145 27 100       133 ? ($val_expr, map {$_ => [sort keys %{$self->{required_modules}{$_}}]} keys %{$self->{required_modules}})
  17         25  
  17         160  
  26         127  
146             : $val_expr;
147             }
148              
149             # type: six primitive types ("null", "boolean", "object", "array", "number", or "string"), or "integer"
150              
151             sub _norm_schema {
152 217     217   308 my $shmpt = $_[0];
153             return +{
154 217 100       505 type => _guess_schema_type($shmpt),
155             const => $shmpt
156             } if 'HASH' ne ref $shmpt;
157 191         319 $shmpt;
158             }
159              
160             sub _guess_schema_type { ## no critic (Subroutines::ProhibitExcessComplexity)
161 68     68   100 my $shmpt = $_[0];
162 68 100       203 if (my $class = blessed($shmpt)) {
163 26 50       105 if ($class =~ /bool/i) {
164 26         104 return 'boolean';
165             } else {
166 0         0 return 'object';
167             }
168             }
169 42 50       112 if ('HASH' ne ref $shmpt) {
170 0 0       0 return 'number' if looks_like_number($shmpt);
171 0         0 return 'string';
172             }
173 42 50       91 return $shmpt->{type} if $shmpt->{type};
174             return 'object'
175             if defined $shmpt->{additionalProperties}
176             or $shmpt->{patternProperties}
177             or $shmpt->{properties}
178             or defined $shmpt->{minProperties}
179 42 50 33     358 or defined $shmpt->{maxProperties};
      66        
      66        
      66        
180             return 'array'
181             if defined $shmpt->{additionalItems}
182             or defined $shmpt->{uniqueItems}
183             or $shmpt->{items}
184             or defined $shmpt->{minItems}
185 36 50 33     291 or defined $shmpt->{maxItems};
      33        
      33        
      33        
186             return 'number'
187             if defined $shmpt->{minimum}
188             or defined $shmpt->{maximum}
189             or exists $shmpt->{exclusiveMinimum}
190             or exists $shmpt->{exclusiveMaximum}
191 36 50 100     246 or defined $shmpt->{multipleOf};
      66        
      33        
      33        
192 32         87 return 'string';
193             }
194              
195             sub _quote_var {
196 81     81   123 my $s = $_[0];
197 81         280 my $d = Data::Dumper->new([$s]);
198 81         2006 $d->Terse(1);
199 81         482 my $qs = $d->Dump;
200 81 50       1199 substr($qs, -1, 1, '') if substr($qs, -1, 1) eq "\n";
201 81         417 return $qs;
202             }
203              
204             #<<<
205             my %formats = (
206             'date-time' => $RE{time}{iso},
207             email => $RE{Email}{Address},
208             uri => $RE{URI},
209             hostname => '(?:(?:(?:(?:[a-zA-Z0-9][-a-zA-Z0-9]*)?[a-zA-Z0-9])[.])*'
210             . '(?:[a-zA-Z][-a-zA-Z0-9]*[a-zA-Z0-9]|[a-zA-Z])[.]?)',
211             ipv4 => $RE{net}{IPv4},
212             ipv6 => $RE{net}{IPv6},
213             );
214             #>>>
215              
216             ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
217             sub _validate_null {
218 1     1   4 my ($self, $sympt, $schmptm, $path) = @_;
219 1         5 my @sp = split /->/, $sympt;
220 1         3 my $el = pop @sp;
221 1         3 my $sh = join "->", @sp;
222 1 50       5 my $ec = $sh ? "|| ('HASH' eq ref($sh) && !exists ($sympt))" : '';
223 1         7 return "push \@\$errors, \"$path must be null\" if defined($sympt) $ec;\n";
224             }
225              
226             sub _validate_boolean {
227 30     30   77 my ($self, $sympt, $schmpt, $path, $is_required) = @_;
228 30         55 $schmpt = _norm_schema($schmpt);
229 30         48 my $r = '';
230 30 50       66 if (exists $schmpt->{default}) {
231 0         0 my $val = _quote_var($schmpt->{default});
232 0         0 $r = "$sympt = $val if not defined $sympt;\n";
233             }
234 30         79 $r .= "if(defined($sympt)) {\n";
235 30         69 $r .= $self->_validate_schemas_array($sympt, $schmpt, $path);
236 30 100       68 if (defined $schmpt->{const}) {
237 26         52 $r .= " { no warnings 'uninitialized';\n";
238 26 100       81 my $not = $schmpt->{const} ? 'not' : "";
239 26         239 $r .= " push \@\$errors, \"$path must be \".($schmpt->{const}?'true':'false') if $not $sympt \n";
240 26         160 $r .= " }\n";
241             }
242 30 50       86 if ($self->{to_json}) {
    100          
243 0         0 $r .= " $sympt = (($sympt)? \\1: \\0);\n";
244             } elsif ($self->{coercion}) {
245 1         4 $r .= " $sympt = (($sympt)? 1: 0);\n";
246             }
247 30         52 $r .= "}\n";
248 30 100       55 if ($is_required) {
249 26         43 $r .= "else {\n";
250 26         48 $r .= " push \@\$errors, \"$path is required\";\n";
251 26         43 $r .= "}\n";
252             }
253 30         81 return $r;
254             }
255              
256             sub _validate_string {
257 61     61   171 my ($self, $sympt, $schmpt, $path, $is_required) = @_;
258 61         117 $schmpt = _norm_schema($schmpt);
259 61         106 my $r = '';
260 61 50       128 if (defined $schmpt->{default}) {
261 0         0 my $val = _quote_var($schmpt->{default});
262 0         0 $r = "$sympt = $val if not defined $sympt;\n";
263             }
264 61         148 $r .= "if(defined($sympt)) {\n";
265 61         145 $r .= $self->_validate_schemas_array($sympt, $schmpt, $path);
266 61 100       173 if (defined $schmpt->{maxLength}) {
267 2         6 $r .= " push \@\$errors, '$path length must be not greater than ";
268 2         9 $r .= "$schmpt->{maxLength}' if length($sympt) > $schmpt->{maxLength};\n";
269             }
270 61 100       122 if (defined $schmpt->{minLength}) {
271 2         8 $r .= " push \@\$errors, '$path length must be not less than ";
272 2         8 $r .= "$schmpt->{minLength}' if length($sympt) < $schmpt->{minLength};\n";
273             }
274 61 50       123 if (defined $schmpt->{const}) {
275 0         0 my $val = _quote_var($schmpt->{const});
276 0         0 $r .= " push \@\$errors, \"$path must be $schmpt->{const}\" if $sympt ne $val;\n";
277             }
278 61 100       127 if (defined $schmpt->{pattern}) {
279 6         10 my $pattern = $schmpt->{pattern};
280 6         16 $pattern =~ s/\\Q(.*?)\\E/quotemeta($1)/eg;
  0         0  
281 6         9 $pattern =~ s/\\Q(.*)$/quotemeta($1)/eg;
  0         0  
282 6         10 $pattern =~ s/"/\\"/g;
283 6         19 $pattern =~ s|/|\\/|g;
284 6         20 $r .= " push \@\$errors, \"$path does not match pattern\" if $sympt !~ /$pattern/;\n";
285             }
286 61 50 66     163 if ($schmpt->{enum} && 'ARRAY' eq ref($schmpt->{enum}) && @{$schmpt->{enum}}) {
  10   66     38  
287 10         19 my $can_list = join ", ", map {_quote_var($_)} @{$schmpt->{enum}};
  14         21  
  10         21  
288 10         26 $self->{required_modules}{'List::Util'}{none} = 1;
289 10         29 $r .= " push \@\$errors, \"$path must be on of $can_list\" if none {\$_ eq $sympt} ($can_list);\n";
290             }
291 61 100 66     197 if ($schmpt->{format} && $formats{$schmpt->{format}}) {
292 6         1435 $r .= " push \@\$errors, \"$path does not match format $schmpt->{format}\"";
293 6         20 $r .= " if $sympt !~ /^$formats{$schmpt->{format}}\$/;\n";
294             }
295 61 100 66     604 if ($self->{to_json} || $self->{coercion}) {
296 1         4 $r .= " $sympt = \"$sympt\";\n";
297             }
298 61         110 $r .= "}\n";
299 61 100       131 if ($is_required) {
300 32         49 $r .= "else {\n";
301 32         78 $r .= " push \@\$errors, \"$path is required\";\n";
302 32         50 $r .= "}\n";
303             }
304 61         221 return $r;
305             }
306              
307             sub _validate_any_number { ## no critic (Subroutines::ProhibitManyArgs Subroutines::ProhibitExcessComplexity)
308 15     15   562 my ($self, $sympt, $schmpt, $path, $is_required, $re, $ntype) = @_;
309 15         261 $schmpt = _norm_schema($schmpt);
310 15         34 my $r = '';
311 15   100     63 $ntype ||= '';
312 15 50       47 if (defined $schmpt->{default}) {
313 0         0 my $val = _quote_var($schmpt->{default});
314 0         0 $r = "$sympt = $val if not defined $sympt;\n";
315             }
316 15         45 $r .= "if(defined($sympt)) {\n";
317 15         57 $r .= $self->_validate_schemas_array($sympt, $schmpt, $path);
318 15         26 $r .= " {\n";
319 15         64 $r .= " if($sympt !~ /^$re\$/){ push \@\$errors, '$path does not look like $ntype number'; last }\n";
320             my ($minimum, $exclusiveMinimum, $maximum, $exclusiveMaximum) =
321 15         2056 @{$schmpt}{qw(minimum exclusiveMinimum maximum exclusiveMaximum)};
  15         69  
322 15 50 66     78 if (defined $minimum && $exclusiveMinimum) {
323 0         0 $exclusiveMinimum = $minimum;
324 0         0 undef $minimum;
325             }
326 15 50 66     59 if (defined $maximum && $exclusiveMaximum) {
327 0         0 $exclusiveMaximum = $maximum;
328 0         0 undef $maximum;
329             }
330 15 100       38 if (defined $minimum) {
331 5         20 $r .= " push \@\$errors, '$path must be not less than $minimum'";
332 5         15 $r .= " if $sympt < $minimum;\n";
333             }
334 15 100       38 if (defined $exclusiveMinimum) {
335 1         5 $r .= " push \@\$errors, '$path must be greater than $exclusiveMinimum'";
336 1         4 $r .= " if $sympt <= $exclusiveMinimum;\n";
337             }
338 15 100       36 if (defined $maximum) {
339 3         12 $r .= " push \@\$errors, '$path must be not greater than $maximum'";
340 3         9 $r .= " if $sympt > $maximum;\n";
341             }
342 15 50       37 if (defined $exclusiveMaximum) {
343 0         0 $r .= " push \@\$errors, '$path must be less than $exclusiveMaximum'";
344 0         0 $r .= " if $sympt >= $exclusiveMaximum;\n";
345             }
346 15 50       53 if (defined $schmpt->{const}) {
347 0         0 $r .= " push \@\$errors, '$path must be $schmpt->{const}' if $sympt != $schmpt->{const};\n";
348             }
349 15 50       42 if ($schmpt->{multipleOf}) {
350 0         0 $self->{required_modules}{'POSIX'}{floor} = 1;
351 0         0 $r .= " push \@\$errors, '$path must be multiple of $schmpt->{multipleOf}'";
352 0         0 $r .= " if $sympt / $schmpt->{multipleOf} != floor($sympt / $schmpt->{multipleOf});\n";
353             }
354 15 0 33     54 if ($schmpt->{enum} && 'ARRAY' eq ref($schmpt->{enum}) && @{$schmpt->{enum}}) {
  0   33     0  
355 0         0 my $can_list = join ", ", map {_quote_var($_)} @{$schmpt->{enum}};
  0         0  
  0         0  
356 0         0 $self->{required_modules}{'List::Util'}{none} = 1;
357 0         0 $r .= " push \@\$errors, '$path must be on of $can_list' if none {$_ == $sympt} ($can_list);\n";
358             }
359 15 50 33     55 if ($schmpt->{format} && $formats{$schmpt->{format}}) {
360 0         0 $r .= " push \@\$errors, '$path does not match format $schmpt->{format}'";
361 0         0 $r .= " if $sympt !~ /^$formats{$schmpt->{format}}\$/;\n";
362             }
363 15 100 66     98 if ($self->{to_json} || $self->{coercion}) {
364 1         4 $r .= " $sympt += 0;\n";
365             }
366 15         68 $r .= "} }\n";
367 15 50       45 if ($is_required) {
368 15         26 $r .= "else {\n";
369 15         37 $r .= " push \@\$errors, \"$path is required\";\n";
370 15         25 $r .= "}\n";
371             }
372 15         108 return $r;
373              
374             }
375              
376             sub _validate_number {
377 5     5   18 my ($self, $sympt, $schmpt, $path, $is_required) = @_;
378 5         33 return $self->_validate_any_number($sympt, $schmpt, $path, $is_required, $RE{num}{real});
379             }
380              
381             sub _validate_integer {
382 10     10   34 my ($self, $sympt, $schmpt, $path, $is_required) = @_;
383 10         75 return $self->_validate_any_number($sympt, $schmpt, $path, $is_required, $RE{num}{int}, "integer");
384             }
385              
386             sub _make_schemas_array {
387 26     26   101 my ($self, $schemas, $rpath, $type) = @_;
388 26 100       70 $schemas = [$schemas] if 'ARRAY' ne ref $schemas;
389 26         42 my @tfa;
390 26         39 for my $schm (@{$schemas}) {
  26         56  
391 57         116 my $subschm = _norm_schema($schm);
392 57   100     198 my $stype = $subschm->{type} // $type // _guess_schema_type($schm);
      66        
393 57         111 my $val_func = "_validate_$stype";
394 57         228 my $ivf = $self->$val_func("\$_[0]", $subschm, "$rpath", "required");
395 57         281 push @tfa, " sub {my \$errors = []; $ivf; \@\$errors == 0}\n";
396             }
397 26         256 return "(" . join(",\n", @tfa) . ")";
398             }
399              
400             sub _validate_all_of {
401 6     6   14 my ($self, $schmpt, $sympt, $rpath) = @_;
402 6         10 my $r = '';
403 6         16 $self->{required_modules}{'List::Util'}{notall} = 1;
404 6         22 $r .= " { my \@allOf = " . $self->_make_schemas_array($schmpt->{allOf}, $rpath, $schmpt->{type}) . ";\n";
405 6         20 $r .= " my \$stored_arg = ${sympt};\n";
406 6         19 $r .= " push \@\$errors, \"$rpath doesn't match all required schemas\" "
407             . "if notall { \$_->(\$stored_arg, \"$rpath\") } \@allOf;\n";
408 6         9 $r .= " }\n";
409 6         13 return $r;
410             }
411              
412             sub _validate_any_of {
413 5     5   11 my ($self, $schmpt, $sympt, $rpath) = @_;
414 5         9 my $r = '';
415 5         42 $self->{required_modules}{'List::Util'}{none} = 1;
416 5         19 $r .= " { my \@anyOf = " . $self->_make_schemas_array($schmpt->{anyOf}, $rpath, $schmpt->{type}) . ";\n";
417 5         15 $r .= " my \$stored_arg = ${sympt};\n";
418 5         14 $r .= " push \@\$errors, \"$rpath doesn't match any required schema\""
419             . " if none { \$_->(\$stored_arg, \"$rpath\") } \@anyOf;\n";
420 5         8 $r .= " }\n";
421 5         11 return $r;
422             }
423              
424             sub _validate_one_of {
425 10     10   19 my ($self, $schmpt, $sympt, $rpath) = @_;
426 10         15 my $r = '';
427 10         47 $r .= " { my \@oneOf = " . $self->_make_schemas_array($schmpt->{oneOf}, $rpath, $schmpt->{type}) . ";\n";
428 10         32 $r .= " my \$stored_arg = ${sympt};\n";
429 10         53 $r .= " my \$m = 0; for my \$t (\@oneOf) { ++\$m if \$t->(\$stored_arg, \"$rpath\"); last if \$m > 1; }\n";
430 10         20 $r .= " push \@\$errors, \"$rpath doesn't match exactly one required schema\" if \$m != 1;\n";
431 10         15 $r .= " }\n";
432 10         84 return $r;
433             }
434              
435             sub _validate_not_of {
436 5     5   11 my ($self, $schmpt, $sympt, $rpath) = @_;
437 5         10 my $r = '';
438 5         11 $self->{required_modules}{'List::Util'}{any} = 1;
439 5         19 $r .= " { my \@notOf = " . $self->_make_schemas_array($schmpt->{not}, $rpath, $schmpt->{type}) . ";\n";
440 5         52 $r .= " my \$stored_arg = ${sympt};\n";
441 5         20 $r .= " push \@\$errors, \"$rpath matches a schema when must not\" "
442             . " if any { \$_->(\$stored_arg, \"$rpath\") } \@notOf;\n";
443 5         9 $r .= " }\n";
444 5         13 return $r;
445             }
446              
447             sub _validate_schemas_array {
448 133     133   255 my ($self, $sympt, $schmpt, $path) = @_;
449 133 100       264 my $rpath = !$path ? "(object)" : $path;
450 133         171 my $r = '';
451 133 100       268 $r .= $self->_validate_any_of($schmpt, $sympt, $rpath) if defined $schmpt->{anyOf};
452 133 100       273 $r .= $self->_validate_all_of($schmpt, $sympt, $rpath) if defined $schmpt->{allOf};
453 133 100       270 $r .= $self->_validate_one_of($schmpt, $sympt, $rpath) if defined $schmpt->{oneOf};
454 133 100       261 $r .= $self->_validate_not_of($schmpt, $sympt, $rpath) if defined $schmpt->{not};
455 133         288 return $r;
456             }
457              
458             sub _validate_object { ## no critic (Subroutines::ProhibitExcessComplexity)
459 24     24   69 my ($self, $sympt, $schmpt, $path, $is_required) = @_;
460 24         45 $schmpt = _norm_schema($schmpt);
461 24 100       62 my $rpath = !$path ? "(object)" : $path;
462 24 100       63 my $ppref = $path ? "$path/" : "";
463 24         37 my $r = '';
464 24 50       58 if ($schmpt->{default}) {
465 0         0 my $val = _quote_var($schmpt->{default});
466 0         0 $r = " $sympt = $val if not defined $sympt;\n";
467             }
468 24         61 $r .= "if('HASH' eq ref($sympt)) {\n";
469 24         64 $r .= $self->_validate_schemas_array($sympt, $schmpt, $path);
470 24 100 66     136 if ($schmpt->{properties} && 'HASH' eq ref $schmpt->{properties}) {
471 22         37 my %required;
472 22 100 66     92 if ($schmpt->{required} && 'ARRAY' eq ref $schmpt->{required}) {
473 20         29 %required = map {$_ => 1} @{$schmpt->{required}};
  32         108  
  20         48  
474             }
475 22         44 for my $k (keys %{$schmpt->{properties}}) {
  22         67  
476 45         77 my $type = 'string';
477 45 50       114 if ('HASH' eq ref $schmpt->{properties}{$k}) {
478 45   66     131 $type = $schmpt->{properties}{$k}{type} // _guess_schema_type($schmpt->{properties}{$k});
479             }
480 45         90 my $val_func = "_validate_$type";
481 45         128 my $qk = _quote_var($k);
482 45         298 $r .= $self->$val_func("${sympt}->{$qk}", $schmpt->{properties}{$k}, "$ppref$k", $required{$k});
483             }
484             }
485 24 50       78 if (defined $schmpt->{minProperties}) {
486 0         0 $schmpt->{minProperties} += 0;
487 0         0 $r .= " push \@\$errors, '$rpath must contain not less than $schmpt->{minProperties} properties'";
488 0         0 $r .= " if keys %{$sympt} < $schmpt->{minProperties};\n";
489             }
490 24 50       53 if (defined $schmpt->{maxProperties}) {
491 0         0 $schmpt->{maxProperties} += 0;
492 0         0 $r .= " push \@\$errors, '$rpath must contain not more than $schmpt->{maxProperties} properties'";
493 0         0 $r .= " if keys %{$sympt} > $schmpt->{minProperties};\n";
494             }
495 24         57 my @pt;
496 24 100       53 if (defined $schmpt->{patternProperties}) {
497 2         5 for my $pt (keys %{$schmpt->{patternProperties}}) {
  2         8  
498 2         5 my $type;
499             $type = $schmpt->{patternProperties}{$pt}{type}
500 2   66     10 // _guess_schema_type($schmpt->{patternProperties}{$pt});
501 2         8 my $val_func = "_validate_$type";
502 2         7 (my $upt = $pt) =~ s/"/\\"/g;
503 2         5 $upt =~ s/\\Q(.*?)\\E/quotemeta($1)/eg;
  0         0  
504 2         5 $upt =~ s/\\Q(.*)$/quotemeta($1)/eg;
  0         0  
505 2         10 $upt =~ s|/|\\/|g;
506 2         5 push @pt, $upt;
507 2         9 my $ivf = $self->$val_func("\$_[0]", $schmpt->{patternProperties}{$pt}, "\$_[1]", "required");
508 2         16 $r .= " { my \@props = grep {/$upt/} keys %{${sympt}};";
509              
510 2 50 33     20 if ($schmpt->{properties} && 'HASH' eq ref $schmpt->{properties}) {
511 2         5 my %apr = map {_quote_var($_) => undef} keys %{$schmpt->{properties}};
  2         14  
  2         8  
512 2         10 $r .= " my %defined_props = (" . join(", ", map {$_ => "undef"} keys %apr) . ");\n";
  2         11  
513 2         7 $r .= " \@props = grep {!exists \$defined_props{\$_} } \@props;\n";
514             }
515 2         43 $r .= " my \$tf = sub { $ivf };\n";
516 2         12 $r .= " for my \$prop (\@props) {\n";
517 2         7 $r .= " \$tf->(${sympt}->{\$prop}, \"$ppref\${prop}\");\n";
518 2         4 $r .= " };\n";
519 2         8 $r .= " }\n";
520             }
521             }
522 24 100       53 if (defined $schmpt->{additionalProperties}) {
523 10 50 33     42 if (!ref($schmpt->{additionalProperties}) && !$schmpt->{additionalProperties}) {
524 10         14 my %apr;
525 10         15 $r .= " {\n";
526 10 50 33     43 if ($schmpt->{properties} && 'HASH' eq ref $schmpt->{properties}) {
527 10         14 %apr = map {_quote_var($_) => undef} keys %{$schmpt->{properties}};
  20         38  
  10         30  
528 10         32 $r .= " my %allowed_props = (" . join(", ", map {$_ => "undef"} keys %apr) . ");\n";
  20         60  
529 10         35 $r .= " my \@unallowed_props = grep {!exists \$allowed_props{\$_} } keys %{${sympt}};\n";
530 10 100       24 if (@pt) {
531             $r .=
532             " \@unallowed_props = grep { "
533 2         6 . join("&&", map {"!/$_/"} @pt)
  2         10  
534             . " } \@unallowed_props;\n";
535             }
536 10         23 $r .= " push \@\$errors, \"$rpath contains not allowed properties: \@unallowed_props\" ";
537 10         20 $r .= " if \@unallowed_props;\n";
538             } else {
539 0         0 $r .= " push \@\$errors, \"$rpath can't contain properties\" if %{${sympt}};\n";
540             }
541 10         25 $r .= " }\n";
542             }
543             }
544 24         38 $r .= "}\n";
545 24 50       64 if ($is_required) {
546 24         58 $r .= "else {\n";
547 24         53 $r .= " push \@\$errors, \"$rpath is required\";\n";
548 24         39 $r .= "}\n";
549             }
550 24         144 return $r;
551             }
552              
553             sub _validate_array {
554 3     3   13 my ($self, $sympt, $schmpt, $path, $is_required) = @_;
555 3         8 $schmpt = _norm_schema($schmpt);
556 3 50       25 my $rpath = !$path ? "(object)" : $path;
557 3         7 my $r = '';
558 3 50       8 if ($schmpt->{default}) {
559 0         0 my $val = _quote_var($schmpt->{default});
560 0         0 $r = " $sympt = $val if not defined $sympt;\n";
561             }
562 3         11 $r .= "if('ARRAY' eq ref($sympt)) {\n";
563 3         9 $r .= $self->_validate_schemas_array($sympt, $schmpt, $path);
564 3 50       10 if (defined $schmpt->{minItems}) {
565 3         20 $r .= " push \@\$errors, '$path must contain not less than $schmpt->{minItems} items'";
566 3         11 $r .= " if \@{$sympt} < $schmpt->{minItems};\n";
567             }
568 3 50       9 if (defined $schmpt->{maxItems}) {
569 0         0 $r .= " push \@\$errors, '$path must contain not more than $schmpt->{maxItems} items'";
570 0         0 $r .= " if \@{$sympt} > $schmpt->{maxItems};\n";
571             }
572 3 50       10 if (defined $schmpt->{uniqueItems}) {
573 3         8 $r .= " { my %seen;\n";
574 3         7 $r .= " for (\@{$sympt}) {\n";
575 3         8 $r .= " if(\$seen{\$_}) { push \@\$errors, '$path must contain only unique items'; last }\n";
576 3         6 $r .= " \$seen{\$_} = 1;\n";
577 3         5 $r .= " };\n";
578 3         5 $r .= " }\n";
579             }
580 3 50       15 if ($schmpt->{items}) {
581 3   33     11 my $type = $schmpt->{items}{type} // _guess_schema_type($schmpt->{items});
582 3         6 my $val_func = "_validate_$type";
583 3         22 my $ivf = $self->$val_func("\$_[0]", $schmpt->{items}, "$path/[]", $is_required);
584 3         9 $r .= " { my \$tf = sub { $ivf };\n";
585 3         8 $r .= " \$tf->(\$_, \"$rpath\") for (\@{$sympt});\n";
586 3         8 $r .= " }\n";
587             }
588 3         5 $r .= "}\n";
589 3 50       7 if ($is_required) {
590 0 0       0 $path = "array" if $path eq "";
591 0         0 $r .= "else {\n";
592 0         0 $r .= " push \@\$errors, \"$path is required\";\n";
593 0         0 $r .= "}\n";
594             }
595 3         19 return $r;
596             }
597              
598             1;
599              
600             __END__