File Coverage

blib/lib/JSON/Validator/Formats.pm
Criterion Covered Total %
statement 105 118 88.9
branch 55 72 76.3
condition 18 33 54.5
subroutine 23 23 100.0
pod 17 17 100.0
total 218 263 82.8


line stmt bran cond sub pod time code
1             package JSON::Validator::Formats;
2 50     50   265757 use Mojo::Base -strict;
  50         97  
  50         302  
3              
4             require Time::Local;
5              
6 50     50   6603 use constant DATA_VALIDATE_DOMAIN => eval 'require Data::Validate::Domain;1';
  50         99  
  50         3813  
7 50     50   300 use constant DATA_VALIDATE_IP => eval 'require Data::Validate::IP;1';
  50         96  
  50         3272  
8 50     50   294 use constant NET_IDN_ENCODE => eval 'require Net::IDN::Encode;1';
  50         95  
  50         3355  
9 50   50 50   279 use constant WARN_MISSING_MODULE => $ENV{JSON_VALIDATOR_WARN} // 1;
  50         102  
  50         96663  
10              
11             our $IRI_TEST_NAME = 'iri-reference';
12              
13             sub check_date {
14 9     9 1 123 my @date = $_[0] =~ m!^(\d{4})-(\d\d)-(\d\d)$!io;
15 9 100       34 return 'Does not match date format.' unless @date;
16 4 100       12 @date = map { s/^0+//; $_ || 0 } reverse @date;
  12         30  
  12         47  
17 4         15 $date[1] -= 1; # month are zero based
18 4         13 local $@;
19 4 100       10 return undef if eval { Time::Local::timegm(0, 0, 0, @date); 1 };
  4         18  
  2         136  
20 2         393 my $err = (split / at /, $@)[0];
21 2         19 $err =~ s!('-?\d+'\s|\s[\d\.]+)!!g;
22 2         5 $err .= '.';
23 2         9 return $err;
24             }
25              
26             sub check_date_time {
27 17     17 1 145 my @dt = $_[0]
28             =~ m!^(\d{4})-(\d\d)-(\d\d)[T ](\d\d):(\d\d):(\d\d(?:\.\d+)?)(?:Z|([+-])(\d+):(\d+))?$!io;
29 17 100       51 return 'Does not match date-time format.' unless @dt;
30 14         40 @dt = map { s/^0//; $_ } reverse @dt[0 .. 5];
  84         146  
  84         188  
31 14         35 $dt[4] -= 1; # month are zero based
32 14         21 local $@;
33 14 100       26 return undef if eval { Time::Local::timegm(@dt); 1 };
  14         47  
  5         215  
34 9         1218 my $err = (split / at /, $@)[0];
35 9         93 $err =~ s!('-?\d+'\s|\s[\d\.]+)!!g;
36 9         19 $err .= '.';
37 9         38 return $err;
38             }
39              
40             sub check_email {
41 5     5 1 11 state $email_rfc5322_re = do {
42 3         31 my $atom = qr;[a-zA-Z0-9_!#\$\%&'*+/=?\^`{}~|\-]+;o;
43 3         13 my $quoted_string = qr/"(?:\\[^\r\n]|[^\\"])*"/o;
44 3         10 my $domain_literal
45             = qr/\[(?:\\[\x01-\x09\x0B-\x0c\x0e-\x7f]|[\x21-\x5a\x5e-\x7e])*\]/o;
46 3         174 my $dot_atom = qr/$atom(?:[.]$atom)*/o;
47 3         178 my $local_part = qr/(?:$dot_atom|$quoted_string)/o;
48 3         149 my $domain = qr/(?:$dot_atom|$domain_literal)/o;
49              
50 3         264 qr/$local_part\@$domain/o;
51             };
52              
53 5 100       102 return $_[0] =~ $email_rfc5322_re ? undef : 'Does not match email format.';
54             }
55              
56             sub check_hostname {
57 2 50   2 1 11 return _module_missing(hostname => 'Data::Validate::Domain')
58             unless DATA_VALIDATE_DOMAIN;
59 0 0       0 return undef if Data::Validate::Domain::is_hostname($_[0]);
60 0         0 return 'Does not match hostname format.';
61             }
62              
63             sub check_idn_email {
64 1 50   1 1 6 return _module_missing('idn-email' => 'Net::IDN::Encode')
65             unless NET_IDN_ENCODE;
66              
67 0         0 local $@;
68 0         0 my $err = eval {
69 0         0 my @email = split /@/, $_[0], 2;
70 0   0     0 check_email(
      0        
71             join '@',
72             Net::IDN::Encode::to_ascii($email[0] // ''),
73             Net::IDN::Encode::domain_to_ascii($email[1] // ''),
74             );
75             };
76              
77 0 0 0     0 return $err ? 'Does not match idn-email format.' : $@ || undef;
78             }
79              
80             sub check_idn_hostname {
81 1 50   1 1 7 return _module_missing('idn-hostname' => 'Net::IDN::Encode')
82             unless NET_IDN_ENCODE;
83              
84 0         0 local $@;
85 0         0 my $err = eval { check_hostname(Net::IDN::Encode::domain_to_ascii($_[0])) };
  0         0  
86 0 0 0     0 return $err ? 'Does not match idn-hostname format.' : $@ || undef;
87             }
88              
89             sub check_iri {
90 4     4 1 9 local $IRI_TEST_NAME = 'iri';
91 4 100       28 return 'Scheme missing.' unless $_[0] =~ m!^\w+:!;
92 3         7 return check_iri_reference($_[0]);
93             }
94              
95             sub check_iri_reference {
96 172 50   172 1 1255 return "Does not match $IRI_TEST_NAME format."
97             unless $_[0]
98             =~ m!^(([^:/?#]+):)?(//([^/?#]*))?([^?#]*)(\?([^#]*))?(#(.*))?!;
99              
100             my ($scheme, $auth_host, $path, $query, $has_fragment, $fragment)
101 172   100     410 = map { $_ // '' } ($2, $4, $5, $7, $8, $9);
  1032         3548  
102              
103 172 100 100     783 return 'Scheme missing.' if length $auth_host and !length $scheme;
104 171 100       556 return 'Scheme, path or fragment are required.'
105             unless length($scheme) + length($path) + length($has_fragment);
106 170 100 100     992 return 'Scheme must begin with a letter.'
107             if length $scheme and lc($scheme) !~ m!^[a-z][a-z0-9\+\-\.]*$!;
108 169 100       468 return 'Invalid hex escape.' if $_[0] =~ /%[^0-9a-f]/i;
109 168 100       382 return 'Hex escapes are not complete.'
110             if $_[0] =~ /%[0-9a-f](:?[^0-9a-f]|$)/i;
111              
112 167 100 66     645 if (defined $auth_host and length $auth_host) {
    100          
113 120 50 33     528 return 'Path cannot be empty and must begin with a /'
114             unless !length $path or $path =~ m!^/!;
115             }
116             elsif ($path =~ m!^//!) {
117 1         5 return 'Path cannot not start with //.';
118             }
119              
120 166         800 return undef;
121             }
122              
123             sub check_json_pointer {
124 5 100 100 5 1 41 return !length $_[0]
125             || $_[0] =~ m!^/! ? undef : 'Does not match json-pointer format.';
126             }
127              
128             sub check_ipv4 {
129 2 50 33 2 1 9 return undef if DATA_VALIDATE_IP and Data::Validate::IP::is_ipv4($_[0]);
130 2         17 my (@octets) = $_[0] =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/;
131             return undef
132 2 100 66     5 if 4 == grep { $_ >= 0 && $_ <= 255 && $_ !~ /^0\d{1,2}$/ } @octets;
  8 100       52  
133 1         5 return 'Does not match ipv4 format.';
134             }
135              
136             sub check_ipv6 {
137 2 50   2 1 11 return _module_missing(ipv6 => 'Data::Validate::IP') unless DATA_VALIDATE_IP;
138 0 0       0 return undef if Data::Validate::IP::is_ipv6($_[0]);
139 0         0 return 'Does not match ipv6 format.';
140             }
141              
142             sub check_relative_json_pointer {
143 5 100   5 1 26 return 'Relative JSON Pointer must start with a non-negative-integer.'
144             unless $_[0] =~ m!^\d+!;
145 4 100       25 return undef if $_[0] =~ m!^(\d+)#?$!;
146 2 50       9 return 'Relative JSON Pointer must have "#" or a JSON Pointer.'
147             unless $_[0] =~ m!^\d+(.+)!;
148 2 100       6 return 'Does not match relative-json-pointer format.'
149             if check_json_pointer($1);
150 1         4 return undef;
151             }
152              
153             sub check_regex {
154 6 100   6 1 12 eval {qr{$_[0]}} ? undef : 'Does not match regex format.';
  6         178  
155             }
156              
157             sub check_time {
158             my @time
159 9     9 1 68 = $_[0] =~ m!^(\d\d):(\d\d):(\d\d(?:\.\d+)?)(?:Z|([+-])(\d+):(\d+))?$!io;
160 9 100       29 return 'Does not match time format.' unless @time;
161 8         21 @time = map { s/^0//; $_ } reverse @time[0 .. 2];
  24         49  
  24         59  
162 8         16 local $@;
163 8 100       14 return undef if eval { Time::Local::timegm(@time, 31, 11, 1947); 1 };
  8         30  
  5         177  
164 3         468 my $err = (split / at /, $@)[0];
165 3         44 $err =~ s!('-?\d+'\s|\s[\d\.]+)!!g;
166 3         7 $err .= '.';
167 3         15 return $err;
168             }
169              
170             sub check_uri {
171 118 50   118 1 459 return 'An URI can only only contain ASCII characters.'
172             if $_[0] =~ m!\P{ASCII}!;
173 118         249 local $IRI_TEST_NAME = 'uri';
174 118         283 return check_iri_reference($_[0]);
175             }
176              
177             sub check_uri_reference {
178 48     48 1 85 local $IRI_TEST_NAME = 'uri-reference';
179 48         113 return check_iri_reference($_[0]);
180             }
181              
182             sub check_uri_template {
183 1     1 1 4 return check_iri($_[0]);
184             }
185              
186             sub _module_missing {
187 6     6   254 warn "[JSON::Validator] Cannot validate $_[0] format: $_[1] is missing"
188             if WARN_MISSING_MODULE;
189 6         67 return undef;
190             }
191              
192             1;
193              
194             =encoding utf8
195              
196             =head1 NAME
197              
198             JSON::Validator::Formats - Functions for validating JSON schema formats
199              
200             =head1 SYNOPSIS
201              
202             use JSON::Validator::Formats;
203             my $error = JSON::Validator::Formats::check_uri($str);
204             die $error if $error;
205              
206             my $jv = JSON::Validator->new;
207             $jv->formats({
208             "date-time" => JSON::Validator::Formats->can("check_date_time"),
209             "email" => JSON::Validator::Formats->can("check_email"),
210             "hostname" => JSON::Validator::Formats->can("check_hostname"),
211             "ipv4" => JSON::Validator::Formats->can("check_ipv4"),
212             "ipv6" => JSON::Validator::Formats->can("check_ipv6"),
213             "regex" => JSON::Validator::Formats->can("check_regex"),
214             "uri" => JSON::Validator::Formats->can("check_uri"),
215             "uri-reference" => JSON::Validator::Formats->can("check_uri_reference"),
216             });
217              
218             =head1 DESCRIPTION
219              
220             L is a module with utility functions used by
221             L to match JSON Schema formats.
222             All functions return C for success or an error message for failure.
223              
224             =head1 FUNCTIONS
225              
226             =head2 check_date
227              
228             my $str_or_undef = check_date $str;
229              
230             Validates the date part of a RFC3339 string.
231              
232             =head2 check_date_time
233              
234             my $str_or_undef = check_date_time $str;
235              
236             Validated against RFC3339 timestamp in UTC time. This is formatted as
237             "YYYY-MM-DDThh:mm:ss.fffZ". The milliseconds portion (".fff") is optional
238              
239             =head2 check_email
240              
241             my $str_or_undef = check_email $str;
242              
243             Validated against the RFC5322 spec.
244              
245             =head2 check_hostname
246              
247             my $str_or_undef = check_hostname $str;
248              
249             Will be validated using L, if installed.
250              
251             =head2 check_idn_email
252              
253             my $str_or_undef = check_idn_email $str;
254              
255             Will validate an email with non-ASCII characters using L if
256             installed.
257              
258             =head2 check_idn_hostname
259              
260             my $str_or_undef = check_idn_hostname $str;
261              
262             Will validate a hostname with non-ASCII characters using L if
263             installed.
264              
265             =head2 check_ipv4
266              
267             my $str_or_undef = check_ipv4 $str;
268              
269             Will be validated using L, if installed or fall
270             back to a plain IPv4 IP regex.
271              
272             =head2 check_ipv6
273              
274             my $str_or_undef = check_ipv6 $str;
275              
276             Will be validated using L, if installed.
277              
278             =head2 check_iri
279              
280             my $str_or_undef = check_iri $str;
281              
282             Validate either an absolute IRI containing ASCII or non-ASCII characters,
283             against the RFC3986 spec.
284              
285             =head2 check_iri_reference
286              
287             my $str_or_undef = check_iri_reference $str;
288              
289             Validate either a relative or absolute IRI containing ASCII or non-ASCII
290             characters, against the RFC3986 spec.
291              
292             =head2 check_json_pointer
293              
294             my $str_or_undef = check_json_pointer $str;
295              
296             Validates a JSON pointer, such as "/foo/bar/42".
297              
298             =head2 check_regex
299              
300             my $str_or_undef = check_regex $str;
301              
302             Will check if the string is a regex, using C.
303              
304             =head2 check_relative_json_pointer
305              
306             my $str_or_undef = check_relative_json_pointer $str;
307              
308             Validates a relative JSON pointer, such as "0/foo" or "3#".
309              
310             =head2 check_time
311              
312             my $str_or_undef = check_time $str;
313              
314             Validates the time and optionally the offset part of a RFC3339 string.
315              
316             =head2 check_uri
317              
318             my $str_or_undef = check_uri $str;
319              
320             Validate either a relative or absolute URI containing just ASCII characters,
321             against the RFC3986 spec.
322              
323             Note that this might change in the future to only check absolute URI.
324              
325             =head2 check_uri_reference
326              
327             my $str_or_undef = check_uri_reference $str;
328              
329             Validate either a relative or absolute URI containing just ASCII characters,
330             against the RFC3986 spec.
331              
332             =head2 check_uri_template
333              
334             my $str_or_undef = check_uri_reference $str;
335              
336             Validate an absolute URI with template characters.
337              
338             =head1 SEE ALSO
339              
340             L.
341              
342             =cut