Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

executable file 1446 lines (1337 sloc) 38.968 kB
#!/usr/bin/perl
use 5.010;
use strict;
use warnings FATAL => 'all';
use FindBin '$Bin';
use vars qw($VERSION);
use Data::Clone;
use File::Slurp;
use YAML::Syck qw(Dump);
# VERSION
unless (defined $VERSION) {
my $dist = read_file "$Bin/../dist.ini";
$dist =~ /^\s*version\s*=\s*(.+)/m and $VERSION = $1;
}
our ($Type, $Clause);
# describe literal
sub _l {
my $d = shift;
return "undefined value" if !defined($d);
return $d unless ref($d);
my $res = Dump($_);
$res =~ s/\s+\z//s;
$res;
}
sub gen_type_check_tests {
my %args = @_;
my @res;
for (@{ $args{accept} }) {
push @res, {
name => "type check: must accept "._l($_),
input => $_,
schema => $Type,
valid => 1,
};
}
for (@{ $args{reject} }) {
push @res, {
name => "type check: must reject "._l($_),
input => $_,
schema => $Type,
valid => 0,
};
}
@res;
}
# req, forbidden, default
#
# args:
#
# - value -> used to test 'forbidden'. must be a valid value.
#
# - ok_defaults -> used to test 'default' and that default values are still
# validated, min 1 value
#
# - nok_defaults -> see above
#
# - ok_clauses -> used to test 'clause' and 'clset'. minimal 2 values, clauses
# must be different
#
# - nok_clauses -> see above.
#
sub gen_BaseType_tests {
my %args = @_;
my @res;
push @res, {
name => "must accept undefined value",
schema => $Type,
input => undef,
valid => 1,
};
# req
push @res, {
name => "req=0 must accept undefined value",
schema => [$Type, req=>0],
input => undef,
valid => 1,
};
push @res, {
name => "req=1 must reject undefined value",
schema => [$Type, req=>1],
input => undef,
valid => 0,
};
# forbidden
push @res, {
name => "forbidden=0 must accept defined value",
schema => [$Type, forbidden=>0],
input => $args{value},
valid => 1,
};
push @res, {
name => "forbidden=1 must reject defined value",
schema => [$Type, forbidden=>1],
input => $args{value},
valid => 0,
};
# default
for (@{ $args{ok_defaults} }) {
push @res, {
name => "default: must accept valid default "._l($_),
input => undef,
schema => ["$Type*", default=>$_],
valid => 1,
};
}
for (@{ $args{nok_defaults} }) {
push @res, {
name => "default: must reject invalid default "._l($_),
input => undef,
schema => ["$Type*", default=>$_],
valid => 0,
};
}
# clause
push @res, {
name => "clause (dies, unknown clause)",
input => $args{value},
schema => ["$Type*", clause=>[foo => 1]],
dies => 1,
};
push @res, {
name => "clause (ok)",
input => $args{value},
schema => ["$Type*", clause=>$args{ok_clauses}[0]],
valid => 1,
} if $args{ok_clauses};
# to test that the existence of clause does not override clauses outside it
push @res, {
name => "clause (ok) + clause nok = nok",
input => $args{value},
schema => [
"$Type*",
clause=>$args{ok_clauses}[0],
$args{nok_clauses}[1][0] => $args{nok_clauses}[1][1],
],
valid => 0,
} if $args{ok_clauses};
push @res, {
name => "clause (nok)",
input => $args{value},
schema => ["$Type*", clause=>$args{nok_clauses}[0]],
valid => 0,
errors => 1,
} if $args{ok_clauses};
# XXX clause 'clause' + .op and/or/none
push @res, {
name => "clset (dies, unknown clause)",
input => $args{value},
schema => ["$Type*", clset=>{foo=>1}],
dies => 1,
};
push @res, {
name => "clset (dies, unknown attr)",
input => $args{value},
schema => ["$Type*", clset=>{min_len=>1, "min_len.foo"=>1}],
dies => 1,
};
push @res, {
name => "clset (empty = ok)",
input => $args{value},
schema => ["$Type*", clset=>{}],
valid => 1,
};
push @res, {
name => "clset (ignored clause/attr = ok)",
input => $args{value},
schema => ["$Type*", clset=>{_foo=>1, "foo._bar"=>2}],
valid => 1,
};
push @res, {
name => "clset (ok + ok = ok)",
input => $args{value},
schema => ["$Type*", clset=>{
$args{ok_clauses}[0][0] => $args{ok_clauses}[0][1],
$args{ok_clauses}[1][0] => $args{ok_clauses}[1][1],
}],
valid => 1,
} if $args{ok_clauses};
# to test that the existence of clset does not override clauses outside it
push @res, {
name => "clset (ok) + clause nok = nok",
input => $args{value},
schema => [
"$Type*",
clset=>{
$args{ok_clauses}[0][0] => $args{ok_clauses}[0][1],
},
$args{nok_clauses}[1][0] => $args{nok_clauses}[1][1],
],
valid => 0,
} if $args{ok_clauses};
push @res, {
name => "clset (ok + nok = nok)",
input => $args{value},
schema => ["$Type*", clset=>{
$args{ok_clauses}[0][0] => $args{ok_clauses}[0][1],
$args{nok_clauses}[1][0] => $args{nok_clauses}[1][1],
}],
valid => 0,
} if $args{ok_clauses};
push @res, {
name => "clset (nok + ok = nok)",
input => $args{value},
schema => ["$Type*", clset=>{
$args{nok_clauses}[0][0] => $args{nok_clauses}[0][1],
$args{ok_clauses}[1][0] => $args{ok_clauses}[1][1],
}],
valid => 0,
} if $args{ok_clauses};
push @res, {
name => "clset (nok + nok = nok)",
input => $args{value},
schema => ["$Type*", clset=>{
$args{nok_clauses}[0][0] => $args{nok_clauses}[0][1],
$args{nok_clauses}[1][0] => $args{nok_clauses}[1][1],
}],
valid => 0,
} if $args{ok_clauses};
# XXX clause 'clset' + .op and/or/none
@res;
}
sub gen_op_attr_tests {
my %args = @_;
my @res;
die "BUG: Need at least 2 values for ok_values"
unless @{$args{ok_values}}>1;
die "BUG: Need at least 2 values for nok_values"
unless @{$args{nok_values}}>1;
push @res, {
name => "!$Clause (nok)",
input => $args{input},
schema => [$Type, "!$Clause" => $args{ok_values}[0]],
valid => 0,
};
push @res, {
name => "!$Clause (ok)",
input => $args{input},
schema => [$Type, "!$Clause" => $args{nok_values}[0]],
valid => 1,
};
push @res, {
name => "$Clause.op=not (nok)",
input => $args{input},
schema => [$Type, $Clause=>$args{ok_values}[0], "$Clause.op"=>"not"],
valid => 0,
};
push @res, {
name => "$Clause.op=not (ok)",
input => $args{input},
schema => [$Type, $Clause=>$args{nok_values}[0], "$Clause.op"=>"not"],
valid => 1,
};
push @res, {
name => "$Clause& (no items)",
input => $args{input},
schema => [$Type, "$Clause&" => []],
valid => 1,
};
push @res, {
name => "$Clause& (ok)",
input => $args{input},
schema => [$Type,
"$Clause&" => $args{ok_values}],
valid => 1,
};
push @res, {
name => "$Clause& (nok + ok)",
input => $args{input},
schema => [$Type,
"$Clause&" => [$args{nok_values}[0], $args{ok_values}[0]]],
valid => 0,
errors => 1,
};
push @res, {
name => "$Clause& (ok + nok)",
input => $args{input},
schema => [$Type,
"$Clause&" => [$args{ok_values}[0], $args{nok_values}[0]]],
valid => 0,
errors => 1,
};
push @res, {
name => "$Clause& (nok + nok)",
input => $args{input},
schema => [$Type,
"$Clause&" => [$args{nok_values}[0], $args{nok_values}[1]]],
valid => 0,
errors => 1,
};
push @res, {
name => "$Clause.op=and (no items)",
input => $args{input},
schema => [$Type, $Clause=>[], "$Clause.op"=>"and"],
valid => 1,
};
push @res, {
name => "$Clause.op=and (ok)",
input => $args{input},
schema => [$Type, $Clause=>$args{ok_values}, "$Clause.op"=>"and"],
valid => 1,
};
push @res, {
name => "$Clause.op=and (nok + ok)",
input => $args{input},
schema => [$Type,
$Clause=>[$args{nok_values}[0], $args{ok_values}[0]],
"$Clause.op"=>"and",
],
valid => 0,
errors => 1,
};
push @res, {
name => "$Clause.op=and (ok + nok)",
input => $args{input},
schema => [$Type,
$Clause=>[$args{ok_values}[0], $args{nok_values}[0]],
"$Clause.op"=>"and",
],
valid => 0,
errors => 1,
};
push @res, {
name => "$Clause.op=and (nok + nok)",
input => $args{input},
schema => [$Type,
$Clause=>[$args{nok_values}[0], $args{nok_values}[1]],
"$Clause.op"=>"and",
],
valid => 0,
errors => 1,
};
push @res, {
name => "$Clause| (no items)",
input => $args{input},
schema => [$Type, "$Clause|" => []],
valid => 1,
};
push @res, {
name => "$Clause| (ok)",
input => $args{input},
schema => [$Type, "$Clause|" => $args{ok_values}],
valid => 1,
};
push @res, {
name => "$Clause| (nok + ok)",
input => $args{input},
schema => [$Type,
"$Clause|" => [$args{nok_values}[0], $args{ok_values}[0]]],
valid => 1,
};
push @res, {
name => "$Clause| (ok + nok)",
input => $args{input},
schema => [$Type,
"$Clause|" => [$args{ok_values}[0], $args{nok_values}[0]]],
valid => 1,
};
push @res, {
name => "$Clause| (nok + nok)",
input => $args{input},
schema => [$Type,
"$Clause|" => [$args{nok_values}[0], $args{nok_values}[1]]],
valid => 0,
errors => 1,
};
push @res, {
name => "$Clause.op=or (no items)",
input => $args{input},
schema => [$Type, $Clause => [], "$Clause.op"=>"or"],
valid => 1,
};
push @res, {
name => "$Clause.op=or (ok)",
input => $args{input},
schema => [$Type, $Clause=>$args{ok_values}, "$Clause.op"=>"or"],
valid => 1,
};
push @res, {
name => "$Clause.op=or (nok + ok)",
input => $args{input},
schema => [$Type,
$Clause=>[$args{nok_values}[0], $args{ok_values}[0]],
"$Clause.op"=>"or",
],
valid => 1,
};
push @res, {
name => "$Clause.op=or (ok + nok)",
input => $args{input},
schema => [$Type,
$Clause=>[$args{ok_values}[0], $args{nok_values}[0]],
"$Clause.op"=>"or",
],
valid => 1,
};
push @res, {
name => "$Clause.op=or (nok + nok)",
input => $args{input},
schema => [$Type,
$Clause=>[$args{nok_values}[0], $args{nok_values}[1]],
"$Clause.op"=>"or",
],
valid => 0,
errors => 1,
};
push @res, {
name => "$Clause.op=none (empty items)",
input => $args{input},
schema => [$Type, $Clause=>[], "$Clause.op"=>"none"],
valid => 1,
};
push @res, {
name => "$Clause.op=none (nok + nok)",
input => $args{input},
schema => [$Type,
$Clause=>[$args{nok_values}[0], $args{nok_values}[1]],
"$Clause.op"=>"none"],
valid => 1,
};
push @res, {
name => "$Clause.op=none (nok + ok)",
input => $args{input},
schema => [$Type,
$Clause=>[$args{nok_values}[0], $args{ok_values}[0]],
"$Clause.op"=>"none"],
valid => 0,
errors => 1,
};
push @res, {
name => "$Clause.op=none (ok + nok)",
input => $args{input},
schema => [$Type,
$Clause=>[$args{ok_values}[0], $args{nok_values}[0]],
"$Clause.op"=>"none"],
valid => 0,
errors => 1,
};
push @res, {
name => "$Clause.op=none (ok + ok)",
input => $args{input},
schema => [$Type, $Clause=>$args{ok_values}, "$Clause.op"=>"none"],
valid => 0,
errors => 1,
};
@res;
}
sub gen_err_level_tests {
my %args = @_;
(
{
name => ".err_level=error (clause=$args{clause}, ok)",
input => $args{ok_value},
schema => [$Type, $args{clause} => $args{cval}],
valid => 1,
},
{
name => ".err_level=error (clause=$args{clause}, nok)",
input => $args{nok_value},
schema => [$Type, $args{clause} => $args{cval}],
valid => 0,
},
{
name => ".err_level=warn (clause=$args{clause}, ok)",
input => $args{ok_value},
schema => [$Type, $args{clause} => $args{cval},
"$args{clause}.err_level"=>"warn"],
valid => 1,
},
{
name => ".err_level=warn (clause=$args{clause}, nok)",
input => $args{nok_value},
schema => ["$Type*", $args{clause} => $args{cval},
"$args{clause}.err_level"=>"warn"],
valid => 1,
warnings => 1,
},
);
# XXX .err_level=fatal (needs two clauses)
}
sub gen_Comparable_tests {
my %args = @_;
my @res;
my $v = $args{values}[0];
my $v2 = $args{values}[1];
# is
push @res, {
name => "is: must accept same value",
schema => [$Type, is=>$v],
input => $v,
valid => 1,
};
push @res, {
name => "is: must reject different value",
schema => [$Type, is=>$v2],
input => $v,
valid => 0,
};
local $Clause = "is";
push @res, gen_op_attr_tests(
input => $v,
ok_values => [$v, $v],
nok_values => [$v2, $v2],
);
# in
push @res, {
name => "in: must accept valid choices",
schema => [$Type, in=>$args{values}],
input => $v,
valid => 1,
};
push @res, {
name => "in: must reject empty choices",
schema => [$Type, in=>[]],
input => $v,
valid => 0,
};
local $Clause = "in";
push @res, gen_op_attr_tests(
input => $v,
ok_values => [$args{values}, clone($args{values})],
nok_values => [[], []],
);
@res;
}
sub gen_Sortable_tests {
my %args = @_;
my @res;
die "BUG: Please supply 3 values" unless @{ $args{values} } == 3;
# $v2 must be > $v1, and $v3 must be >= $v2
my ($v1, $v2, $v3) = @{ $args{values} };
push @res, (
{
name => "min: "._l($v2)." "._l($v1),
input => $v2,
schema => [$Type, min => $v1],
valid => 1,
},
{
name => "min: "._l($v2)." "._l($v2),
input => $v2,
schema => [$Type, min => $v2],
valid => 1,
},
{
name => "min: "._l($v1)." "._l($v2).' -> fail',
input => $v1,
schema => [$Type, min => $v2],
valid => 0,
},
{
name => "xmin: "._l($v2)." "._l($v1),
input => $v2,
schema => [$Type, xmin => $v1],
valid => 1,
},
{
name => "xmin: "._l($v2)." "._l($v2).' -> fail',
input => $v2,
schema => [$Type, xmin => $v2],
valid => 0,
},
{
name => "xmin: "._l($v1)." "._l($v2).' -> fail',
input => $v1,
schema => [$Type, xmin => $v2],
valid => 0,
},
{
name => "max: "._l($v2)." "._l($v1).' -> fail',
input => $v2,
schema => [$Type, max => $v1],
valid => 0,
},
{
name => "max: "._l($v2)." "._l($v2),
input => $v2,
schema => [$Type, max => $v2],
valid => 1,
},
{
name => "max: "._l($v1)." "._l($v2),
input => $v1,
schema => [$Type, max => $v2],
valid => 1,
},
{
name => "xmax: "._l($v2)." "._l($v1).' -> fail',
input => $v2,
schema => [$Type, xmax => $v1],
valid => 0,
},
{
name => "xmax: "._l($v2)." "._l($v2).' -> fail',
input => $v2,
schema => [$Type, xmax => $v2],
valid => 0,
},
{
name => "xmax: "._l($v1)." "._l($v2),
input => $v1,
schema => [$Type, xmax => $v2],
valid => 1,
},
{
name => "between: "._l($v2)." "._l($v1)." & "._l($v3),
input => $v2,
schema => [$Type, between => [$v1, $v3]],
valid => 1,
},
{
name => "between: "._l($v2)." "._l($v1)." & "._l($v2),
input => $v2,
schema => [$Type, between => [$v1, $v2]],
valid => 1,
},
{
name => "between: "._l($v2)." "._l($v2)." & "._l($v2),
input => $v2,
schema => [$Type, between => [$v2, clone($v2)]],
valid => 1,
},
{
name => "between: "._l($v1)." "._l($v2)." & "._l($v3).' -> fail',
input => $v1,
schema => [$Type, between => [$v2, $v3]],
valid => 0,
},
{
name => "xbetween: "._l($v2)." "._l($v1)." & "._l($v3),
input => $v2,
schema => [$Type, xbetween => [$v1, $v3]],
valid => $v3 eq $v2 ? 0:1,
},
{
name => "xbetween: "._l($v2)." "._l($v1)." & "._l($v2).' -> fail',
input => $v2,
schema => [$Type, xbetween => [$v1, $v2]],
valid => 0,
},
{
name => "xbetween: "._l($v2)." "._l($v2)." & "._l($v2).' -> fail',
input => $v2,
schema => [$Type, xbetween => [$v2, clone($v2)]],
valid => 0,
},
{
name => "xbetween: "._l($v1)." "._l($v2)." & "._l($v3).' -> fail',
input => $v1,
schema => [$Type, xbetween => [$v2, $v3]],
valid => 0,
},
);
# disabled temporarily because failing for bool, even though i've adjust
# stuffs
#local $Clause = "between";
#push @res, gen_op_attr_tests(
# input => $v1,
# # i know, lame, it's because bool only has two possible values
# ok_values => [[$v1, clone($v1)], [$v1, clone($v1)]],
# nok_values => [[$v2, clone($v2)], [$v2, clone($v2)]],
#);
# XXX op attr for xbetween
@res;
}
sub gen_HasElems_tests {
my %args = @_;
my @res;
die "BUG: Please supply two values" unless @{$args{values}} == 2;
my $v1 = $args{values}[0][0];
my $l1 = $args{values}[0][1];
my $v2 = $args{values}[1][0];
my $l2 = $args{values}[1][1];
die "BUG: First value's length must be less than second value's"
unless $l1 < $l2;
push @res, (
{
name => "len (ok)",
input => $v1,
schema => [$Type, len => $l1],
valid => 1,
},
{
name => "len (nok)",
input => $v1,
schema => [$Type, len => $l2],
valid => 0,
},
{
name => "min_len (ok)",
input => $v1,
schema => [$Type, min_len => $l1],
valid => 1,
},
{
name => "min_len (nok)",
input => $v1,
schema => [$Type, min_len => $l2],
valid => 0,
},
{
name => "max_len (ok)",
input => $v1,
schema => [$Type, min_len => $l1],
valid => 1,
},
{
name => "max_len (nok)",
input => $v2,
schema => [$Type, max_len => $l1],
valid => 0,
},
{
name => "len_between (ok)",
input => $v1,
schema => [$Type, len_between => [$l1, $l2]],
valid => 1,
},
{
name => "len_between (nok)",
input => $v2,
schema => [$Type, len_between => [$l1, $l1]],
valid => 0,
},
# XXX has
{
name => "each_index (ok)",
input => $v2,
schema => [$Type, each_index => $args{ok_each_index}],
valid => 1,
},
{
name => "each_index (nok)",
input => $v2,
schema => [$Type, each_index => $args{nok_each_index}],
valid => 0,
},
{
name => "each_elem (ok)",
input => $v2,
schema => [$Type, each_elem => $args{ok_each_elem}],
valid => 1,
},
{
name => "each_elem (nok)",
input => $v2,
schema => [$Type, each_elem => $args{nok_each_elem}],
valid => 0,
},
# XXX check_each_index
# XXX check_each_elem
# XXX uniq
# XXX exists
);
if ($args{elems_test}) {
for ($args{elems_test}) {
push @res, (
{
name => 'elems (ok)',
input => $_->{value},
schema => [$Type, elems => $_->{ok}],
valid => 1,
},
{
name => 'elems (nok)',
input => $_->{value},
schema => [$Type, elems => $_->{nok}],
valid => 0,
},
);
}
}
# XXX multi vals for all clauses
@res;
}
sub gen_int_tests {
my %args = @_;
my @res;
local $Type = "int";
(
gen_type_check_tests(
accept => [-1, 0, 1],
reject => [1.1, "a", [], {}], # XXX -Inf, NaN, Inf
),
gen_BaseType_tests(
value => 2,
ok_defaults => [1],
nok_defaults => [[]],
ok_clauses => [[min=>1], [max=>2]],
nok_clauses => [[min=>3], [xmax=>2]],
),
gen_err_level_tests(
clause => 'div_by',
cval => 3,
ok_value => 9,
nok_value => 8,
),
gen_Comparable_tests(
values => [1, 2],
),
gen_Sortable_tests(
values => [-3, 2, 4],
),
{
name => 'mod: (nok)',
input => 10,
schema => [int => mod => [3, 2]],
valid => 0,
},
{
name => 'mod: (ok)',
input => 11,
schema => [int => mod => [3, 2]],
valid => 1,
},
{
name => 'div_by: (nok)',
input => 7,
schema => [int => div_by => 3],
valid => 0,
},
{
name => 'div_by: (ok)',
input => 6,
schema => [int => div_by => 3],
valid => 1,
},
);
# XXX op attr for mod
# XXX op attr for div_by
# XXX div_by 0
}
sub gen_float_tests {
my %args = @_;
my @res;
local $Type = "float";
(
gen_type_check_tests(
accept => [-1.1, -1, 0, 1, 1.1], # XXX -Inf, NaN, Inf
reject => ["a", [], {}],
),
gen_BaseType_tests(
value => 1.1,
ok_defaults => [1.1],
nok_defaults => [[]],
ok_clauses => [[min=>1], [max=>1.1]],
nok_clauses => [[min=>2], [max=>1]],
),
gen_err_level_tests(
clause => 'min',
cval => 0,
ok_value => 0.1,
nok_value => -0.1,
),
gen_Comparable_tests(
values => [1.1, 1.2],
),
gen_Sortable_tests(
values => [-3.1, 2.1, 4.1],
),
# is_{nan,inf,pos_inf,neg_inf} is currently tested in perl compiler
);
}
sub gen_array_tests {
my %args = @_;
my @res;
local $Type = "array";
push @res, (
gen_type_check_tests(
accept => [[], [1, "a"], [[]]],
reject => [1, "a", {}],
),
gen_BaseType_tests(
value => [1],
ok_defaults => [[]],
nok_defaults => ["a"],
ok_clauses => [[min_len=>0], [max_len=>1]],
nok_clauses => [[min_len=>2], [max_len=>0]],
),
gen_err_level_tests(
clause => 'is',
cval => [],
ok_value => [],
nok_value => [0],
),
gen_Comparable_tests(
values => [[1], [2]],
),
gen_HasElems_tests(
# two values, each value is [VAL, LEN].
values => [ [[1], 1], [[1, 1.2], 2] ],
# will be tested on the second value
ok_each_index => [int => max => 1],
nok_each_index => [int => xmax => 1],
ok_each_elem => "float",
nok_each_elem => "int",
# 'elems' is actually not part of HasElems currently, but we stick
# it in here for the moment. str might get 'elems' too.
elems_test => {value=>[1, 1.2], ok=>["int","float"], nok=>["int","int"]},
),
);
my $sch = [array => {elems => ["int*", ["float", default=>2]]}];
push @res, (
{
name => 'elems (nok, first elem required)',
input => [undef, 1],
schema => $sch,
valid => 0,
},
{
name => 'elems (ok, missing elem set to undef)',
input => [1],
schema => $sch,
valid => 1,
},
{
name => 'elems (ok, second elem optional)',
input => [1, undef],
schema => $sch,
valid => 1,
},
{
name => 'elems (ok 2)',
input => [1, 1.1],
schema => $sch,
valid => 1,
},
{
name => 'elems (ok, extra elems ignored)',
input => [1, 1.1, undef],
schema => $sch,
valid => 1,
},
{
name => 'elems (ok, extra elems ignored 2)',
input => [1, 1.1, "foo"],
schema => $sch,
valid => 1,
},
);
$sch = [array => {elems => ["int", ["int", default=>2]],
"elems.create_default"=>0}];
push @res, (
{
name => 'elems (ok, create_default=0)',
input => [1],
schema => $sch,
valid => 1,
output => [1],
},
{
name => 'elems (ok 2, create_default=0)',
input => [1, undef],
schema => $sch,
valid => 1,
output => [1, 2],
},
);
@res;
}
sub gen_str_tests {
my %args = @_;
my @res;
local $Type = "str";
push @res, (
gen_type_check_tests(
accept => [0, 1.1, "", "str\n"],
reject => [[], {}],
),
gen_BaseType_tests(
value => "a",
ok_defaults => ["a"],
nok_defaults => [[]],
ok_clauses => [[match=>"a"], [len=>1]],
nok_clauses => [[match=>"b"], [len=>2]],
),
gen_err_level_tests(
clause => 'is',
cval => "a",
ok_value => "a",
nok_value => "a\n",
),
gen_Comparable_tests(
values => ["a", "b"],
),
gen_Sortable_tests(
values => ["", "a", "ab"],
),
gen_HasElems_tests(
# two values, each value is [VAL, LEN]
values => [ ["a", 1], ["abc", 3] ],
# will be tested on the second value
ok_each_index => [int => max => 2],
nok_each_index => [int => xmax => 2],
ok_each_elem => "str",
nok_each_elem => "float",
# currently only array has 'elems' clause, and it's not part of
# HasELems role
#elems_test => {value=>"abc", ok=>["str","str","str"], nok=>["str","str",[str=>is=>"d"]]},
),
{
name => 'match: (ok)',
input => "a",
schema => [str => match => "[abc]"],
valid => 1,
},
{
name => 'match: (nok)',
input => "z",
schema => [str => match => "[abc]"],
valid => 0,
},
{
name => 'match: (dies, invalid regex)',
input => "a",
schema => [str => match => "("],
dies => 1,
},
{
name => 'is_re: 1 (ok)',
input => "a",
schema => [str => is_re => 1],
valid => 1,
},
{
name => 'is_re: 1 (nok)',
input => "a(",
schema => [str => is_re => 1],
valid => 0,
},
{
name => 'is_re: 0 (ok)',
input => "a(",
schema => [str => is_re => 0],
valid => 1,
},
{
name => 'is_re: 0 (nok)',
input => "a",
schema => [str => is_re => 0],
valid => 0,
},
);
@res;
}
sub gen_hash_tests {
my %args = @_;
my @res;
my ($sch, $sch2);
local $Type = "hash";
push @res, (
gen_type_check_tests(
accept => [{}, {a=>1}, {""=>[]}],
reject => [1, "a", []],
),
gen_BaseType_tests(
value => {a=>1},
ok_defaults => [{}],
nok_defaults => ["a"],
ok_clauses => [[min_len=>1], [max_len=>1]],
nok_clauses => [[min_len=>2], [max_len=>0]],
),
gen_err_level_tests(
clause => 'is',
cval => {a=>0},
ok_value => {a=>0},
nok_value => {a=>1},
),
gen_Comparable_tests(
values => [{}, {a=>1}],
),
gen_HasElems_tests(
# two values, each value is [VAL, LEN].
values => [ [{a=>1}, 1], [{a=>1, b=>1.1}, 2] ],
# will be tested on the second value
ok_each_index => [str => len=>1],
nok_each_index => [str => len=>2],
ok_each_elem => "float",
nok_each_elem => "int",
# currently only array has 'elems' clause, and it's not part of
# HasELems role
)
);
$sch = [hash => {keys => {a=>"int", b=>"float*"}}];
$sch2 = [hash => {keys => {a=>"int", b=>"float*"}}];
push @res, (
{
name => 'keys: (ok, empty)',
input => {},
schema => $sch,
valid => 1,
},
{
name => 'keys: (ok, only a, a valid 1)',
input => {a=>undef},
schema => $sch,
valid => 1,
},
{
name => 'keys: (ok, only a, a valid 2)',
input => {a=>1},
schema => $sch,
valid => 1,
},
{
name => 'keys: (nok, only a, a invalid)',
input => {a=>1.1},
schema => $sch,
valid => 0,
},
{
name => 'keys: (ok, only a, valid 2)',
input => {a=>1},
schema => $sch,
valid => 1,
},
{
name => 'keys: (ok, a & b, valid)',
input => {a=>1, b=>1.1},
schema => $sch,
valid => 1,
},
{
name => 'keys: (nok, a & b, b invalid)',
input => {a=>1, b=>undef},
schema => $sch,
valid => 0,
},
{
name => 'keys: (nok, a & b, a invalid)',
input => {a=>1.1, b=>1.1},
schema => $sch,
valid => 0,
},
{
name => 'keys: (nok, a & b, a & b invalid)',
input => {a=>1.1, b=>undef},
schema => $sch,
valid => 0,
},
{
name => 'keys: (nok, extra)',
input => {a=>1, b=>1.1, c=>1},
schema => $sch,
valid => 0,
},
{
name => 'keys: (ok, extra, restrict=0)',
input => {a=>1, b=>1.1, c=>1},
schema => $sch,
valid => 0,
},
);
$sch = [hash => {keys => {a=>"int", b=>["int", default=>2]}}];
push @res, (
{
name => 'keys (create_default=1) 1',
input => {},
schema => $sch,
valid => 1,
output => {b=>2},
},
{
name => 'keys (create_default=1) 2',
input => {b=>undef},
schema => $sch,
valid => 1,
output => {b=>2},
},
);
$sch = [hash => {keys => {a=>"int", b=>["int", default=>2]},
"keys.create_default" => 0}];
push @res, (
{
name => 'keys (create_default=0) 1',
input => {},
schema => $sch,
valid => 1,
output => {},
},
{
name => 'keys (create_default=0) 2',
input => {b=>undef},
schema => $sch,
valid => 1,
output => {b=>2},
},
);
# XXX re_keys
# XXX req_keys
# XXX allowed_keys
# XXX allowed_keys_re
@res;
}
sub gen_bool_tests {
my %args = @_;
my @res;
# XXX how to dump YAML's boolean?
local $Type = "bool";
(
gen_type_check_tests(
accept => [0, 1],
reject => [[], {}], # in perl, "a", -2, 3.4 are ok
),
gen_BaseType_tests(
value => 1,
ok_defaults => [1],
nok_defaults => [[]],
# perl-specific, no real bool value
#ok_clauses => [[is_true=>1], [is=>1]],
#nok_clauses => [[is_true=>0], [is=>0]],
),
gen_err_level_tests(
clause => 'is',
cval => 1,
ok_value => 1,
nok_value => 0,
),
gen_Comparable_tests(
values => [0, 1],
),
gen_Sortable_tests(
values => [0, 1, 1],
),
{
name => 'is_true: 1 (ok)',
input => 1,
schema => [$Type => is_true => 1],
valid => 1,
},
{
name => 'is_true: 1 (nok)',
input => 0,
schema => [$Type => is_true => 1],
valid => 0,
},
{
name => 'is_true: 0 (ok)',
input => 0,
schema => [$Type => is_true => 0],
valid => 1,
},
{
name => 'is_true: 0 (nok)',
input => 1,
schema => [$Type => is_true => 0],
valid => 0,
},
{
name => 'is_true: undef (ok 1)',
input => 0,
schema => [$Type => is_true => undef],
valid => 1,
},
{
name => 'is_true: undef (ok 2)',
input => 1,
schema => [$Type => is_true => undef],
valid => 1,
},
);
}
sub gen_any_tests {
my %args = @_;
my @res;
local $Type = "any";
(
{
name => 'of (nok + nok)',
input => 3,
schema => [$Type => of => [[int => div_by=>2], [int => div_by=>5]]],
valid => 0,
},
{
name => 'of (ok + nok)',
input => 2,
schema => [$Type => of => [[int => div_by=>2], [int => div_by=>5]]],
valid => 1,
},
{
name => 'of (nok + ok)',
input => 5,
schema => [$Type => of => [[int => div_by=>2], [int => div_by=>5]]],
valid => 1,
},
{
name => 'of (ok + ok)',
input => 10,
schema => [$Type => of => [[int => div_by=>2], [int => div_by=>5]]],
valid => 1,
},
);
}
sub gen_all_tests {
my %args = @_;
my @res;
local $Type = "all";
(
{
name => 'of (nok + nok)',
input => 3,
schema => [$Type => of => [[int => div_by=>2], [int => div_by=>5]]],
valid => 0,
},
{
name => 'of (ok + nok)',
input => 2,
schema => [$Type => of => [[int => div_by=>2], [int => div_by=>5]]],
valid => 0,
},
{
name => 'of (nok + ok)',
input => 5,
schema => [$Type => of => [[int => div_by=>2], [int => div_by=>5]]],
valid => 0,
},
{
name => 'of (ok + ok)',
input => 10,
schema => [$Type => of => [[int => div_by=>2], [int => div_by=>5]]],
valid => 1,
},
);
}
{
my $now = localtime();
local $YAML::Syck::Headless = 1;
local $YAML::Syck::ImplicitTyping = 1;
for my $type (qw(int float array str hash bool any all)) {
my $v = "v$VERSION (generated by $0 on $now)",
my $f = "gen_${type}_tests";
no strict 'refs';
write_file(
"$Bin/../share/spectest/10-type-$type.yaml",
Dump({version => $v, tests => [$f->()]}),
);
}
}
Jump to Line
Something went wrong with that request. Please try again.