File Coverage

blib/lib/JSON/Schema/Modern/Utilities.pm
Criterion Covered Total %
statement 231 244 94.6
branch 113 130 86.9
condition 71 84 84.5
subroutine 39 42 92.8
pod 0 18 0.0
total 454 518 87.6


line stmt bran cond sub pod time code
1 36     36   255580 use strict;
  36         115  
  36         1232  
2 36     36   208 use warnings;
  36         93  
  36         1932  
3             package JSON::Schema::Modern::Utilities;
4             # vim: set ts=8 sts=2 sw=2 tw=100 et :
5             # ABSTRACT: Internal utilities for JSON::Schema::Modern
6              
7             our $VERSION = '0.572';
8              
9 36     36   840 use 5.020;
  36         151  
10 36     36   230 use strictures 2;
  36         355  
  36         1552  
11 36     36   7858 use stable 0.031 'postderef';
  36         624  
  36         322  
12 36     36   5994 use experimental 'signatures';
  36         96  
  36         183  
13 36     36   2758 use if "$]" >= 5.022, experimental => 're_strict';
  36         118  
  36         402  
14 36     36   3396 no if "$]" >= 5.031009, feature => 'indirect';
  36         103  
  36         269  
15 36     36   1969 no if "$]" >= 5.033001, feature => 'multidimensional';
  36         99  
  36         259  
16 36     36   1798 no if "$]" >= 5.033006, feature => 'bareword_filehandles';
  36         102  
  36         220  
17 36     36   1370 use B;
  36         116  
  36         2281  
18 36     36   298 use Carp 'croak';
  36         117  
  36         2534  
19 36     36   1246 use JSON::MaybeXS 1.004004 'is_bool';
  36         16122  
  36         2637  
20 36     36   1241 use Ref::Util 0.100 qw(is_ref is_plain_arrayref is_plain_hashref);
  36         3809  
  36         2322  
21 36     36   270 use Scalar::Util 'blessed';
  36         103  
  36         1958  
22 36     36   1501 use Storable 'dclone';
  36         6461  
  36         1971  
23 36     36   1221 use Feature::Compat::Try;
  36         720  
  36         365  
24 36     36   11022 use JSON::Schema::Modern::Error;
  36         100  
  36         1104  
25 36     36   1309 use JSON::Schema::Modern::Annotation;
  36         99  
  36         978  
26 36     36   223 use namespace::clean;
  36         112  
  36         338  
27              
28 36     36   11473 use Exporter 'import';
  36         92  
  36         2776  
29              
30             our @EXPORT_OK = qw(
31             is_type
32             get_type
33             is_equal
34             is_elements_unique
35             jsonp
36             unjsonp
37             local_annotations
38             canonical_uri
39             E
40             A
41             abort
42             assert_keyword_exists
43             assert_keyword_type
44             assert_pattern
45             assert_uri_reference
46             assert_uri
47             annotate_self
48             sprintf_num
49             true
50             false
51             );
52              
53 36     36   272 use JSON::PP ();
  36         95  
  36         1649  
54 36     36   230 use constant { true => JSON::PP::true, false => JSON::PP::false };
  36         107  
  36         276  
55              
56 72373     72373 0 491426 sub is_type ($type, $value) {
  72373         111445  
  72373         107258  
  72373         100868  
57 72373 100       146067 if ($type eq 'null') {
58 71         361 return !(defined $value);
59             }
60 72302 100       135325 if ($type eq 'boolean') {
61 8201         26543 return is_bool($value);
62             }
63 64101 100       123946 if ($type eq 'object') {
64 18243         84322 return is_plain_hashref($value);
65             }
66 45858 100       92646 if ($type eq 'array') {
67 11148         51862 return is_plain_arrayref($value);
68             }
69              
70 34710 100 100     107593 if ($type eq 'string' or $type eq 'number' or $type eq 'integer') {
      100        
71 34700 100       70622 return 0 if not defined $value;
72 34686         155693 my $flags = B::svref_2object(\$value)->FLAGS;
73              
74 34686 100       93287 if ($type eq 'string') {
75 24306   66     216661 return !is_ref($value) && $flags & B::SVf_POK && !($flags & (B::SVf_IOK | B::SVf_NOK));
76             }
77              
78 10380 100       23561 if ($type eq 'number') {
79 6892   100     56965 return ref($value) =~ /^Math::Big(?:Int|Float)$/
80             || !($flags & B::SVf_POK) && ($flags & (B::SVf_IOK | B::SVf_NOK));
81             }
82              
83 3488 50       8087 if ($type eq 'integer') {
84 3488   100     36019 return ref($value) =~ /^Math::Big(?:Int|Float)$/ && $value->is_int
85             || !($flags & B::SVf_POK) && ($flags & (B::SVf_IOK | B::SVf_NOK)) && int($value) == $value;
86             }
87             }
88              
89 10 100       60 if ($type =~ /^reference to (.+)$/) {
90 6   33     61 return !blessed($value) && ref($value) eq $1;
91             }
92              
93 4         24 return ref($value) eq $type;
94             }
95              
96 77809     77809 0 182137 sub get_type ($value) {
  77809         122572  
  77809         111651  
97 77809 100       237518 return 'object' if is_plain_hashref($value);
98 21689 100       60222 return 'boolean' if is_bool($value);
99 12886 100       91238 return 'null' if not defined $value;
100 12573 100       27687 return 'array' if is_plain_arrayref($value);
101              
102 11321 100       26898 return ref($value) =~ /^Math::Big(?:Int|Float)$/ ? ($value->is_int ? 'integer' : 'number')
    100          
    100          
    100          
103             : (blessed($value) ? '' : 'reference to ').ref($value)
104             if is_ref($value);
105              
106 10868         41499 my $flags = B::svref_2object(\$value)->FLAGS;
107 10868 100 100     47394 return 'string' if $flags & B::SVf_POK && !($flags & (B::SVf_IOK | B::SVf_NOK));
108 4748 100 66     29330 return int($value) == $value ? 'integer' : 'number'
    100          
109             if !($flags & B::SVf_POK) && ($flags & (B::SVf_IOK | B::SVf_NOK));
110              
111 2         10 return 'ambiguous type';
112             }
113              
114             # compares two arbitrary data payloads for equality, as per
115             # https://json-schema.org/draft/2020-12/json-schema-core.html#rfc.section.4.2.2
116             # if provided with a state hashref with a 'path' key, any differences are recorded within
117 4453     4453 0 6869 sub is_equal ($x, $y, $state = undef) {
  4453         6934  
  4453         7002  
  4453         6652  
  4453         6184  
118 4453   100     18696 $state->{path} //= '';
119              
120 4453         10462 my @types = map get_type($_), $x, $y;
121              
122 4453 100       15232 if ($state->{scalarref_booleans}) {
123 1582 100       3688 ($x, $types[0]) = (0+!!$$x, 'boolean') if $types[0] eq 'reference to SCALAR';
124 1582 100       3561 ($y, $types[1]) = (0+!!$$y, 'boolean') if $types[1] eq 'reference to SCALAR';
125             }
126              
127 4453 100       11835 return 0 if $types[0] ne $types[1];
128 3560 100       7489 return 1 if $types[0] eq 'null';
129 3546 100       13341 return $x eq $y if $types[0] eq 'string';
130 1625 100       8755 return $x == $y if grep $types[0] eq $_, qw(boolean number integer);
131              
132 542         1017 my $path = $state->{path};
133 542 100       1190 if ($types[0] eq 'object') {
134 214 100       676 return 0 if keys %$x != keys %$y;
135 198 100       971 return 0 if not is_equal([ sort keys %$x ], [ sort keys %$y ]);
136 192         751 foreach my $property (sort keys %$x) {
137 230         571 $state->{path} = jsonp($path, $property);
138 230 100       619 return 0 if not is_equal($x->{$property}, $y->{$property}, $state);
139             }
140 106         740 return 1;
141             }
142              
143 328 50       775 if ($types[0] eq 'array') {
144 328 100       799 return 0 if @$x != @$y;
145 320         884 foreach my $idx (0 .. $x->$#*) {
146 364         1052 $state->{path} = $path.'/'.$idx;
147 364 100       990 return 0 if not is_equal($x->[$idx], $y->[$idx], $state);
148             }
149 232         1067 return 1;
150             }
151              
152 0         0 return 0; # should never get here
153             }
154              
155             # checks array elements for uniqueness. short-circuits on first pair of matching elements
156             # if second arrayref is provided, it is populated with the indices of identical items
157 2849     2849 0 5273 sub is_elements_unique ($array, $equal_indices = undef) {
  2849         4939  
  2849         5315  
  2849         4435  
158 2849         9805 foreach my $idx0 (0 .. $array->$#*-1) {
159 985         2804 foreach my $idx1 ($idx0+1 .. $array->$#*) {
160 1390 100       4961 if (is_equal($array->[$idx0], $array->[$idx1], { scalarref_booleans => 1 })) {
161 211 50       2671 push @$equal_indices, $idx0, $idx1 if defined $equal_indices;
162 211         920 return 0;
163             }
164             }
165             }
166 2638         8990 return 1;
167             }
168              
169             # shorthand for creating and appending json pointers
170             # the first argument is a a json pointer; remaining arguments are path segments to be encoded and
171             # appended
172             sub jsonp {
173 45526 100   45526 0 569758 return join('/', shift, map s/~/~0/gr =~ s!/!~1!gr, map +(is_plain_arrayref($_) ? @$_ : $_), grep defined, @_);
174             }
175              
176             # splits a json pointer apart into its path segments
177 0     0 0 0 sub unjsonp ($path) {
  0         0  
  0         0  
178 0         0 return map s!~0!~!gr =~ s!~1!/!gr, split m!/!, $path;
179             }
180              
181             # get all annotations produced for the current instance data location (that are visible to this
182             # schema location) - remember these are hashrefs, not Annotation objects
183 1200     1200 0 2204 sub local_annotations ($state) {
  1200         2231  
  1200         1909  
184 1200         4945 grep $_->{instance_location} eq $state->{data_path}, $state->{annotations}->@*;
185             }
186              
187             # shorthand for finding the canonical uri of the present schema location
188             # last argument can be an arrayref, usually coming from $state->{_schema_path_suffix}
189 41279     41279 0 68586 sub canonical_uri ($state, @extra_path) {
  41279         62181  
  41279         76458  
  41279         59575  
190 41279 100 100     171446 return $state->{initial_schema_uri} if not @extra_path and not length($state->{schema_path});
191 23870 100 100     84419 splice(@extra_path, -1, 1, $extra_path[-1]->@*) if @extra_path and is_plain_arrayref($extra_path[-1]);
192 23870         88788 my $uri = $state->{initial_schema_uri}->clone;
193 23870 100 100     1809229 my $fragment = ($uri->fragment//'').(@extra_path ? jsonp($state->{schema_path}, @extra_path) : $state->{schema_path});
194 23870 100       128808 undef $fragment if not length($fragment);
195 23870         70807 $uri->fragment($fragment);
196 23870         175176 $uri;
197             }
198              
199             # shorthand for creating error objects
200             # uses these keys from $state:
201             # - initial_schema_uri
202             # - keyword
203             # - data_path
204             # - traversed_schema_path
205             # - schema_path
206             # - _schema_path_suffix
207             # - errors
208 11206     11206 0 44004 sub E ($state, $error_string, @args) {
  11206         18302  
  11206         20920  
  11206         21764  
  11206         16972  
209 11206 50       27016 croak 'E called in void context' if not defined wantarray;
210              
211             # sometimes the keyword shouldn't be at the very end of the schema path
212             my $uri = canonical_uri($state, $state->{keyword}, $state->{_schema_path_suffix})
213 11206         40217 ->to_abs($state->{effective_base_uri});
214              
215             my $keyword_location = $state->{traversed_schema_path}
216 11206         2699009 .jsonp($state->{schema_path}, $state->{keyword}, delete $state->{_schema_path_suffix});
217              
218 11206 100 100     42208 undef $uri if $uri eq '' and $keyword_location eq ''
      100        
      100        
      100        
219             or ($uri->fragment // '') eq $keyword_location and $uri->clone->fragment(undef) eq '';
220              
221             push $state->{errors}->@*, JSON::Schema::Modern::Error->new(
222             keyword => $state->{keyword},
223             instance_location => $state->{data_path},
224             keyword_location => $keyword_location,
225             defined $uri ? ( absolute_keyword_location => $uri ) : (),
226             error => @args ? sprintf($error_string, @args) : $error_string,
227 11206 100       4450419 $state->{exception} ? ( exception => $state->{exception} ) : (),
    100          
    100          
228             );
229              
230 11206         787919 return 0;
231             }
232              
233             # shorthand for creating annotations
234             # uses these keys from $state:
235             # - initial_schema_uri
236             # - keyword
237             # - data_path
238             # - traversed_schema_path
239             # - schema_path
240             # - _schema_path_suffix
241             # - annotations
242             # - collect_annotations
243 10764     10764 0 17590 sub A ($state, $annotation) {
  10764         16972  
  10764         17537  
  10764         16673  
244 10764 100 100     42698 return 1 if not $state->{collect_annotations} or $state->{spec_version} eq 'draft7';
245              
246             # we store the absolute uri in unresolved form until needed,
247             # and perform the rest of the calculations later.
248              
249             my $uri = [ canonical_uri($state, $state->{keyword}, $state->{_schema_path_suffix}),
250 2466         9438 $state->{effective_base_uri} ];
251              
252             my $keyword_location = $state->{traversed_schema_path}
253 2466         8672 .jsonp($state->{schema_path}, $state->{keyword}, delete $state->{_schema_path_suffix});
254              
255             push $state->{annotations}->@*, {
256             keyword => $state->{keyword},
257             instance_location => $state->{data_path},
258             keyword_location => $keyword_location,
259             # we calculate absolute_keyword_location when instantiating the Annotation object for Result
260             _uri => $uri,
261             annotation => $annotation,
262 2466 100       15524 $state->{_unknown} ? ( unknown => 1 ) : (),
263             };
264              
265 2466         7111 return 1;
266             }
267              
268             # creates an error object, but also aborts evaluation immediately
269             # only this error is returned, because other errors on the stack might not actually be "real"
270             # errors (consider if we were in the middle of evaluating a "not" or "if").
271             # Therefore this is only appropriate during the evaluation phase, not the traverse phase.
272 55     55 0 287 sub abort ($state, $error_string, @args) {
  55         112  
  55         114  
  55         133  
  55         97  
273 55         709 ()= E({ %$state, exception => 1 }, $error_string, @args);
274 55 50       462 croak 'abort() called during traverse' if $state->{traverse};
275 55         754 die pop $state->{errors}->@*;
276             }
277              
278 0     0 0 0 sub assert_keyword_exists ($state, $schema) {
  0         0  
  0         0  
  0         0  
279 0 0       0 croak 'assert_keyword_exists called in void context' if not defined wantarray;
280 0 0       0 return E($state, '%s keyword is required', $state->{keyword}) if not exists $schema->{$state->{keyword}};
281 0         0 return 1;
282             }
283              
284 39919     39919 0 60645 sub assert_keyword_type ($state, $schema, $type) {
  39919         59293  
  39919         55789  
  39919         64566  
  39919         55633  
285 39919 50       85635 croak 'assert_keyword_type called in void context' if not defined wantarray;
286 39919         82391 my $value = $schema->{$state->{keyword}};
287 39919         60695 my $thing = 'value';
288             ($value, $thing) = is_plain_hashref($value) ? ($value->{$state->{_schema_path_suffix}}, 'value at "'.$state->{_schema_path_suffix}.'"')
289             : is_plain_arrayref($value) ? ($value->[$state->{_schema_path_suffix}], 'item '.$state->{_schema_path_suffix})
290             : die 'unknown type'
291 39919 0       87372 if exists $state->{_schema_path_suffix};
    50          
    100          
292 39919 100       83759 return 1 if is_type($type, $value);
293 18 100       135 E($state, '%s %s is not a%s %s', $state->{keyword}, $thing, ($type =~ /^[aeiou]/ ? 'n' : ''), $type);
294             }
295              
296 2289     2289 0 4394 sub assert_pattern ($state, $pattern) {
  2289         3770  
  2289         4283  
  2289         3522  
297 2289 50       5611 croak 'assert_pattern called in void context' if not defined wantarray;
298             try {
299 0     0   0 local $SIG{__WARN__} = sub { die @_ };
300             qr/$pattern/;
301             }
302 2289         5434 catch ($e) { return E($state, $e); };
303 2286         18415 return 1;
304             }
305              
306             # this is only suitable for checking URIs within schemas themselves
307 4596     4596 0 8265 sub assert_uri_reference ($state, $schema) {
  4596         7517  
  4596         7006  
  4596         6568  
308 4596 50       10775 croak 'assert_uri_reference called in void context' if not defined wantarray;
309              
310 4596         9907 my $string = $schema->{$state->{keyword}};
311             return E($state, '%s value is not a valid URI reference', $state->{keyword})
312             # see also uri-reference format sub
313 4596 100 66     15514 if fc(Mojo::URL->new($string)->to_unsafe_string) ne fc($string)
      100        
      100        
      100        
      100        
314             or $string =~ /[^[:ascii:]]/
315             or $string =~ /#/
316             and $string !~ m{#$} # empty fragment
317             and $string !~ m{#[A-Za-z][A-Za-z0-9_:.-]*$} # plain-name fragment
318             and $string !~ m{#/(?:[^~]|~[01])*$}; # json pointer fragment
319              
320 4566         1605609 return 1;
321             }
322              
323             # this is only suitable for checking URIs within schemas themselves
324 5823     5823 0 10460 sub assert_uri ($state, $schema, $override = undef) {
  5823         9933  
  5823         9679  
  5823         10124  
  5823         8891  
325 5823 50       12995 croak 'assert_uri called in void context' if not defined wantarray;
326              
327 5823   66     21190 my $string = $override // $schema->{$state->{keyword}};
328 5823         19621 my $uri = Mojo::URL->new($string);
329              
330 5823 50 66     488145 return E($state, '"%s" is not a valid URI', $string)
      100        
      66        
      33        
      33        
      66        
331             # see also uri format sub
332             if fc($uri->to_unsafe_string) ne fc($string)
333             or $string =~ /[^[:ascii:]]/
334             or not $uri->is_abs
335             or $string =~ /#/
336             and $string !~ m{#$} # empty fragment
337             and $string !~ m{#[A-Za-z][A-Za-z0-9_:.-]*$} # plain-name fragment
338             and $string !~ m{#/(?:[^~]|~[01])*$}; # json pointer fragment
339              
340 5815         1181317 return 1;
341             }
342              
343             # produces an annotation whose value is the same as that of the current keyword
344 1595     1595 0 2501 sub annotate_self ($state, $schema) {
  1595         2556  
  1595         2409  
  1595         2321  
345             A($state, is_ref($schema->{$state->{keyword}}) ? dclone($schema->{$state->{keyword}})
346 1595 100       10779 : $schema->{$state->{keyword}});
347             }
348              
349 1101     1101 0 1923 sub sprintf_num ($value) {
  1101         1928  
  1101         2185  
350             # use original value as stored in the NV, without losing precision
351 1101 100       7000 ref($value) =~ /^Math::Big(?:Int|Float)$/ ? $value->bstr : sprintf('%s', $value);
352             }
353              
354             1;
355              
356             __END__
357              
358             =pod
359              
360             =encoding UTF-8
361              
362             =head1 NAME
363              
364             JSON::Schema::Modern::Utilities - Internal utilities for JSON::Schema::Modern
365              
366             =head1 VERSION
367              
368             version 0.572
369              
370             =head1 SYNOPSIS
371              
372             use JSON::Schema::Modern::Utilities qw(func1 func2..);
373              
374             =head1 DESCRIPTION
375              
376             This class contains internal utilities to be used by L<JSON::Schema::Modern>.
377              
378             =for Pod::Coverage is_type get_type is_equal is_elements_unique jsonp unjsonp local_annotations
379             canonical_uri E A abort assert_keyword_exists assert_keyword_type assert_pattern assert_uri_reference assert_uri
380             annotate_self sprintf_num
381              
382             =for stopwords OpenAPI
383              
384             =head1 SUPPORT
385              
386             Bugs may be submitted through L<https://github.com/karenetheridge/JSON-Schema-Modern/issues>.
387              
388             I am also usually active on irc, as 'ether' at C<irc.perl.org> and C<irc.libera.chat>.
389              
390             You can also find me on the L<JSON Schema Slack server|https://json-schema.slack.com> and L<OpenAPI Slack
391             server|https://open-api.slack.com>, which are also great resources for finding help.
392              
393             =head1 AUTHOR
394              
395             Karen Etheridge <ether@cpan.org>
396              
397             =head1 COPYRIGHT AND LICENCE
398              
399             This software is copyright (c) 2020 by Karen Etheridge.
400              
401             This is free software; you can redistribute it and/or modify it under
402             the same terms as the Perl 5 programming language system itself.
403              
404             =cut