package JSON::Validator::Formats;
use Mojo::Base -strict;
use Scalar::Util 'looks_like_number';
require Time::Local;
use constant DATA_VALIDATE_DOMAIN => eval 'require Data::Validate::Domain;1';
use constant DATA_VALIDATE_IP => eval 'require Data::Validate::IP;1';
use constant IV_SIZE => eval 'require Config;$Config::Config{ivsize}';
use constant NET_IDN_ENCODE => eval 'require Net::IDN::Encode;1';
use constant WARN_MISSING_MODULE => $ENV{JSON_VALIDATOR_WARN} // 1;
our $IRI_TEST_NAME = 'iri-reference';
sub check_byte {
$_[0] =~ /^[A-Za-z0-9\+\/\=]+$/ ? undef : 'Does not match byte format.';
}
sub check_date {
my @date = $_[0] =~ m!^(\d{4})-(\d\d)-(\d\d)$!io;
return 'Does not match date format.' unless @date;
@date = map { s/^0+//; $_ || 0 } reverse @date;
$date[1] -= 1; # month are zero based
local $@;
return undef if eval { Time::Local::timegm(0, 0, 0, @date); 1 };
my $err = (split / at /, $@)[0];
$err =~ s!('-?\d+'\s|\s[\d\.]+)!!g;
$err .= '.';
return $err;
}
sub check_date_time {
my @dt = $_[0] =~ m!^(\d{4})-(\d\d)-(\d\d)[T ](\d\d):(\d\d):(\d\d(?:\.\d+)?)(?:Z|([+-])(\d\d):(\d\d))?$!io;
return 'Does not match date-time format.' unless @dt;
return 'Time offset hour out of range.' if defined $dt[7] and $dt[7] > 23;
return 'Time offset minute out of range.' if defined $dt[8] and $dt[8] > 59;
@dt = map { s/^0//; $_ } reverse @dt[0 .. 5];
$dt[4] -= 1; # month are zero based
local $@;
return undef if eval { Time::Local::timegm(@dt); 1 };
my $err = (split / at /, $@)[0];
$err =~ s!('-?\d+'\s|\s[\d\.]+)!!g;
$err .= '.';
return $err;
}
sub check_double { _match_number(double => $_[0], '') }
sub check_duration {
state $rfc3339_duration_re = do {
my $num = qr{\d+(?:[,.]\d+)?};
my $sec = qr/${num}S/;
my $min = qr/${num}M(?:$sec)?/;
my $hour = qr/${num}H(?:$min)?/;
my $day = qr/${num}D(?:$hour)?/;
my $mon = qr/${num}M(?:$day)?/;
my $year = qr/${num}Y(?:$mon)?/;
my $week = qr/${num}W/;
my $time = qr/T($hour|$min|$sec)/;
my $date = qr/(?:$day|$mon|$year)(?:$time)?/;
qr{^P(?:$date|$time|$week)$};
};
return $_[0] =~ $rfc3339_duration_re ? undef : 'Does not match duration format.';
}
sub check_email {
state $email_rfc5322_re = do {
my $atom = qr;[a-zA-Z0-9_!#\$\%&'*+/=?\^`{}~|\-]+;o;
my $quoted_string = qr/"(?:\\[^\r\n]|[^\\"])*"/o;
my $domain_literal = qr/\[(?:\\[\x01-\x09\x0B-\x0c\x0e-\x7f]|[\x21-\x5a\x5e-\x7e])*\]/o;
my $dot_atom = qr/$atom(?:[.]$atom)*/o;
my $local_part = qr/(?:$dot_atom|$quoted_string)/o;
my $domain = qr/(?:$dot_atom|$domain_literal)/o;
qr/^$local_part\@$domain$/o;
};
return $_[0] =~ $email_rfc5322_re ? undef : 'Does not match email format.';
}
sub check_float { _match_number(float => $_[0], '') }
sub check_hostname {
return _module_missing(hostname => 'Data::Validate::Domain') unless DATA_VALIDATE_DOMAIN;
return undef if Data::Validate::Domain::is_hostname($_[0]);
return 'Does not match hostname format.';
}
sub check_idn_email {
return _module_missing('idn-email' => 'Net::IDN::Encode') unless NET_IDN_ENCODE;
local $@;
my $err = eval {
my @email = split /@/, $_[0], 2;
check_email(
join '@',
Net::IDN::Encode::to_ascii($email[0] // ''),
Net::IDN::Encode::domain_to_ascii($email[1] // ''),
);
};
return $err ? 'Does not match idn-email format.' : $@ || undef;
}
sub check_idn_hostname {
return _module_missing('idn-hostname' => 'Net::IDN::Encode') unless NET_IDN_ENCODE;
local $@;
my $err = eval { check_hostname(Net::IDN::Encode::domain_to_ascii($_[0])) };
return $err ? 'Does not match idn-hostname format.' : $@ || undef;
}
sub check_int32 { _match_number(int32 => $_[0], 'l') }
sub check_int64 { _match_number(int64 => $_[0], IV_SIZE >= 8 ? 'q' : '') }
sub check_iri {
local $IRI_TEST_NAME = 'iri';
return 'Scheme missing.' unless $_[0] =~ m!^\w+:!;
return check_iri_reference($_[0]);
}
sub check_iri_reference {
return "Does not match $IRI_TEST_NAME format."
unless $_[0] =~ m!^(([^:/?#]+):)?(//([^/?#]*))?([^?#]*)(\?([^#]*))?(#(.*))?!;
my ($scheme, $auth_host, $path, $query, $has_fragment, $fragment) = map { $_ // '' } ($2, $4, $5, $7, $8, $9);
return 'Scheme missing.' if length $auth_host and !length $scheme;
return 'Scheme, path or fragment are required.' unless length($scheme) + length($path) + length($has_fragment);
return 'Scheme must begin with a letter.' if length $scheme and lc($scheme) !~ m!^[a-z][a-z0-9\+\-\.]*$!;
return 'Invalid hex escape.' if $_[0] =~ /%[^0-9a-f]/i;
return 'Hex escapes are not complete.' if $_[0] =~ /%[0-9a-f](:?[^0-9a-f]|$)/i;
if (defined $auth_host and length $auth_host) {
return 'Path cannot be empty and must begin with a /' unless !length $path or $path =~ m!^/!;
}
elsif ($path =~ m!^//!) {
return 'Path cannot not start with //.';
}
return undef;
}
sub check_json_pointer {
return !length $_[0] || $_[0] =~ m!^/! ? undef : 'Does not match json-pointer format.';
}
sub check_ipv4 {
return undef if DATA_VALIDATE_IP and Data::Validate::IP::is_ipv4($_[0]);
my (@octets) = $_[0] =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/;
return undef if 4 == grep { $_ >= 0 && $_ <= 255 && $_ !~ /^0\d{1,2}$/ } @octets;
return 'Does not match ipv4 format.';
}
sub check_ipv6 {
return _module_missing(ipv6 => 'Data::Validate::IP') unless DATA_VALIDATE_IP;
return undef if Data::Validate::IP::is_ipv6($_[0]);
return 'Does not match ipv6 format.';
}
sub check_relative_json_pointer {
return 'Relative JSON Pointer must start with a non-negative-integer.' unless $_[0] =~ m!^\d+!;
return undef if $_[0] =~ m!^(\d+)#?$!;
return 'Relative JSON Pointer must have "#" or a JSON Pointer.' unless $_[0] =~ m!^\d+(.+)!;
return 'Does not match relative-json-pointer format.' if check_json_pointer($1);
return undef;
}
sub check_regex {
eval {qr{$_[0]}} ? undef : 'Does not match regex format.';
}
sub check_time {
my @time = $_[0] =~ m!^(\d\d):(\d\d):(\d\d(?:\.\d+)?)(?:Z|([+-])(\d+):(\d+))?$!io;
return 'Does not match time format.' unless @time;
@time = map { s/^0//; $_ } reverse @time[0 .. 2];
local $@;
return undef if eval { Time::Local::timegm(@time, 31, 11, 1947); 1 };
my $err = (split / at /, $@)[0];
$err =~ s!('-?\d+'\s|\s[\d\.]+)!!g;
$err .= '.';
return $err;
}
sub check_uri {
return 'An URI can only only contain ASCII characters.' if $_[0] =~ m!\P{ASCII}!;
local $IRI_TEST_NAME = 'uri';
return check_iri_reference($_[0]);
}
sub check_uri_reference {
local $IRI_TEST_NAME = 'uri-reference';
return check_iri_reference($_[0]);
}
sub check_uri_template {
return check_iri($_[0]);
}
sub check_uuid {
state $uuid_re = do {
my $x = qr{[0-9A-Fa-f]};
qr{^$x$x$x$x$x$x$x$x-$x$x$x$x-[0-9]$x$x$x-$x$x$x$x-$x$x$x$x$x$x$x$x$x$x$x$x$};
};
return $_[0] =~ $uuid_re ? undef : 'Does not match uuid format.';
}
sub _match_number {
my ($name, $val, $format) = @_;
return 'Does not look like an integer' if $name =~ m!^int! and $val !~ /^-?\d+(\.\d+)?$/;
return 'Does not look like a number.' unless looks_like_number $val;
return undef unless $format;
return undef if $val eq unpack $format, pack $format, $val;
return "Does not match $name format.";
}
sub _module_missing {
warn "[JSON::Validator] Cannot validate $_[0] format: $_[1] is missing" if WARN_MISSING_MODULE;
return undef;
}
1;
=encoding utf8
=head1 NAME
JSON::Validator::Formats - Functions for validating JSON schema formats
=head1 SYNOPSIS
use JSON::Validator::Formats;
my $error = JSON::Validator::Formats::check_uri($str);
die $error if $error;
my $jv = JSON::Validator->new;
$jv->formats({
"date-time" => JSON::Validator::Formats->can("check_date_time"),
"email" => JSON::Validator::Formats->can("check_email"),
"hostname" => JSON::Validator::Formats->can("check_hostname"),
"ipv4" => JSON::Validator::Formats->can("check_ipv4"),
"ipv6" => JSON::Validator::Formats->can("check_ipv6"),
"regex" => JSON::Validator::Formats->can("check_regex"),
"uri" => JSON::Validator::Formats->can("check_uri"),
"uri-reference" => JSON::Validator::Formats->can("check_uri_reference"),
});
=head1 DESCRIPTION
L<JSON::Validator::Formats> is a module with utility functions used by
L<JSON::Validator/formats> to match JSON Schema formats.
All functions return C<undef> for success or an error message for failure.
=head1 FUNCTIONS
=head2 check_byte
my $str_or_undef = check_byte $str;
Checks that the string matches byte format.
=head2 check_date
my $str_or_undef = check_date $str;
Validates the date part of a RFC3339 string.
=head2 check_date_time
my $str_or_undef = check_date_time $str;
Validated against RFC3339 timestamp in UTC time. This is formatted as
"YYYY-MM-DDThh:mm:ss.fffZ". The milliseconds portion (".fff") is optional
=head2 check_duration
my $str_or_undef = check_duration $str;
Validate a RFC3339 duration string, such as "P3Y6M4DT12H30M5S".
=head2 check_double
my $str_or_undef = check_double $number;
Tries to check if the number is a double. Note that this check is not very
accurate.
=head2 check_email
my $str_or_undef = check_email $str;
Validated against the RFC5322 spec.
=head2 check_float
my $str_or_undef = check_float $number;
Tries to check if the number is a float. Note that this check is not very
accurate.
=head2 check_hostname
my $str_or_undef = check_hostname $str;
Will be validated using L<Data::Validate::Domain/is_hostname>, if installed.
=head2 check_idn_email
my $str_or_undef = check_idn_email $str;
Will validate an email with non-ASCII characters using L<Net::IDN::Encode> if
installed.
=head2 check_idn_hostname
my $str_or_undef = check_idn_hostname $str;
Will validate a hostname with non-ASCII characters using L<Net::IDN::Encode> if
installed.
=head2 check_int32
my $str_or_undef = check_int32 $number;
Tries to check if the number is a int32. Note that this check is not very
accurate.
=head2 check_int64
my $str_or_undef = check_int64 $number;
Tries to check if the number is a int64. Note that this check is not very
accurate.
=head2 check_ipv4
my $str_or_undef = check_ipv4 $str;
Will be validated using L<Data::Validate::IP/is_ipv4>, if installed or fall
back to a plain IPv4 IP regex.
=head2 check_ipv6
my $str_or_undef = check_ipv6 $str;
Will be validated using L<Data::Validate::IP/is_ipv6>, if installed.
=head2 check_iri
my $str_or_undef = check_iri $str;
Validate either an absolute IRI containing ASCII or non-ASCII characters,
against the RFC3986 spec.
=head2 check_iri_reference
my $str_or_undef = check_iri_reference $str;
Validate either a relative or absolute IRI containing ASCII or non-ASCII
characters, against the RFC3986 spec.
=head2 check_json_pointer
my $str_or_undef = check_json_pointer $str;
Validates a JSON pointer, such as "/foo/bar/42".
=head2 check_regex
my $str_or_undef = check_regex $str;
Will check if the string is a regex, using C<qr{...}>.
=head2 check_relative_json_pointer
my $str_or_undef = check_relative_json_pointer $str;
Validates a relative JSON pointer, such as "0/foo" or "3#".
=head2 check_time
my $str_or_undef = check_time $str;
Validates the time and optionally the offset part of a RFC3339 string.
=head2 check_uri
my $str_or_undef = check_uri $str;
Validate either a relative or absolute URI containing just ASCII characters,
against the RFC3986 spec.
Note that this might change in the future to only check absolute URI.
=head2 check_uri_reference
my $str_or_undef = check_uri_reference $str;
Validate either a relative or absolute URI containing just ASCII characters,
against the RFC3986 spec.
=head2 check_uri_template
my $str_or_undef = check_uri_reference $str;
Validate an absolute URI with template characters.
=head2 check_uuid
my $str_or_undef = check_uuid $str;
Will check if C<$str> looks like an UUID. Example UUID:
"5782165B-6BB6-472F-B3DD-369D707D6C72".
=head1 SEE ALSO
L<JSON::Validator>.
=cut