File Coverage

blib/lib/JSONSchema/Validator/Format.pm
Criterion Covered Total %
statement 134 134 100.0
branch 85 90 94.4
condition 8 9 88.8
subroutine 31 31 100.0
pod 0 23 0.0
total 258 287 89.9


line stmt bran cond sub pod time code
1             package JSONSchema::Validator::Format;
2              
3             # ABSTRACT: Formats of JSON Schema specification
4              
5 7     7   66506 use strict;
  7         23  
  7         220  
6 7     7   38 use warnings;
  7         11  
  7         198  
7 7     7   3063 use Time::Piece;
  7         61509  
  7         33  
8              
9 7     7   544 use Scalar::Util 'looks_like_number';
  7         13  
  7         4089  
10              
11             our @ISA = 'Exporter';
12             our @EXPORT_OK = qw(
13             validate_date_time validate_date validate_time
14             validate_email validate_hostname
15             validate_idn_email
16             validate_uuid
17             validate_ipv4 validate_ipv6
18             validate_byte
19             validate_int32 validate_int64
20             validate_float validate_double
21             validate_regex
22             validate_json_pointer validate_relative_json_pointer
23             validate_uri validate_uri_reference
24             validate_iri validate_iri_reference
25             validate_uri_template
26             );
27              
28             my $DATE_PATTERN = qr/(\d{4})-(\d\d)-(\d\d)/;
29             my $TIME_PATTERN = qr/(\d\d):(\d\d):(\d\d)(?:\.\d+)?/;
30             my $ZONE_PATTERN = qr/[zZ]|([+-])(\d\d):(\d\d)/;
31             my $DATETIME_PATTERN = qr/^${DATE_PATTERN}[tT ]${TIME_PATTERN}(?:${ZONE_PATTERN})?$/;
32             my $DATE_PATTERN_FULL = qr/\A${DATE_PATTERN}\z/;
33             my $TIME_PATTERN_FULL = qr/\A${TIME_PATTERN}(?:${ZONE_PATTERN})?\z/;
34             my $HEX_PATTERN = qr/[0-9A-Fa-f]/;
35             my $UUID_PATTERN = qr/\A${HEX_PATTERN}{8}-${HEX_PATTERN}{4}-${HEX_PATTERN}{4}-[089abAB]${HEX_PATTERN}{3}-${HEX_PATTERN}{12}\z/;
36             my $IPV4_OCTET_PATTERN = qr/\d|[1-9]\d|1\d\d|2[0-4]\d|25[0-5]/;
37             my $IPV4_PATTERN = qr/${IPV4_OCTET_PATTERN}(?:\.${IPV4_OCTET_PATTERN}){3}/;
38             my $IPV4_FINAL_PATTERN = qr/\A${IPV4_PATTERN}\z/;
39             my $IPV6_SINGLE_PATTERN = qr/\A(?:${HEX_PATTERN}{1,4}:){7}${HEX_PATTERN}{1,4}\z/;
40             my $IPV6_GROUP_PATTERN = qr/(?:${HEX_PATTERN}{1,4}:)*${HEX_PATTERN}{1,4}/;
41             my $IPV6_MULTI_GROUP_PATTERN = qr/\A(?:${IPV6_GROUP_PATTERN}|)::(?:${IPV6_GROUP_PATTERN}|)\z/;
42             my $IPV6_SINGLE_IPV4_PATTERN = qr/\A((?:${HEX_PATTERN}{1,4}:){6})((?:\d{1,3}\.){3}\d{1,3})\z/;
43             my $IPV6_MULTI_GROUP_IPV4_PATTERN = qr/\A((?:${IPV6_GROUP_PATTERN}|)::(?:${IPV6_GROUP_PATTERN}:|))((?:\d{1,3}\.){3}\d{1,3})\z/;
44             my $BASE64_PATTERN = qr/\A(?:|[A-Za-z0-9\+\/]+=?=?)\z/;
45             my $INTEGER_PATTERN = qr/\A[\+\-]?\d+\z/;
46             my $UCSCHAR_PATTERN = qr/
47             [\x{A0}-\x{D7FF}\x{F900}-\x{FDCF}\x{FDF0}-\x{FFEF}] |
48             [\x{10000}-\x{1FFFD}\x{20000}-\x{2FFFD}\x{30000}-\x{3FFFD}] |
49             [\x{40000}-\x{4FFFD}\x{50000}-\x{5FFFD}\x{60000}-\x{6FFFD}] |
50             [\x{70000}-\x{7FFFD}\x{80000}-\x{8FFFD}\x{90000}-\x{9FFFD}] |
51             [\x{A0000}-\x{AFFFD}\x{B0000}-\x{BFFFD}\x{C0000}-\x{CFFFD}] |
52             [\x{D0000}-\x{DFFFD}\x{E1000}-\x{EFFFD}]
53             /x;
54             my $IPRIVATE_PATTERN = qr/[\x{E000}-\x{F8FF}\x{F0000}-\x{FFFFD}\x{100000}-\x{10FFFD}]/;
55             my $IPV6_PATTERN = do {
56             my $HEXDIG = qr/[A-Fa-f0-9]/;
57             my $h16 = qr/${HEXDIG}{1,4}/;
58             my $ls32 = qr/(?:${h16}:${h16})|${IPV4_PATTERN}/;
59             qr/
60             (?:${h16}:){6} ${ls32} |
61             :: (?:${h16}:){5} ${ls32} |
62             (?: ${h16})? :: (?:${h16}:){4} ${ls32} |
63             (?:(?:${h16}:){0,1} ${h16})? :: (?:${h16}:){3} ${ls32} |
64             (?:(?:${h16}:){0,2} ${h16})? :: (?:${h16}:){2} ${ls32} |
65             (?:(?:${h16}:){0,3} ${h16})? :: (?:${h16}:){1} ${ls32} |
66             (?:(?:${h16}:){0,4} ${h16})? :: ${ls32} |
67             (?:(?:${h16}:){0,5} ${h16})? :: ${h16} |
68             (?:(?:${h16}:){0,6} ${h16})? ::
69             /x;
70             };
71             my $IPV6_FINAL_PATTERN = qr/\A${IPV6_PATTERN}\z/;
72              
73             my $HOSTNAME_PATTERN = do {
74             my $ldh_str = qr/(?:[A-Za-z0-9\-])+/;
75             my $label = qr/[A-Za-z](?:(?:${ldh_str})?[A-Za-z0-9])?/;
76             qr/\A${label}(?:\.${label})*\z/;
77             };
78              
79             my $EMAIL_PATTERN = do {
80 7     7   79 use re 'eval';
  7         39  
  7         18610  
81             my $obs_NO_WS_CTL = qr/[\x01-\x08\x0b\x0c\x0e-\x1f\x7f]/;
82             my $obs_qp = qr/\\(?:\x00|${obs_NO_WS_CTL}|\n|\r)/;
83             my $quoted_pair = qr/\\(?:[\x21-\x7e]|[ \t])|${obs_qp}/;
84             my $obs_FWS = qr/[ \t]+(?:\r\n[ \t]+)*/;
85             my $FWS = qr/(?:[ \t]*\r\n)?[ \t]+|${obs_FWS}/;
86             my $ctext = qr/[\x21-\x27\x2a-\x5b\x5d-\x7e]|${obs_NO_WS_CTL}/;
87             my $comment;
88             $comment = qr/\((?:(?:${FWS})?(?:${ctext}|${quoted_pair}|(??{$comment})))*(?:${FWS})?\)/;
89             my $CFWS = qr/(?:(?:${FWS})?${comment})+(?:${FWS})?|${FWS}/;
90             my $atext = qr/[A-Za-z0-9!#\$\%&'*+\/=?\^_`{|}~\-]/;
91             my $dot_atom_text = qr/(?:${atext})+(?:\.(?:${atext})+)*/;
92             my $dot_atom = qr/(?:${CFWS})?${dot_atom_text}(?:${CFWS})?/;
93             my $obs_dtext = qr/${obs_NO_WS_CTL}|${quoted_pair}/;
94             my $dtext = qr/[\x21-\x5a\x5e-\x7e]|${obs_dtext}/;
95             my $domain_literal = qr/(?:${CFWS})?\[(?:(?:${FWS})?${dtext})*(?:${FWS})?\](?:${CFWS})?/;
96             my $obs_qtext = $obs_NO_WS_CTL;
97             my $qtext = qr/[\x21\x23-\x5b\x5d-\x7e]|${obs_qtext}/;
98             my $qcontent = qr/${qtext}|${quoted_pair}/;
99             my $quoted_string = qr/(?:${CFWS})?\x22(?:(?:${FWS})?${qcontent})*(?:${FWS})?\x22(?:${CFWS})?/;
100             my $atom = qr/(?:${CFWS})?(?:${atext})+(?:${CFWS})?/;
101             my $word = qr/${atom}|${quoted_string}/;
102             my $obs_local_part = qr/${word}(?:\.${word})*/;
103             my $local_part = qr/${dot_atom}|${quoted_string}|${obs_local_part}/;
104             my $obs_domain = qr/${atom}(?:\.${atom})*/;
105             my $domain = qr/${dot_atom}|${domain_literal}|${obs_domain}/;
106             qr/\A${local_part}\@${domain}\z/;
107             };
108              
109             my $IDN_EIMAIL_PATTERN = do {
110             # from rfc3629 UTF-{1,4} given in octet sequence of utf8
111             # transform it to unicode number
112             my $UTF8_non_ascii = qr/
113             [\x80-\x{D7FF}] | [\x{E000}-\x{FDCF}] | [\x{FDF0}-\x{FFFD}] |
114             [\x{10000}-\x{1FFFD}] | [\x{20000}-\x{2FFFD}] | [\x{30000}-\x{3FFFD}] |
115             [\x{40000}-\x{4fffd}] | [\x{50000}-\x{5fffd}] | [\x{60000}-\x{6fffd}] |
116             [\x{70000}-\x{7fffd}] | [\x{80000}-\x{8fffd}] | [\x{90000}-\x{9fffd}] |
117             [\x{a0000}-\x{afffd}] | [\x{b0000}-\x{bfffd}] | [\x{c0000}-\x{cfffd}] |
118             [\x{d0000}-\x{dfffd}] | [\x{e0000}-\x{efffd}] | [\x{f0000}-\x{ffffd}] |
119             [\x{100000}-\x{10fffd}]
120             /x;
121             my $atext = qr/[A-Za-z0-9!#\$\%&'*+\/=?\^_`{|}~\-]|${UTF8_non_ascii}/;
122             my $quoted_pairSMTP = qr/\x5c[\x20-\x7e]/;
123             my $qtextSMTP = qr/[\x20\x21\x23-\x5b\x5d-\x7e]|${UTF8_non_ascii}/;
124             my $QcontentSMTP = qr/${qtextSMTP}|${quoted_pairSMTP}/;
125             my $quoted_string = qr/\x22(?:${QcontentSMTP})*\x22/;
126             my $atom = qr/(?:${atext})+/;
127             my $dot_string = qr/${atom}(?:\.${atom})*/;
128             my $local_part = qr/${dot_string}|${quoted_string}/;
129             my $let_dig = qr/[A-Za-z0-9]/;
130             my $ldh_str = qr/(?:[A-Za-z0-9\-])*${let_dig}/;
131             my $Standardized_tag = qr/${ldh_str}/;
132             my $dcontent = qr/[\x21-\x5a\x5e-\x7e]/;
133             my $General_address_literal = qr/${Standardized_tag}:(?:${dcontent})+/;
134             my $IPv6_address_literal = qr/IPv6:${IPV6_PATTERN}/;
135             my $address_literal = qr/\[(?:${IPV4_PATTERN}|${IPv6_address_literal}|${General_address_literal})\]/;
136             my $sub_domain = qr/${let_dig}(?:${ldh_str})?|(?:${UCSCHAR_PATTERN})*/; # couldn't find ABNF for U-label from rfc5890 use ucschar instead
137             my $domain = qr/${sub_domain}(?:\.${sub_domain})*/;
138             qr/\A${local_part}\@(?:${domain}|${address_literal})\z/;
139             };
140              
141             sub URI_IRI_REGEXP_BUILDER {
142 14     14 0 42 my $is_iri = shift;
143              
144 14         37 my $alpha = qr/[A-Za-z]/;
145 14         37 my $HEXDIG = qr/[A-Fa-f0-9]/;
146 14         124 my $h16 = qr/${HEXDIG}{1,4}/;
147 14         46 my $sub_delims = qr/[!\$&'\(\)\*\+,;=]/;
148 14         36 my $gen_delims = qr/[:\/\?#\[\]\@]/;
149 14         185 my $reserved = qr/${gen_delims}|${sub_delims}/;
150 14         161 my $unreserved = qr/${alpha}|\d|\-|\.|_|~/;
151 14         32 my $iunreserved = $unreserved;
152 14 100       62 if ($is_iri) {
153 7         350 $iunreserved = qr/${alpha}|\d|\-|\.|_|~|${UCSCHAR_PATTERN}/;
154             }
155 14         120 my $pct_encoded = qr/\%${HEXDIG}${HEXDIG}/;
156 14         720 my $pchar = qr/${iunreserved}|${pct_encoded}|${sub_delims}|:|\@/;
157 14         857 my $fragment = qr/(?:${pchar}|\/|\?)*/;
158 14         757 my $query = qr/(?:${pchar}|\/|\?)*/;
159 14 100       80 if ($is_iri) {
160 7         469 $query = qr/(?:${pchar}|${IPRIVATE_PATTERN}|\/|\?)*/;
161             }
162 14         628 my $segment_nz_nc = qr/(?:${iunreserved}|${pct_encoded}|${sub_delims}|\@)+/;
163 14         705 my $segment_nz = qr/(?:${pchar})+/;
164 14         700 my $segment = qr/(?:${pchar})*/;
165 14         1351 my $path_rootless = qr/${segment_nz}(?:\/${segment})*/;
166 14         1279 my $path_noscheme = qr/${segment_nz_nc}(?:\/${segment})*/;
167 14         1145 my $path_absolute = qr/\/(?:${segment_nz}(?:\/${segment})*)?/;
168 14         571 my $path_abempty = qr/(?:\/${segment})*/;
169 14         819 my $reg_name = qr/(?:${iunreserved}|${pct_encoded}|${sub_delims})*/;
170 14         266 my $IPvFuture = qr/v${HEXDIG}+\.(?:${unreserved}|${sub_delims}|:)+/; # must be unreserved, not iunreserved
171 14         1996 my $IP_literal = qr/\[(?:${IPV6_PATTERN}|${IPvFuture})\]/;
172 14         78 my $port = qr/\d*/;
173 14         4744 my $host = qr/${IP_literal}|${IPV4_PATTERN}|${reg_name}/;
174 14         843 my $userinfo = qr/(?:${iunreserved}|${pct_encoded}|${sub_delims}|:)*/;
175 14         5420 my $authority = qr/(?:${userinfo}\@)?${host}(?::${port})?/;
176 14         306 my $scheme = qr/${alpha}(?:${alpha}|\d|\+|\-|\.)*/;
177 14         7297 my $hier_part = qr!//${authority}${path_abempty}|${path_absolute}|${path_rootless}|!;
178 14         8376 my $uri = qr/\A${scheme}:${hier_part}(?:\?${query})?(?:#${fragment})?\z/;
179 14         7873 my $relative_part = qr!//${authority}${path_abempty}|${path_absolute}|${path_noscheme}|!;
180 14         8622 my $relative_ref = qr/\A${relative_part}(?:\?${query})?(?:#${fragment})?\z/;
181 14         17368 my $uri_reference = qr/${uri}|${relative_ref}/;
182 14         686 ($uri, $uri_reference);
183             }
184              
185             my ($URI_PATTERN, $URI_REFERENCE_PATTERN) = URI_IRI_REGEXP_BUILDER(0);
186             my ($IRI_PATTERN, $IRI_REFERENCE_PATTERN) = URI_IRI_REGEXP_BUILDER(1);
187              
188             my $URI_TEMPLATE_PATTERN = do {
189             my $alpha = qr/[A-Za-z]/;
190             my $HEXDIG = qr/[A-Fa-f0-9]/;
191             my $pct_encoded = qr/\%${HEXDIG}${HEXDIG}/;
192             my $unreserved = qr/${alpha}|\d|\-|\.|_|~/;
193             my $sub_delims = qr/[!\$&'\(\)\*\+,;=]/;
194             my $gen_delims = qr/[:\/\?#\[\]\@]/;
195             my $reserved = qr/${gen_delims}|${sub_delims}/;
196             my $explode = qr/\*/;
197             my $max_length = qr/[1-9]\d{0,3}/;
198             my $prefix = qr/:${max_length}/;
199             my $modifier_level4 = qr/${prefix}|${explode}/;
200             my $varchar = qr/${alpha}|\d|_|${pct_encoded}/;
201             my $varname = qr/${varchar}(?:\.?${varchar})*/;
202             my $varspec = qr/${varname}(?:${modifier_level4})?/;
203             my $variable_list = qr/${varspec}(?:,${varspec})*/;
204             my $op_reserve = qr/[=,!\@\|]/;
205             my $op_level3 = qr/[\.\/;\?&]/;
206             my $op_level2 = qr/[\+#]/;
207             my $operator = qr/${op_level2}|${op_level3}|${op_reserve}/;
208             my $expression = qr/\{(?:${operator})?${variable_list}\}/;
209             my $literals = qr/
210             [\x21\x23\x24\x26\x28-\x3B\x3D\x3F-\x5B] |
211             [\x5D\x5F\x61-\x7A\x7E] |
212             ${UCSCHAR_PATTERN} |
213             ${IPRIVATE_PATTERN} |
214             ${pct_encoded}
215             /x;
216             qr/\A(?:${literals}|${expression})*\z/;
217             };
218              
219             sub validate_date_time {
220 8     8 0 85 my @dt = $_[0] =~ $DATETIME_PATTERN;
221              
222 8         23 my ($Y, $m, $d, $H, $M, $S, $sign, $HH, $MM) = @dt;
223              
224 8         19 my $r = _validate_date($Y, $m, $d);
225 8 50       17 return 0 unless $r;
226              
227 8         18 $r = _validate_time($H, $M, $S, $sign, $HH, $MM);
228 8 100       26 return 0 unless $r;
229              
230 6         26 return 1;
231             }
232              
233             sub validate_date {
234 5     5 0 32 my @dt = $_[0] =~ $DATE_PATTERN_FULL;
235 5         16 return _validate_date(@dt);
236             }
237              
238             sub _validate_date {
239 13     13   24 my ($Y, $m, $d) = @_;
240              
241 13         28 for ($Y, $m, $d) {
242 33 100       73 return 0 unless defined $_;
243             }
244              
245 10         12 my $date2;
246 10         16 eval { $date2 = Time::Piece->strptime("$Y-$m-$d", '%Y-%m-%d'); };
  10         50  
247 10 50       628 return 0 if $@;
248              
249             # need to recheck values (test 2019-02-30)
250 10 50       26 return 0 unless $date2->year == $Y;
251 10 100       123 return 0 unless $date2->mon == $m;
252 9 50       55 return 0 unless $date2->mday == $d;
253              
254 9         55 return 1;
255             }
256              
257             sub validate_time {
258 14     14 0 122 my @dt = $_[0] =~ $TIME_PATTERN_FULL;
259 14         34 return _validate_time(@dt);
260             }
261              
262             sub _validate_time {
263 22     22   48 my ($H, $M, $S, $sign, $HH, $MM) = @_;
264              
265 22         37 for ($H, $M, $S) {
266 64 100       115 return 0 unless defined $_;
267             }
268              
269 21 100       54 return 0 if $H > 23;
270 20 100       44 return 0 if $M > 59;
271 19 100       37 return 0 if $S > 60;
272              
273 18 100 66     59 if ($HH && $MM) {
274 11 100       32 return 0 if $HH > 23;
275 8 100       28 return 0 if $MM > 59;
276             }
277              
278 12         38 return 1;
279             }
280              
281             sub validate_uuid {
282             # from rfc4122
283             # Today, there are versions 1-5. Version 6-F for future use.
284             # [089abAB] - variants
285 7 100   7 0 155 return $_[0] =~ $UUID_PATTERN ? 1 : 0;
286             }
287              
288             sub validate_ipv4 {
289             # from rfc2673
290 9 100   9 0 98 return $_[0] =~ $IPV4_FINAL_PATTERN ? 1 : 0;
291             }
292              
293             sub validate_ipv6 {
294             # from rfc2373
295 23 100   23 0 342 return $_[0] =~ $IPV6_FINAL_PATTERN ? 1 : 0;
296             }
297              
298             sub validate_hostname {
299             # from rfc1034
300 8     8 0 19 my $hostname = shift;
301 8 100       25 return 0 if length $hostname > 255;
302              
303             # remove root empty label
304 7         19 $hostname =~ s/\.\z//;
305              
306 7 100       63 return 0 unless $hostname =~ $HOSTNAME_PATTERN;
307              
308 4         18 my @labels = split /\./, $hostname, -1;
309 4         11 my @filtered = grep { length() <= 63 } @labels;
  9         23  
310 4 100       15 return 0 unless scalar(@labels) == scalar(@filtered);
311 3         16 return 1;
312             }
313              
314             sub validate_email {
315             # from rfc5322 section 3.4.1 addr-spec
316             # not compatible with rfc5321 section 4.1.2 Mailbox
317 60 100   60 0 1467 return $_[0] =~ $EMAIL_PATTERN ? 1 : 0;
318             }
319              
320             sub validate_idn_email {
321             # from rfc6531 section 3.3 which extend rfc5321 section 4.1.2
322             # not compatible with rfc5322 section 3.4.1 add-spec
323 3 100   3 0 56 return $_[0] =~ $IDN_EIMAIL_PATTERN ? 1 : 0;
324             }
325              
326             sub validate_byte {
327 17 100   17 0 73 return 0 if length($_[0]) % 4 != 0;
328 11 100       101 return 1 if $_[0] =~ $BASE64_PATTERN;
329 3         12 return 0;
330             }
331              
332             sub validate_int32 {
333 30     30 0 74 return _validate_int_32_64($_[0], '214748364');
334             }
335              
336             sub validate_int64 {
337 36     36 0 76 return _validate_int_32_64($_[0], '922337203685477580');
338             }
339              
340             sub _validate_int_32_64 {
341 66     66   183 my ($num, $abs) = @_;
342 66 100       559 return 0 unless $num =~ $INTEGER_PATTERN;
343              
344 56 100       185 my $sign = index($num, '-') == -1 ? 1 : -1;
345 56         175 $num =~ s/\A[\+\-]?0*//;
346              
347 56         89 my $length_num = length $num;
348 56         83 my $length_abs = 1 + length $abs;
349              
350 56 100       138 return 0 if $length_num > $length_abs;
351 52 100       189 return 1 if $length_num < $length_abs;
352              
353 12 100 100     64 return 1 if $sign > 0 && (($abs . '7') cmp $num) >= 0;
354 8 100 100     41 return 1 if $sign < 0 && (($abs . '8') cmp $num) >= 0;
355 4         20 return 0;
356             }
357              
358             sub validate_json_pointer {
359             # from rfc6901:
360             # CORE::state $pointer_regexp = do {
361             # my $escaped = qr/~[01]/;
362             # my $unescaped = qr/\x00-\x2e\x30-\x7d\x7f-\x10FFFF/;
363             # my $reference_token = qr/(?:${unescaped}|${escaped})*/;
364             # qr/(?:\/${reference_token})*/;
365             # };
366              
367             # more simple solution:
368 20 100   20 0 58 return 1 if $_[0] eq '';
369 16 100       415 return 0 unless index($_[0], '/') == 0;
370 13 100       68 return 0 if $_[0] =~ m/~(?:[^01]|\z)/;
371 9         39 return 1;
372             }
373              
374             sub validate_relative_json_pointer {
375             # from draft-handrews-relative-json-pointer-01:
376             # CORE::state $pointer_regexp = do {
377             # my $non_negative_integer = qr/0|[1-9][0-9]*/;
378             # my $relative_json_pointer = qr/${non_negative_integer}(?:#|${json_pointer})/;
379             # };
380              
381             # more simple solution:
382 11     11 0 70 my ($integer, $pointer) = $_[0] =~ m/\A(0|[1-9][0-9]*)(.*)\z/s;
383 11 50       30 return 0 unless defined $integer;
384 11 100       31 return 1 if $pointer eq '#';
385 9         18 return validate_json_pointer($pointer);
386             }
387              
388             sub validate_uri {
389             # from rfc3986 Appendix A.
390 17 100   17 0 758 return $_[0] =~ $URI_PATTERN ? 1 : 0;
391             }
392              
393             sub validate_uri_reference {
394             # from rfc3986 Appendix A.
395 20 100   20 0 740 return $_[0] =~ $URI_REFERENCE_PATTERN ? 1 : 0;
396             }
397              
398             sub validate_iri {
399             # from rfc3987 section 2.2
400 5 100   5 0 287 return $_[0] =~ $IRI_PATTERN ? 1 : 0;
401             }
402              
403             sub validate_iri_reference {
404             # from rfc3987 section 2.2
405 3 100   3 0 87 return $_[0] =~ $IRI_REFERENCE_PATTERN ? 1 : 0;
406             }
407              
408             sub validate_uri_template {
409             # from rfc6570
410 9 100   9 0 157 return $_[0] =~ $URI_TEMPLATE_PATTERN ? 1 : 0;
411             }
412              
413             # validators below need to be improved
414              
415             # no difference between double and float
416             sub validate_float {
417 23 100   23 0 229 return 0 if $_[0] =~ m/\A\s+|\s+\z/;
418 20 100       87 return 0 unless looks_like_number $_[0];
419 16         100 return 1;
420             }
421              
422             sub validate_double {
423 2     2 0 6 return validate_float($_[0]);
424             }
425              
426             # match perl regex but need ecma-262 regex
427             sub validate_regex {
428 9 100   9 0 17 return eval { qr/$_[0]/; } ? 1 : 0;
  9         225  
429             }
430              
431             1;
432              
433             __END__