File Coverage

blib/lib/JSON/Schema/AsType/Draft4/Types.pm
Criterion Covered Total %
statement 48 49 97.9
branch 8 8 100.0
condition n/a
subroutine 13 14 92.8
pod 0 1 0.0
total 69 72 95.8


line stmt bran cond sub pod time code
1             package JSON::Schema::AsType::Draft4::Types;
2             our $AUTHORITY = 'cpan:YANICK';
3             # ABSTRACT: JSON-schema v4 keywords as types
4             $JSON::Schema::AsType::Draft4::Types::VERSION = '0.4.1';
5              
6 11     11   27088 use strict;
  11         14  
  11         360  
7 11     11   38 use warnings;
  11         13  
  11         314  
8              
9 11     11   708 use Type::Utils -all;
  11         20689  
  11         101  
10 11         88 use Types::Standard qw/
11             Str StrictNum HashRef ArrayRef
12             Int
13             Dict slurpy Optional Any
14             Tuple
15             ConsumerOf
16             InstanceOf
17 11     11   21148 /;
  11         34778  
18              
19             use Type::Library
20 11         64 -base,
21             -declare => qw(
22             Minimum
23             ExclusiveMinimum
24             Maximum
25             ExclusiveMaximum
26             MultipleOf
27              
28             Null
29             Boolean
30             Array
31             Object
32             String
33             Integer
34             Pattern
35             Number
36              
37             Required
38              
39             Not
40              
41             OneOf
42             AllOf
43             AnyOf
44              
45             MaxLength
46             MinLength
47              
48             Items
49             AdditionalItems
50             MaxItems
51             MinItems
52              
53             Properties
54             PatternProperties
55             AdditionalProperties
56             MaxProperties
57             MinProperties
58              
59              
60             Dependencies
61             Dependency
62              
63             Enum
64              
65             UniqueItems
66              
67             Schema
68              
69 11     11   12556 );
  11         18  
70              
71 11     11   26037 use List::MoreUtils qw/ all any zip none /;
  11         3991  
  11         76  
72 11     11   5846 use List::Util qw/ pairs pairmap reduce uniq /;
  11         43  
  11         781  
73              
74 11     11   44 use JSON qw/ to_json from_json /;
  11         13  
  11         59  
75              
76 11     11   1577 use JSON::Schema::AsType;
  11         15  
  11         2816  
77              
78             declare AdditionalProperties,
79             constraint_generator => sub {
80             my( $known_properties, $type_or_boolean ) = @_;
81              
82             sub {
83             return 1 unless Object->check($_);
84             my @add_keys = grep {
85             my $key = $_;
86             none {
87             ref $_ ? $key =~ $_ : $key eq $_
88             } @$known_properties
89             } keys %$_;
90              
91             if ( eval { $type_or_boolean->can('check') } ) {
92             my $obj = $_;
93             return all { $type_or_boolean->check($obj->{$_}) } @add_keys;
94             }
95             else {
96             return not( @add_keys and not $type_or_boolean );
97             }
98             }
99             };
100              
101             declare UniqueItems,
102             where {
103             return 1 unless Array->check($_);
104             @$_ == uniq map { to_json $_ , { allow_nonref => 1 } } @$_
105             };
106              
107             my $json = JSON->new->allow_nonref->canonical;
108 11     11   6399 use List::AllUtils qw/ zip none uniq /;
  11         81526  
  11         1240  
109              
110             sub same_structs {
111 1299     1299 0 1480 my @s = @_;
112              
113 1299         1157 my @refs = grep { $_ } map { ref } @s;
  2598         2475  
  2598         2740  
114              
115 1299 100       2117 return if @refs == 1;
116              
117 11     11   69 no warnings 'uninitialized';
  11         15  
  11         19800  
118              
119 1252 100       3001 return $s[0] eq $s[1] unless @refs;
120              
121 24         165 @refs = uniq @refs;
122 24 100       69 return unless @refs == 1;
123              
124 14 100       40 if ( ref $s[0] eq 'ARRAY' ) {
125 3     0   12 return all { same_structs($a,$b) } zip @{$s[0]}, @{$s[1]};
  0         0  
  3         9  
  3         56  
126             }
127              
128 11     16   35 all { same_structs($s[0]{$_},$s[1]{$_}) } uniq map { keys %$_ } @s;
  16         91  
  22         82  
129             }
130              
131             declare Enum,
132             constraint_generator => sub {
133             my @items = @_;
134              
135             sub {
136             my $j = $_;
137             any { same_structs($_,$j) } @items;
138             }
139             };
140              
141             # Dependencies[ foo => $type, bar => [ 'baz' ] ]
142             # TODO name of generated type should be better
143             declare Dependencies,
144             constraint_generator => sub {
145             my %deps = @_;
146              
147             return reduce { $a & $b } pairmap { Dependency[$a => $b] } %deps;
148             };
149              
150             # Depencency[ foo => $type ]
151             declare Dependency,
152             constraint_generator => sub {
153             my( $property, $dep) = @_;
154              
155             sub {
156             return 1 unless Object->check($_);
157             return 1 unless exists $_->{$property};
158              
159             my $obj = $_;
160              
161             return all { exists $obj->{$_} } @$dep if ref $dep eq 'ARRAY';
162              
163             return $dep->check($_);
164             }
165             };
166              
167             declare PatternProperties,
168             constraint_generator => sub {
169             my %props = @_;
170              
171             sub {
172             return 1 unless Object->check($_);
173              
174             my $obj = $_;
175             for my $key ( keys %props ) {
176             return unless all { $props{$key}->check($obj->{$_}) } grep { /$key/ } keys %$_;
177             }
178              
179             return 1;
180              
181             }
182             };
183             declare Properties,
184             constraint_generator => sub {
185             my @types = @_;
186              
187             @types = pairmap { $a => Optional[$b] } @types;
188              
189             my $type = Dict[@types,slurpy Any];
190              
191             sub {
192             return 1 unless Object->check($_);
193             return $type->check($_);
194             }
195             };
196              
197             declare Items,
198             constraint_generator => sub {
199             my $types = shift;
200              
201             if ( Boolean->check($types) ) {
202             return $types ? Any : sub { !@$_ };
203             }
204              
205             my $type = ref $types eq 'ARRAY'
206             ? Tuple[ ( map { Optional[$_] } @$types ), slurpy Any ]
207             : Tuple[ slurpy ArrayRef[ $types ] ];
208              
209             return ~ArrayRef | $type;
210              
211             };
212              
213             declare AdditionalItems,
214             constraint_generator=> sub {
215             if( @_ > 1 ) {
216             my $to_skip = shift;
217             my $schema = shift;
218             return sub {
219             all { $schema->check($_) } splice @$_, $to_skip;
220             }
221             }
222             else {
223             my $size = shift;
224             return sub { @$_ <= $size };
225             }
226             };
227              
228             declare MaxLength,
229             constraint_generator => sub {
230             my $length = shift;
231             sub {
232             !String->check($_) or $length >= length;
233             }
234             };
235              
236             declare MinLength,
237             constraint_generator => sub {
238             my $length = shift;
239             sub {
240             !String->check($_) or $length <= length;
241             }
242             };
243              
244             declare AllOf,
245             constraint_generator => sub {
246             my @types = @_;
247             sub {
248             my $v = $_;
249             all { $_->check($v) } @types;
250             }
251             };
252              
253             declare AnyOf,
254             constraint_generator => sub {
255             my @types = @_;
256             sub {
257             my $v = $_;
258             any { $_->check($v) } @types;
259             }
260             };
261              
262             declare OneOf,
263             constraint_generator => sub {
264             my @types = @_;
265             sub {
266             my $v = $_;
267             1 == grep { $_->check($v) } @types;
268             }
269             };
270              
271             declare MaxProperties,
272             constraint_generator => sub {
273             my $nbr = shift;
274             sub { !Object->check($_) or $nbr >= keys %$_; },
275             };
276              
277             declare MinProperties,
278             constraint_generator => sub {
279             my $nbr = shift;
280             sub {
281             !Object->check($_)
282             or $nbr <= scalar keys %$_
283             },
284             };
285              
286             declare Not,
287             constraint_generator => sub {
288             my $type = shift;
289             sub { not $type->check($_) },
290             };
291              
292              
293             # ~Str or ~String?
294             declare Pattern,
295             constraint_generator => sub {
296             my $regex = shift;
297             sub { !String->check($_) or /$regex/ },
298             };
299              
300              
301             declare Object => as HashRef ,where sub { ref eq 'HASH' };
302              
303             declare Required,
304             constraint_generator => sub {
305             my @keys = @_;
306             sub {
307             return 1 unless Object->check($_);
308             my $obj = $_;
309             all { exists $obj->{$_} } @keys;
310             }
311             };
312              
313             declare Array => as ArrayRef;
314              
315             declare Boolean => where sub { ref =~ /JSON/ };
316              
317             declare LaxNumber =>
318             as StrictNum,
319             where sub {
320             return !(!defined || ref);
321             };
322              
323             declare Number =>
324             where sub {
325             return 0 if !defined || ref;
326              
327             my $b_obj = B::svref_2object(\$_);
328             my $flags = $b_obj->FLAGS;
329             return( $flags & ( B::SVp_IOK | B::SVp_NOK ) and not ($flags & B::SVp_POK) );
330             };
331              
332             declare LaxInteger =>
333             as Int,
334             where sub { return !(!defined || ref ) };
335              
336             declare Integer =>
337             where sub {
338             return 0 if !defined || ref;
339              
340             my $b_obj = B::svref_2object(\$_);
341             my $flags = $b_obj->FLAGS;
342             return( $flags & B::SVp_IOK and not ($flags & B::SVp_POK) );
343             };
344              
345             declare LaxString => as Str,
346             where sub { return defined && not ref; };
347              
348             declare String => as Str,
349             where sub {
350             return 0 if !defined || ref;
351              
352             my $b_obj = B::svref_2object(\$_);
353             my $flags = $b_obj->FLAGS;
354             return ($flags & B::SVp_POK);
355             };
356              
357             declare Null => where sub { not defined };
358              
359             declare 'MaxItems',
360             constraint_generator => sub {
361             my $max = shift;
362              
363             return sub {
364             ref ne 'ARRAY' or @$_ <= $max;
365             };
366             };
367              
368             declare 'MinItems',
369             constraint_generator => sub {
370             my $min = shift;
371              
372             return sub {
373             ref ne 'ARRAY' or @$_ >= $min;
374             };
375             };
376              
377             declare 'MultipleOf',
378             constraint_generator => sub {
379             my $num =shift;
380              
381             return sub {
382             !Number->check($_)
383             or ($_ / $num) !~ /\./;
384             }
385             };
386              
387             declare Minimum,
388             constraint_generator => sub {
389             my $minimum = shift;
390             return sub {
391             ! Number->check($_)
392             or $_ >= $minimum;
393             };
394             };
395              
396             declare ExclusiveMinimum,
397             constraint_generator => sub {
398             my $minimum = shift;
399             return sub {
400             ! StrictNum->check($_)
401             or $_ > $minimum;
402             }
403             };
404              
405             declare Maximum,
406             constraint_generator => sub {
407             my $max = shift;
408             return sub {
409             ! StrictNum->check($_)
410             or $_ <= $max;
411             };
412             };
413              
414             declare ExclusiveMaximum,
415             constraint_generator => sub {
416             my $max = shift;
417             return sub {
418             ! StrictNum->check($_)
419             or $_ < $max;
420             }
421             };
422              
423             declare Schema, as InstanceOf['Type::Tiny'];
424              
425             coerce Schema,
426             from HashRef,
427             via {
428             my $schema = JSON::Schema::AsType->new( draft_version => 4, schema => $_ );
429              
430             if ( $schema->validate_schema ) {
431             die "not a valid draft4 json schema\n";
432             }
433              
434             $schema->type
435             };
436              
437             1;
438              
439             __END__
440              
441             =pod
442              
443             =encoding UTF-8
444              
445             =head1 NAME
446              
447             JSON::Schema::AsType::Draft4::Types - JSON-schema v4 keywords as types
448              
449             =head1 VERSION
450              
451             version 0.4.1
452              
453             =head1 SYNOPSIS
454              
455             use JSON::Schema::AsType::Draft4::Types '-all';
456              
457             my $type = Object &
458             Properties[
459             foo => Minimum[3]
460             ];
461              
462             $type->check({ foo => 5 }); # => 1
463             $type->check({ foo => 1 }); # => 0
464              
465             =head1 EXPORTED TYPES
466              
467             Null Boolean Array Object String Integer Pattern Number Enum
468              
469             OneOf AllOf AnyOf
470              
471             Required Not
472              
473             Minimum ExclusiveMinimum Maximum ExclusiveMaximum MultipleOf
474              
475             MaxLength MinLength
476              
477             Items AdditionalItems MaxItems MinItems UniqueItems
478              
479             Properties PatternProperties AdditionalProperties MaxProperties MinProperties
480              
481             Dependencies Dependency
482              
483             =head2 Schema
484              
485             Only verifies that the variable is a L<Type::Tiny>.
486              
487             Can coerce the value from a hashref defining the schema.
488              
489             my $schema = Schema->coerce( \%schema );
490              
491             # equivalent to
492              
493             $schema = JSON::Schema::AsType::Draft4->new(
494             draft_version => 4,
495             schema => \%schema;
496             )->type;
497              
498             =head1 AUTHOR
499              
500             Yanick Champoux <yanick@babyl.dyndns.org>
501              
502             =head1 COPYRIGHT AND LICENSE
503              
504             This software is copyright (c) 2015 by Yanick Champoux.
505              
506             This is free software; you can redistribute it and/or modify it under
507             the same terms as the Perl 5 programming language system itself.
508              
509             =cut