use
constant
CASE_TOLERANT
=> File::Spec->case_tolerant;
use
constant
DEBUG
=>
$ENV
{JSON_VALIDATOR_DEBUG} || 0;
use
constant
REPORT
=>
$ENV
{JSON_VALIDATOR_REPORT} // DEBUG >= 2;
use
constant
RECURSION_LIMIT
=>
$ENV
{JSON_VALIDATOR_RECURSION_LIMIT} || 100;
our
$DEFINITIONS
=
'definitions'
;
our
$VERSION
=
'3.13'
;
our
$YAML_LOADER
=
eval
q[use YAML::XS 0.67; YAML::XS->can('Load')]
;
our
@EXPORT_OK
=
qw(joi validate_json)
;
my
$BUNDLED_CACHE_DIR
= path(path(__FILE__)->dirname,
qw(Validator cache)
);
my
$HTTP_SCHEME_RE
=
qr{^https?:}
;
sub
D {
Data::Dumper->new([
@_
])->Sortkeys(1)->Indent(0)->Maxdepth(2)->Pair(
':'
)
->Useqq(1)->Terse(1)->Dump;
}
sub
E { JSON::Validator::Error->new(
@_
) }
sub
S {
Mojo::Util::md5_sum(Data::Dumper->new([
@_
])->Sortkeys(1)->Useqq(1)->Dump);
}
has
cache_paths
=>
sub
{
return
[
split
(/:/,
$ENV
{JSON_VALIDATOR_CACHE_PATH} ||
''
),
$BUNDLED_CACHE_DIR
];
};
has
formats
=>
sub
{
shift
->_build_formats };
has
version
=> 4;
has
ua
=>
sub
{
my
$ua
= Mojo::UserAgent->new;
$ua
->proxy->detect;
$ua
->max_redirects(3);
$ua
;
};
sub
bundle {
my
(
$self
,
$args
) =
@_
;
my
@topics
= ([
undef
,
my
$bundle
= {}]);
my
(
$cloner
,
$tied
);
$topics
[0][0]
=
$args
->{schema} ?
$self
->_resolve(
$args
->{schema}) :
$self
->schema->data;
local
$DEFINITIONS
=
$args
->{ref_key} ||
$DEFINITIONS
;
Mojo::Util::deprecated(
'bundle({ref_key => "..."}) will be removed.'
)
if
$args
->{ref_key};
if
(
$args
->{replace}) {
$cloner
=
sub
{
my
$from
=
shift
;
my
$ref
=
ref
$from
;
$from
=
$tied
->schema
if
$ref
eq
'HASH'
and
$tied
=
tied
%$from
;
my
$to
=
$ref
eq
'ARRAY'
? [] :
$ref
eq
'HASH'
? {} :
$from
;
push
@topics
, [
$from
,
$to
]
if
$ref
;
return
$to
;
};
}
else
{
my
%seen
;
$bundle
->{
$DEFINITIONS
} =
$topics
[0][0]{
$DEFINITIONS
} || {};
$cloner
=
sub
{
my
$from
=
shift
;
my
$from_type
=
ref
$from
;
if
(
$from_type
eq
'HASH'
and
my
$ref
=
tied
%$from
) {
return
$from
if
!
$args
->{schema}
and
$ref
->fqn =~ m!^\Q
$self
->{root_schema_url}\E\
my
$k
=
$self
->_definitions_key(
$bundle
,
$ref
, \
%seen
);
push
@topics
, [
$ref
->schema,
$bundle
->{
$DEFINITIONS
}{
$k
} ||= {}]
unless
$seen
{
$ref
->fqn}++;
tie
my
%ref
,
'JSON::Validator::Ref'
,
$ref
->schema,
"#/$DEFINITIONS/$k"
;
return
\
%ref
;
}
my
$to
=
$from_type
eq
'ARRAY'
? [] :
$from_type
eq
'HASH'
? {} :
$from
;
push
@topics
, [
$from
,
$to
]
if
$from_type
;
return
$to
;
};
}
while
(
@topics
) {
my
(
$from
,
$to
) = @{
shift
@topics
};
if
(
ref
$from
eq
'ARRAY'
) {
for
(
my
$i
= 0;
$i
<
@$from
;
$i
++) {
$to
->[
$i
] =
$cloner
->(
$from
->[
$i
]);
}
}
elsif
(
ref
$from
eq
'HASH'
) {
while
(
my
(
$key
,
$value
) =
each
%$from
) {
$to
->{
$key
} //=
$cloner
->(
$from
->{
$key
});
}
}
}
delete
$bundle
->{
$DEFINITIONS
}
unless
keys
%{
$bundle
->{
$DEFINITIONS
}};
return
$bundle
;
}
sub
coerce {
my
$self
=
shift
;
return
$self
->{coerce} ||= {}
unless
defined
(
my
$what
=
shift
);
if
(
$what
eq
'1'
) {
Mojo::Util::deprecated(
'coerce(1) will be deprecated.'
);
$what
= {
booleans
=> 1,
numbers
=> 1,
strings
=> 1};
}
state
$short
= {
bool
=>
'booleans'
,
def
=>
'defaults'
,
num
=>
'numbers'
,
str
=>
'strings'
};
$what
= {
map
{ (
$_
=> 1) }
split
/,/,
$what
}
unless
ref
$what
;
$self
->{coerce} = {};
$self
->{coerce}{(
$short
->{
$_
} ||
$_
)} =
$what
->{
$_
}
for
keys
%$what
;
return
$self
;
}
sub
get {
my
(
$self
,
$p
) =
@_
;
$p
= [
ref
$p
?
@$p
:
length
$p
?
split
(
'/'
,
$p
, -1) :
$p
];
shift
@$p
if
@$p
and
defined
$p
->[0] and !
length
$p
->[0];
$self
->_get(
$self
->schema->data,
$p
,
''
);
}
sub
joi {
return
JSON::Validator::Joi->new
unless
@_
;
my
(
$data
,
$joi
) =
@_
;
return
$joi
->validate(
$data
,
$joi
);
}
sub
load_and_validate_schema {
my
(
$self
,
$spec
,
$args
) =
@_
;
my
$schema
=
$args
->{schema} || SPECIFICATION_URL;
$self
->version($1)
if
!
$self
->{version} and
$schema
=~ /draft-0+(\w+)/;
$spec
=
$self
->_resolve(
$spec
);
my
@errors
=
$self
->new(
%$self
)->schema(
$schema
)->validate(
$spec
);
confess
join
"\n"
,
"Invalid JSON specification $spec:"
,
map
{
"- $_"
}
@errors
if
@errors
;
$self
->{schema} = Mojo::JSON::Pointer->new(
$spec
);
$self
;
}
sub
new {
my
$self
=
shift
->SUPER::new(
@_
);
$self
->coerce(
$self
->{coerce})
if
defined
$self
->{coerce};
return
$self
;
}
sub
schema {
my
$self
=
shift
;
return
$self
->{schema}
unless
@_
;
$self
->{schema} = Mojo::JSON::Pointer->new(
$self
->_resolve(
shift
));
return
$self
;
}
sub
singleton { state
$jv
=
shift
->new }
sub
validate {
my
(
$self
,
$data
,
$schema
) =
@_
;
$schema
||=
$self
->schema->data;
return
E
'/'
,
'No validation rules defined.'
unless
$schema
and
%$schema
;
local
$self
->{grouped} = 0;
local
$self
->{schema} = Mojo::JSON::Pointer->new(
$schema
);
local
$self
->{seen} = {};
local
$self
->{temp_schema} = [];
$self
->{report} = [];
my
@errors
=
$self
->_validate(
$_
[1],
''
,
$schema
);
$self
->_report
if
DEBUG and REPORT;
return
@errors
;
}
sub
validate_json {
__PACKAGE__->singleton->schema(
$_
[1])->validate(
$_
[0]);
}
sub
_build_formats {
return
{
'date'
=> JSON::Validator::Formats->can(
'check_date'
),
'date-time'
=> JSON::Validator::Formats->can(
'check_date_time'
),
'email'
=> JSON::Validator::Formats->can(
'check_email'
),
'hostname'
=> JSON::Validator::Formats->can(
'check_hostname'
),
'idn-email'
=> JSON::Validator::Formats->can(
'check_idn_email'
),
'idn-hostname'
=> JSON::Validator::Formats->can(
'check_idn_hostname'
),
'ipv4'
=> JSON::Validator::Formats->can(
'check_ipv4'
),
'ipv6'
=> JSON::Validator::Formats->can(
'check_ipv6'
),
'iri'
=> JSON::Validator::Formats->can(
'check_iri'
),
'iri-reference'
=> JSON::Validator::Formats->can(
'check_iri_reference'
),
'json-pointer'
=> JSON::Validator::Formats->can(
'check_json_pointer'
),
'regex'
=> JSON::Validator::Formats->can(
'check_regex'
),
'relative-json-pointer'
=>
JSON::Validator::Formats->can(
'check_relative_json_pointer'
),
'time'
=> JSON::Validator::Formats->can(
'check_time'
),
'uri'
=> JSON::Validator::Formats->can(
'check_uri'
),
'uri-reference'
=> JSON::Validator::Formats->can(
'check_uri_reference'
),
'uri-reference'
=> JSON::Validator::Formats->can(
'check_uri_reference'
),
'uri-template'
=> JSON::Validator::Formats->can(
'check_uri_template'
),
};
}
sub
_definitions_key {
my
(
$self
,
$bundle
,
$ref
,
$seen
) =
@_
;
return
$1
if
$ref
->fqn =~ m!
and (
$seen
->{
$ref
->fqn}
or !
$bundle
->{
$DEFINITIONS
}{$1}
or D(
$ref
->schema) eq D(
$bundle
->{
$DEFINITIONS
}{$1}));
my
$key
=
$ref
->fqn;
my
$spec_path
= (
split
'#'
,
$key
)[0];
if
(-e
$spec_path
) {
$key
=
sprintf
'%s-%s'
,
substr
(sha1_sum(
$key
), 0, 10),
path(
$spec_path
)->basename;
}
$key
=~ s![^\w-]!_!g;
$key
;
}
sub
_get {
my
(
$self
,
$data
,
$path
,
$pos
,
$cb
) =
@_
;
my
$tied
;
while
(
@$path
) {
my
$p
=
shift
@$path
;
unless
(
defined
$p
) {
my
$i
= 0;
return
Mojo::Collection->new(
map
{
$self
->_get(
$_
->[0], [
@$path
], _path(
$pos
,
$_
->[1]),
$cb
) }
ref
$data
eq
'ARRAY'
?
map
{ [
$_
,
$i
++] }
@$data
:
ref
$data
eq
'HASH'
?
map
{ [
$data
->{
$_
},
$_
] }
sort
keys
%$data
: [
$data
,
''
]);
}
$p
=~ s!~1!/!g;
$p
=~ s/~0/~/g;
$pos
= _path(
$pos
,
$p
)
if
$cb
;
if
(
ref
$data
eq
'HASH'
and
exists
$data
->{
$p
}) {
$data
=
$data
->{
$p
};
}
elsif
(
ref
$data
eq
'ARRAY'
and
$p
=~ /^\d+$/ and
@$data
>
$p
) {
$data
=
$data
->[
$p
];
}
else
{
return
undef
;
}
$data
=
$tied
->schema
if
ref
$data
eq
'HASH'
and
$tied
=
tied
%$data
;
}
return
$cb
->(
$data
,
$pos
)
if
$cb
;
return
$data
;
}
sub
_id_key {
$_
[0]->version < 7 ?
'id'
:
'$id'
}
sub
_load_schema {
my
(
$self
,
$url
) =
@_
;
if
(
$url
=~ m!^https?://!) {
warn
"[JSON::Validator] Loading schema from URL $url\n"
if
DEBUG;
return
$self
->_load_schema_from_url(Mojo::URL->new(
$url
)->fragment(
undef
)),
"$url"
;
}
if
(
$url
=~ m!^data://([^/]*)/(.*)!) {
my
(
$file
,
@modules
) = ($2, ($1));
@modules
= _stack()
unless
$modules
[0];
for
my
$module
(
@modules
) {
warn
"[JSON::Validator] Looking for $file in $module\n"
if
DEBUG;
my
$text
= Mojo::Loader::data_section(
$module
,
$file
);
return
$self
->_load_schema_from_text(\
$text
),
"$url"
if
$text
;
}
confess
"$file could not be found in __DATA__ section of @modules."
;
}
if
(
$url
=~ m!^\s*[\[\{]!) {
warn
"[JSON::Validator] Loading schema from string.\n"
if
DEBUG;
return
$self
->_load_schema_from_text(\
$url
),
''
;
}
my
$file
=
$url
;
$file
=~ s!
$file
= path(
split
'/'
,
$file
);
if
(-e
$file
) {
$file
=
$file
->realpath;
warn
"[JSON::Validator] Loading schema from file: $file\n"
if
DEBUG;
return
$self
->_load_schema_from_text(\
$file
->slurp),
CASE_TOLERANT ? path(
lc
$file
) :
$file
;
}
elsif
(
$url
=~ m!^/! and
$self
->ua->server->app) {
warn
"[JSON::Validator] Loading schema from URL $url\n"
if
DEBUG;
return
$self
->_load_schema_from_url(Mojo::URL->new(
$url
)->fragment(
undef
)),
"$url"
;
}
confess
"Unable to load schema '$url' ($file)"
;
}
sub
_load_schema_from_text {
my
(
$self
,
$text
) =
@_
;
my
$visit
;
return
Mojo::JSON::decode_json(
$$text
)
if
$$text
=~ /^\s*\{/s;
$visit
=
sub
{
my
$v
=
shift
;
$visit
->(
$_
)
for
grep
{
ref
$_
eq
'HASH'
}
values
%$v
;
return
$v
unless
$v
->{type}
and
$v
->{type} eq
'boolean'
and
exists
$v
->{
default
};
%$v
= (
%$v
,
default
=>
$v
->{
default
} ? true : false);
return
$v
;
};
die
"[JSON::Validator] YAML::XS 0.67 is missing or could not be loaded."
unless
$YAML_LOADER
;
no
warnings
'once'
;
local
$YAML::XS::Boolean
=
'JSON::PP'
;
return
$visit
->(
$YAML_LOADER
->(
$$text
));
}
sub
_load_schema_from_url {
my
(
$self
,
$url
) =
@_
;
my
$cache_path
=
$self
->cache_paths->[0];
my
$cache_file
= Mojo::Util::md5_sum(
"$url"
);
my
(
$err
,
$tx
);
for
(@{
$self
->cache_paths}) {
my
$path
= path
$_
,
$cache_file
;
warn
"[JSON::Validator] Looking for cached spec $path ($url)\n"
if
DEBUG;
next
unless
-r
$path
;
return
$self
->_load_schema_from_text(\
$path
->slurp);
}
$tx
=
$self
->ua->get(
$url
);
$err
=
$tx
->error &&
$tx
->error->{message};
confess
"GET $url == $err"
if
DEBUG and
$err
;
die
"[JSON::Validator] GET $url == $err"
if
$err
;
if
(
$cache_path
and
(
$cache_path
ne
$BUNDLED_CACHE_DIR
or
$ENV
{JSON_VALIDATOR_CACHE_ANYWAYS})
and -w
$cache_path
)
{
$cache_file
= path
$cache_path
,
$cache_file
;
warn
"[JSON::Validator] Caching $url to $cache_file\n"
unless
$ENV
{HARNESS_ACTIVE};
$cache_file
->spurt(
$tx
->res->body);
}
return
$self
->_load_schema_from_text(\
$tx
->res->body);
}
sub
_ref_to_schema {
my
(
$self
,
$schema
) =
@_
;
my
@guard
;
while
(
my
$tied
=
tied
%$schema
) {
push
@guard
,
$tied
->
ref
;
confess
"Seems like you have a circular reference: @guard"
if
@guard
> RECURSION_LIMIT;
$schema
=
$tied
->schema;
}
return
$schema
;
}
sub
_register_schema {
my
(
$self
,
$schema
,
$fqn
) =
@_
;
$fqn
=~ s!(.)
$self
->{schemas}{
$fqn
} =
$schema
;
}
sub
_report {
my
$table
= Mojo::Util::tablify(
$_
[0]->{report});
$table
=~ s!^(\W*)(N?OK|<<<)(.*)!{_report_colored()}!gme;
warn
"---\n$table"
;
}
sub
_report_colored {
my
(
$x
,
$y
,
$z
) = ($1, $2, $3);
my
$c
=
$y
eq
'OK'
?
'green'
:
$y
eq
'<<<'
?
'blue'
:
'magenta'
;
$c
=
"$c bold"
if
$z
=~ /\s\w+Of\s/;
Term::ANSIColor::colored([
$c
],
"$x$y$z"
);
}
sub
_report_errors {
my
(
$self
,
$path
,
$type
,
$errors
) =
@_
;
push
@{
$self
->{report}},
[
((
' '
) x
$self
->{grouped}) . (
@$errors
?
'NOK'
:
'OK'
),
$path
||
'/'
,
$type
,
join
"\n"
,
@$errors
];
}
sub
_report_schema {
my
(
$self
,
$path
,
$type
,
$schema
) =
@_
;
push
@{
$self
->{report}},
[((
' '
) x
$self
->{grouped}) . (
'<<<'
),
$path
||
'/'
,
$type
, D
$schema
];
}
sub
_resolve {
my
(
$self
,
$schema
) =
@_
;
my
$id_key
=
$self
->_id_key;
my
(
$id
,
$resolved
,
@refs
);
local
$self
->{level} =
$self
->{level} || 0;
delete
$_
[0]->{schemas}{
''
}
unless
$self
->{level};
if
(
ref
$schema
eq
'HASH'
) {
$id
=
$schema
->{
$id_key
} //
''
;
return
$resolved
if
$resolved
=
$self
->{schemas}{
$id
};
}
elsif
(
$resolved
=
$self
->{schemas}{
$schema
//
''
}) {
return
$resolved
;
}
else
{
(
$schema
,
$id
) =
$self
->_load_schema(
$schema
);
$id
=
$schema
->{
$id_key
}
if
$schema
->{
$id_key
};
}
unless
(
$self
->{level}) {
my
$rid
=
$schema
->{
$id_key
} //
$id
;
if
(
$rid
) {
confess
"Root schema cannot have a fragment in the 'id'. ($rid)"
if
$rid
=~ /\
confess
"Root schema cannot have a relative 'id'. ($rid)"
unless
$rid
=~ /^\w+:/
or -e
$rid
or
$rid
=~ m!^/!;
}
warn
sprintf
"[JSON::Validator] Using root_schema_url of '$rid'\n"
if
DEBUG;
$self
->{root_schema_url} =
$rid
;
}
$self
->{level}++;
$self
->_register_schema(
$schema
,
$id
);
my
@topics
= ([
$schema
, UNIVERSAL::isa(
$id
,
'Mojo::File'
) ?
$id
: Mojo::URL->new(
$id
)
]);
while
(
@topics
) {
my
(
$topic
,
$base
) = @{
shift
@topics
};
if
(UNIVERSAL::isa(
$topic
,
'ARRAY'
)) {
push
@topics
,
map
{ [
$_
,
$base
] }
@$topic
;
}
elsif
(UNIVERSAL::isa(
$topic
,
'HASH'
)) {
push
@refs
, [
$topic
,
$base
] and
next
if
$topic
->{
'$ref'
} and !
ref
$topic
->{
'$ref'
};
if
(
$topic
->{
$id_key
} and !
ref
$topic
->{
$id_key
}) {
my
$fqn
= Mojo::URL->new(
$topic
->{
$id_key
});
$fqn
=
$fqn
->to_abs(
$base
)
unless
$fqn
->is_abs;
$self
->_register_schema(
$topic
,
$fqn
->to_string);
}
push
@topics
,
map
{ [
$_
,
$base
] }
values
%$topic
;
}
}
$self
->_resolve_ref(
@$_
)
for
@refs
;
return
$schema
;
}
sub
_location_to_abs {
my
(
$location
,
$base
) =
@_
;
my
$location_as_url
= Mojo::URL->new(
$location
);
return
$location_as_url
if
$location_as_url
->is_abs;
if
(
$base
->isa(
'Mojo::File'
)) {
return
$base
if
!
length
$location
;
return
$base
->sibling(
split
'/'
,
$location
)->realpath;
}
return
$location_as_url
->to_abs(
$base
);
}
sub
_resolve_ref {
my
(
$self
,
$topic
,
$url
) =
@_
;
return
if
tied
%$topic
;
my
$other
=
$topic
;
my
(
$location
,
$fqn
,
$pointer
,
$ref
,
@guard
);
while
(1) {
$ref
=
$other
->{
'$ref'
};
push
@guard
,
$other
->{
'$ref'
};
confess
"Seems like you have a circular reference: @guard"
if
@guard
> RECURSION_LIMIT;
last
if
!
$ref
or
ref
$ref
;
$fqn
=
$ref
=~ m!^/! ?
"#$ref"
:
$ref
;
(
$location
,
$pointer
) =
split
/
$url
=
$location
= _location_to_abs(
$location
,
$url
);
$pointer
=
undef
if
length
$location
and !
length
$pointer
;
$pointer
= url_unescape
$pointer
if
defined
$pointer
;
$fqn
=
join
'#'
,
grep
defined
,
$location
,
$pointer
;
$other
=
$self
->_resolve(
$location
);
if
(
defined
$pointer
and
length
$pointer
and
$pointer
=~ m!^/!) {
$other
= Mojo::JSON::Pointer->new(
$other
)->get(
$pointer
)
or confess
qq[Possibly a typo in schema? Could not find "$pointer" in "$location" ($ref)]
;
}
}
tie
%$topic
,
'JSON::Validator::Ref'
,
$other
,
$topic
->{
'$ref'
},
$fqn
;
}
sub
_stack {
my
@classes
;
my
$i
= 2;
while
(
my
$pkg
=
caller
(
$i
++)) {
no
strict
'refs'
;
push
@classes
,
grep
{ !/(^JSON::Validator$|^Mojo::Base$|^Mojolicious$|\w+::_Dynamic)/ }
$pkg
, @{
"$pkg\::ISA"
};
}
return
@classes
;
}
sub
_validate {
my
(
$self
,
$data
,
$path
,
$schema
) =
@_
;
my
(
$seen_addr
,
$to_json
,
$type
);
return
if
blessed
$schema
and
$schema
->isa(
'JSON::PP::Boolean'
);
$schema
=
$self
->_ref_to_schema(
$schema
)
if
$schema
->{
'$ref'
};
$seen_addr
=
join
':'
, refaddr(
$schema
),
(
ref
$data
? refaddr
$data
: ++
$self
->{seen}{
scalar
});
if
(
$self
->{seen}{
$seen_addr
}) {
$self
->_report_schema(
$path
||
'/'
,
'seen'
,
$schema
)
if
REPORT;
return
@{
$self
->{seen}{
$seen_addr
}};
}
$self
->{seen}{
$seen_addr
} = \
my
@errors
;
$to_json
= (blessed
$data
and
$data
->can(
'TO_JSON'
)) ? \
$data
->TO_JSON :
undef
;
$data
=
$$to_json
if
$to_json
;
$type
=
$schema
->{type} || _guess_schema_type(
$schema
,
$data
);
if
(
ref
$type
eq
'ARRAY'
) {
push
@{
$self
->{temp_schema}}, [
map
{ +{
%$schema
,
type
=>
$_
} }
@$type
];
push
@errors
,
$self
->_validate_any_of(
$to_json
?
$$to_json
:
$_
[1],
$path
,
$self
->{temp_schema}[-1]);
}
elsif
(
$type
) {
my
$method
=
sprintf
'_validate_type_%s'
,
$type
;
$self
->_report_schema(
$path
||
'/'
,
$type
,
$schema
)
if
REPORT;
@errors
=
$self
->
$method
(
$to_json
?
$$to_json
:
$_
[1],
$path
,
$schema
);
$self
->_report_errors(
$path
,
$type
, \
@errors
)
if
REPORT;
return
@errors
if
@errors
;
}
if
(
$schema
->{enum}) {
push
@errors
,
$self
->_validate_type_enum(
$to_json
?
$$to_json
:
$_
[1],
$path
,
$schema
);
$self
->_report_errors(
$path
,
'enum'
, \
@errors
)
if
REPORT;
return
@errors
if
@errors
;
}
if
(
my
$rules
=
$schema
->{not}) {
push
@errors
,
$self
->_validate(
$to_json
?
$$to_json
:
$_
[1],
$path
,
$rules
);
$self
->_report_errors(
$path
,
'not'
, \
@errors
)
if
REPORT;
return
@errors
? () : (E
$path
,
'Should not match.'
);
}
if
(
my
$rules
=
$schema
->{allOf}) {
push
@errors
,
$self
->_validate_all_of(
$to_json
?
$$to_json
:
$_
[1],
$path
,
$rules
);
}
elsif
(
$rules
=
$schema
->{anyOf}) {
push
@errors
,
$self
->_validate_any_of(
$to_json
?
$$to_json
:
$_
[1],
$path
,
$rules
);
}
elsif
(
$rules
=
$schema
->{oneOf}) {
push
@errors
,
$self
->_validate_one_of(
$to_json
?
$$to_json
:
$_
[1],
$path
,
$rules
);
}
return
@errors
;
}
sub
_validate_all_of {
my
(
$self
,
$data
,
$path
,
$rules
) =
@_
;
my
$type
= _guess_data_type(
$data
,
$rules
);
my
(
@errors
,
@expected
);
$self
->_report_schema(
$path
,
'allOf'
,
$rules
)
if
REPORT;
local
$self
->{grouped} =
$self
->{grouped} + 1;
my
$i
= 0;
for
my
$rule
(
@$rules
) {
next
unless
my
@e
=
$self
->_validate(
$_
[1],
$path
,
$rule
);
my
$schema_type
= _guess_schema_type(
$rule
);
push
@expected
,
$schema_type
if
$schema_type
;
push
@errors
, [
$i
,
@e
]
if
!
$schema_type
or
$schema_type
eq
$type
;
}
continue
{
$i
++;
}
$self
->_report_errors(
$path
,
'allOf'
, \
@errors
)
if
REPORT;
return
E
$path
,
"/allOf Expected @{[join '/', _uniq(@expected)]} - got $type."
if
!
@errors
and
@expected
;
return
_add_path_to_error_messages(
allOf
=>
@errors
)
if
@errors
;
return
;
}
sub
_validate_any_of {
my
(
$self
,
$data
,
$path
,
$rules
) =
@_
;
my
$type
= _guess_data_type(
$data
,
$rules
);
my
(
@e
,
@errors
,
@expected
);
$self
->_report_schema(
$path
,
'anyOf'
,
$rules
)
if
REPORT;
local
$self
->{grouped} =
$self
->{grouped} + 1;
my
$i
= 0;
for
my
$rule
(
@$rules
) {
@e
=
$self
->_validate(
$_
[1],
$path
,
$rule
);
return
unless
@e
;
my
$schema_type
= _guess_schema_type(
$rule
);
push
@errors
, [
$i
,
@e
] and
next
if
!
$schema_type
or
$schema_type
eq
$type
;
push
@expected
,
$schema_type
;
}
continue
{
$i
++;
}
$self
->_report_errors(
$path
,
'anyOf'
, \
@errors
)
if
REPORT;
my
$expected
=
join
'/'
, _uniq(
@expected
);
return
E
$path
,
"/anyOf Expected $expected - got $type."
unless
@errors
;
return
_add_path_to_error_messages(
anyOf
=>
@errors
);
}
sub
_validate_one_of {
my
(
$self
,
$data
,
$path
,
$rules
) =
@_
;
my
$type
= _guess_data_type(
$data
,
$rules
);
my
(
@errors
,
@expected
);
$self
->_report_schema(
$path
,
'oneOf'
,
$rules
)
if
REPORT;
local
$self
->{grouped} =
$self
->{grouped} + 1;
my
$i
= 0;
for
my
$rule
(
@$rules
) {
my
@e
=
$self
->_validate(
$_
[1],
$path
,
$rule
) or
next
;
my
$schema_type
= _guess_schema_type(
$rule
);
push
@errors
, [
$i
,
@e
] and
next
if
!
$schema_type
or
$schema_type
eq
$type
;
push
@expected
,
$schema_type
;
}
continue
{
$i
++;
}
if
(REPORT) {
my
@e
=
@errors
+
@expected
+ 1 ==
@$rules
? ()
:
@errors
?
@errors
:
'All of the oneOf rules match.'
;
$self
->_report_errors(
$path
,
'oneOf'
, \
@e
);
}
return
if
@errors
+
@expected
+ 1 ==
@$rules
;
my
$expected
=
join
'/'
, _uniq(
@expected
);
return
E
$path
,
"All of the oneOf rules match."
unless
@errors
+
@expected
;
return
E
$path
,
"/oneOf Expected $expected - got $type."
unless
@errors
;
return
_add_path_to_error_messages(
oneOf
=>
@errors
);
}
sub
_validate_type_enum {
my
(
$self
,
$data
,
$path
,
$schema
) =
@_
;
my
$enum
=
$schema
->{enum};
my
$m
= S
$data
;
for
my
$i
(
@$enum
) {
return
if
$m
eq S
$i
;
}
local
$" =
', '
;
return
E
$path
,
sprintf
'Not in enum list: %s.'
,
join
', '
,
map
{ (!
defined
or
ref
) ? Mojo::JSON::encode_json(
$_
) :
$_
}
@$enum
;
}
sub
_validate_type_const {
my
(
$self
,
$data
,
$path
,
$schema
) =
@_
;
my
$const
=
$schema
->{const};
my
$m
= S
$data
;
return
if
$m
eq S
$const
;
return
E
$path
,
sprintf
'Does not match const: %s.'
,
Mojo::JSON::encode_json(
$const
);
}
sub
_validate_format {
my
(
$self
,
$value
,
$path
,
$schema
) =
@_
;
my
$code
=
$self
->formats->{
$schema
->{
format
}};
return
do
{
warn
"Format rule for '$schema->{format}' is missing"
;
return
}
unless
$code
;
return
unless
my
$err
=
$code
->(
$value
);
return
E
$path
,
$err
;
}
sub
_validate_type_any { }
sub
_validate_type_array {
my
(
$self
,
$data
,
$path
,
$schema
) =
@_
;
my
@errors
;
if
(
ref
$data
ne
'ARRAY'
) {
return
E
$path
, _expected(
array
=>
$data
);
}
if
(
defined
$schema
->{minItems} and
$schema
->{minItems} >
@$data
) {
push
@errors
, E
$path
,
sprintf
'Not enough items: %s/%s.'
,
int
@$data
,
$schema
->{minItems};
}
if
(
defined
$schema
->{maxItems} and
$schema
->{maxItems} <
@$data
) {
push
@errors
, E
$path
,
sprintf
'Too many items: %s/%s.'
,
int
@$data
,
$schema
->{maxItems};
}
if
(
$schema
->{uniqueItems}) {
my
%uniq
;
for
(
@$data
) {
next
if
!
$uniq
{S(
$_
)}++;
push
@errors
, E
$path
,
'Unique items required.'
;
last
;
}
}
if
(
$schema
->{contains}) {
my
@e
;
for
my
$i
(0 ..
@$data
- 1) {
my
@tmp
=
$self
->_validate(
$data
->[
$i
],
"$path/$i"
,
$schema
->{contains});
push
@e
, \
@tmp
if
@tmp
;
}
push
@errors
,
map
{
@$_
}
@e
if
@e
>=
@$data
;
}
elsif
(
ref
$schema
->{items} eq
'ARRAY'
) {
my
$additional_items
=
$schema
->{additionalItems} // {
type
=>
'any'
};
my
@rules
= @{
$schema
->{items}};
if
(
$additional_items
) {
push
@rules
,
$additional_items
while
@rules
<
@$data
;
}
if
(
@rules
==
@$data
) {
for
my
$i
(0 ..
@rules
- 1) {
push
@errors
,
$self
->_validate(
$data
->[
$i
],
"$path/$i"
,
$rules
[
$i
]);
}
}
elsif
(!
$additional_items
) {
push
@errors
, E
$path
,
sprintf
"Invalid number of items: %s/%s."
,
int
(
@$data
),
int
(
@rules
);
}
}
elsif
(UNIVERSAL::isa(
$schema
->{items},
'HASH'
)) {
for
my
$i
(0 ..
@$data
- 1) {
push
@errors
,
$self
->_validate(
$data
->[
$i
],
"$path/$i"
,
$schema
->{items});
}
}
return
@errors
;
}
sub
_validate_type_boolean {
my
(
$self
,
$value
,
$path
,
$schema
) =
@_
;
if
(blessed
$value
and (
$value
->isa(
'JSON::PP::Boolean'
) or
"$value"
eq
"1"
or !
$value
))
{
return
;
}
if
(
defined
$value
and
$self
->{coerce}{booleans}
and (B::svref_2object(\
$value
)->FLAGS & (B::SVp_IOK | B::SVp_NOK)
or
$value
=~ /^(true|false)$/)
)
{
$_
[1] =
$value
? true : false;
return
;
}
return
E
$path
, _expected(
boolean
=>
$value
);
}
sub
_validate_type_integer {
my
(
$self
,
$value
,
$path
,
$schema
) =
@_
;
my
@errors
=
$self
->_validate_type_number(
$_
[1],
$path
,
$schema
,
'integer'
);
return
@errors
if
@errors
;
return
if
$value
=~ /^-?\d+$/;
return
E
$path
,
"Expected integer - got number."
;
}
sub
_validate_type_null {
my
(
$self
,
$value
,
$path
,
$schema
) =
@_
;
return
E
$path
,
'Not null.'
if
defined
$value
;
return
;
}
sub
_validate_type_number {
my
(
$self
,
$value
,
$path
,
$schema
,
$expected
) =
@_
;
my
@errors
;
$expected
||=
'number'
;
if
(!
defined
$value
or
ref
$value
) {
return
E
$path
, _expected(
$expected
=>
$value
);
}
unless
(_is_number(
$value
)) {
return
E
$path
,
"Expected $expected - got string."
if
!
$self
->{coerce}{numbers}
or
$value
!~ /^-?(?:0|[1-9]\d*)(?:\.\d+)?(?:[eE][+-]?\d+)?$/;
$_
[1] = 0 +
$value
;
}
if
(
$schema
->{
format
}) {
push
@errors
,
$self
->_validate_format(
$value
,
$path
,
$schema
);
}
if
(
my
$e
= _cmp(
$schema
->{minimum},
$value
,
$schema
->{exclusiveMinimum},
'<'
))
{
push
@errors
, E
$path
,
"$value $e minimum($schema->{minimum})"
;
}
if
(
my
$e
= _cmp(
$value
,
$schema
->{maximum},
$schema
->{exclusiveMaximum},
'>'
))
{
push
@errors
, E
$path
,
"$value $e maximum($schema->{maximum})"
;
}
if
(
my
$d
=
$schema
->{multipleOf}) {
if
((
$value
/
$d
) =~ /\.[^0]+$/) {
push
@errors
, E
$path
,
"Not multiple of $d."
;
}
}
return
@errors
;
}
sub
_validate_type_object {
my
(
$self
,
$data
,
$path
,
$schema
) =
@_
;
my
%required
=
map
{ (
$_
=> 1) } @{
$schema
->{required} || []};
my
(
$additional
,
@errors
,
%rules
);
if
(
ref
$data
ne
'HASH'
) {
return
E
$path
, _expected(
object
=>
$data
);
}
my
@dkeys
=
sort
keys
%$data
;
if
(
defined
$schema
->{maxProperties} and
$schema
->{maxProperties} <
@dkeys
) {
push
@errors
, E
$path
,
sprintf
'Too many properties: %s/%s.'
,
int
@dkeys
,
$schema
->{maxProperties};
}
if
(
defined
$schema
->{minProperties} and
$schema
->{minProperties} >
@dkeys
) {
push
@errors
, E
$path
,
sprintf
'Not enough properties: %s/%s.'
,
int
@dkeys
,
$schema
->{minProperties};
}
if
(
my
$n_schema
=
$schema
->{propertyNames}) {
for
my
$name
(
keys
%$data
) {
next
unless
my
@e
=
$self
->_validate(
$name
,
$path
,
$n_schema
);
push
@errors
,
_add_path_to_error_messages(
propertyName
=> [
map
{ (
$name
,
$_
) }
@e
]);
}
}
if
(
$schema
->{
if
}) {
push
@errors
,
$self
->_validate(
$data
,
$path
,
$schema
->{
if
})
?
$self
->_validate(
$data
,
$path
,
$schema
->{
else
} // {})
:
$self
->_validate(
$data
,
$path
,
$schema
->{then} // {});
}
my
$coerce_defaults
=
$self
->{coerce}{defaults};
while
(
my
(
$k
,
$r
) =
each
%{
$schema
->{properties}}) {
push
@{
$rules
{
$k
}},
$r
;
next
unless
$coerce_defaults
;
$data
->{
$k
} =
$r
->{
default
}
if
exists
$r
->{
default
} and !
exists
$data
->{
$k
};
}
while
(
my
(
$p
,
$r
) =
each
%{
$schema
->{patternProperties} || {}}) {
push
@{
$rules
{
$_
}},
$r
for
sort
grep
{
$_
=~ /
$p
/ }
@dkeys
;
}
$additional
=
exists
$schema
->{additionalProperties}
?
$schema
->{additionalProperties}
: {};
if
(
$additional
) {
$additional
= {}
unless
UNIVERSAL::isa(
$additional
,
'HASH'
);
$rules
{
$_
} ||= [
$additional
]
for
@dkeys
;
}
elsif
(
my
@k
=
grep
{ !
$rules
{
$_
} }
@dkeys
) {
local
$" =
', '
;
return
E
$path
,
"Properties not allowed: @k."
;
}
for
my
$k
(
sort
keys
%required
) {
next
if
exists
$data
->{
$k
};
push
@errors
, E _path(
$path
,
$k
),
'Missing property.'
;
delete
$rules
{
$k
};
}
for
my
$k
(
sort
keys
%rules
) {
for
my
$r
(@{
$rules
{
$k
}}) {
next
unless
exists
$data
->{
$k
};
my
@e
=
$self
->_validate(
$data
->{
$k
}, _path(
$path
,
$k
),
$r
);
push
@errors
,
@e
;
next
if
@e
or !UNIVERSAL::isa(
$r
,
'HASH'
);
push
@errors
,
$self
->_validate_type_enum(
$data
->{
$k
}, _path(
$path
,
$k
),
$r
)
if
$r
->{enum};
push
@errors
,
$self
->_validate_type_const(
$data
->{
$k
}, _path(
$path
,
$k
),
$r
)
if
$r
->{const};
}
}
return
@errors
;
}
sub
_validate_type_string {
my
(
$self
,
$value
,
$path
,
$schema
) =
@_
;
my
@errors
;
if
(!
defined
$value
or
ref
$value
) {
return
E
$path
, _expected(
string
=>
$value
);
}
if
( B::svref_2object(\
$value
)->FLAGS & (B::SVp_IOK | B::SVp_NOK)
and 0 +
$value
eq
$value
and
$value
* 0 == 0)
{
return
E
$path
,
"Expected string - got number."
unless
$self
->{coerce}{strings};
$_
[1] =
"$value"
;
}
if
(
$schema
->{
format
}) {
push
@errors
,
$self
->_validate_format(
$value
,
$path
,
$schema
);
}
if
(
defined
$schema
->{maxLength}) {
if
(
length
(
$value
) >
$schema
->{maxLength}) {
push
@errors
, E
$path
,
sprintf
"String is too long: %s/%s."
,
length
(
$value
),
$schema
->{maxLength};
}
}
if
(
defined
$schema
->{minLength}) {
if
(
length
(
$value
) <
$schema
->{minLength}) {
push
@errors
, E
$path
,
sprintf
"String is too short: %s/%s."
,
length
(
$value
),
$schema
->{minLength};
}
}
if
(
defined
$schema
->{pattern}) {
my
$p
=
$schema
->{pattern};
unless
(
$value
=~ /
$p
/) {
push
@errors
, E
$path
,
"String does not match '$p'"
;
}
}
return
@errors
;
}
sub
_add_path_to_error_messages {
my
(
$type
,
@errors_with_index
) =
@_
;
my
@errors
;
for
my
$e
(
@errors_with_index
) {
my
$index
=
shift
@$e
;
push
@errors
,
map
{
my
$msg
=
sprintf
'/%s/%s %s'
,
$type
,
$index
,
$_
->{message};
$msg
=~ s!(\d+)\s/!$1/!g;
E
$_
->path,
$msg
;
}
@$e
;
}
return
@errors
;
}
sub
_cmp {
return
undef
if
!
defined
$_
[0] or !
defined
$_
[1];
return
"$_[3]="
if
$_
[2] and
$_
[0] >=
$_
[1];
return
$_
[3]
if
$_
[0] >
$_
[1];
return
""
;
}
sub
_expected {
my
$type
= _guess_data_type(
$_
[1], []);
return
"Expected $_[0] - got different $type."
if
$_
[0] =~ /\b
$type
\b/;
return
"Expected $_[0] - got $type."
;
}
sub
_guess_data_type {
my
$ref
=
ref
$_
[0];
my
$blessed
= blessed
$_
[0];
return
'object'
if
$ref
eq
'HASH'
;
return
lc
$ref
if
$ref
and !
$blessed
;
return
'null'
if
!
defined
$_
[0];
return
'boolean'
if
$blessed
and (
"$_[0]"
eq
"1"
or !
"$_[0]"
);
if
(_is_number(
$_
[0])) {
return
'integer'
if
grep
{ (
$_
->{type} //
''
) eq
'integer'
} @{
$_
[1] || []};
return
'number'
;
}
return
$blessed
||
'string'
;
}
sub
_guess_schema_type {
return
$_
[0]->{type}
if
$_
[0]->{type};
return
_guessed_right(
object
=>
$_
[1])
if
$_
[0]->{additionalProperties};
return
_guessed_right(
object
=>
$_
[1])
if
$_
[0]->{patternProperties};
return
_guessed_right(
object
=>
$_
[1])
if
$_
[0]->{properties};
return
_guessed_right(
object
=>
$_
[1])
if
$_
[0]->{propertyNames};
return
_guessed_right(
object
=>
$_
[1])
if
$_
[0]->{required};
return
_guessed_right(
object
=>
$_
[1])
if
$_
[0]->{
if
};
return
_guessed_right(
object
=>
$_
[1])
if
defined
$_
[0]->{maxProperties}
or
defined
$_
[0]->{minProperties};
return
_guessed_right(
array
=>
$_
[1])
if
$_
[0]->{additionalItems};
return
_guessed_right(
array
=>
$_
[1])
if
$_
[0]->{items};
return
_guessed_right(
array
=>
$_
[1])
if
$_
[0]->{uniqueItems};
return
_guessed_right(
array
=>
$_
[1])
if
defined
$_
[0]->{maxItems}
or
defined
$_
[0]->{minItems};
return
_guessed_right(
string
=>
$_
[1])
if
$_
[0]->{pattern};
return
_guessed_right(
string
=>
$_
[1])
if
defined
$_
[0]->{maxLength}
or
defined
$_
[0]->{minLength};
return
_guessed_right(
number
=>
$_
[1])
if
$_
[0]->{multipleOf};
return
_guessed_right(
number
=>
$_
[1])
if
defined
$_
[0]->{maximum}
or
defined
$_
[0]->{minimum};
return
'const'
if
$_
[0]->{const};
return
undef
;
}
sub
_guessed_right {
return
$_
[0]
if
!
defined
$_
[1];
return
$_
[0]
if
$_
[0] eq _guess_data_type(
$_
[1], [{
type
=>
$_
[0]}]);
return
undef
;
}
sub
_is_number {
B::svref_2object(\
$_
[0])->FLAGS & (B::SVp_IOK | B::SVp_NOK)
&& 0 +
$_
[0] eq
$_
[0]
&&
$_
[0] * 0 == 0;
}
sub
_path {
local
$_
=
$_
[1];
s!~!~0!g;
s!/!~1!g;
"$_[0]/$_"
;
}
sub
_uniq {
my
%uniq
;
grep
{ !
$uniq
{
$_
}++ }
@_
;
}
1;