use strict;
use warnings;
package Test::RxTester;
use autodie;
use Data::Rx;
use File::Find::Rule;
use JSON ();
use Scalar::Util;
use Test::Deep::NoTest qw/ :DEFAULT cmp_details deep_diag /;
use Test::More ();
use Try::Tiny;
sub _decode_json {
my ($self, $json_str) = @_;
$self->{__json} ||= JSON->new;
$self->{__json}->decode($json_str);
}
sub _slurp_json {
my ($self, $fn) = @_;
my $json = do { local $/; open my $fh, '<', $fn; <$fh> };
my $data = eval { JSON->new->decode($json) };
die "$@ (in $fn)" unless $data;
return $data;
}
sub new {
my ($class, $file) = @_;
my $self = bless {} => $class;
my $spec = $self->_slurp_json( $file );
$self->{spec} = $spec->{tests};
$self->{plan} = $spec->{count};
return $self;
}
sub plan {
$_[0]->{plan};
}
my $fudge = {
int => { str => "Perl has trouble with num/str distinction", },
num => { str => "Perl has trouble with num/str distinction", },
str => { num => "Perl has trouble with num/str distinction", },
'str-empty' => { num => 'Perl has trouble with num/str distinction' },
'str-x' => { num => 'Perl has trouble with num/str distinction' },
'str-length' => { num => 'Perl has trouble with num/str distinction' },
'num-0' => { str => 'Perl has trouble with num/str distinction', },
'int-0' => { str => 'Perl has trouble with num/str distinction', },
'int-range' => { str => 'Perl has trouble with num/str distinction', },
'int-range-empty' => { str => 'Perl has trouble with num/str distinction', },
'num-range' => { str => 'Perl has trouble with num/str distinction', },
'array-3-int' => {
arr => {
'0-s1-1' => 'Perl has trouble with num/str distinction',
},
},
};
sub fudge_reason {
my ($schema, $source, $entry) = @_;
return unless $fudge->{$schema}
and my $se_reason = $fudge->{$schema}{$source};
return $se_reason if ! ref $se_reason;
return unless my $reason = $se_reason->{$entry};
return $reason;
}
sub assert_pass {
my ($self, $arg) = @_;
my ($schema, $schema_desc, $input, $input_desc)
= @$arg{ qw(schema schema_desc input input_desc) };
my $desc = "$schema_desc should ACCEPT $input_desc";
try {
$schema->assert_valid($input);
Test::More::pass("$desc");
} catch {
my $fails = $_;
Test::More::fail("$desc");
(my $diag = "$fails") =~ s/^/ /mg;
Test::More::diag($diag);
}
}
sub assert_fail {
my ($self, $arg) = @_;
my ($schema, $schema_desc, $schema_spec, $input, $input_desc, $want)
= @$arg{ qw(schema schema_desc schema_spec input input_desc want) };
my $desc = "$schema_desc should REJECT $input_desc";
try {
$schema->assert_valid($input);
Test::More::fail($desc);
} catch {
my $fails = $_;
my $ok = 1;
my @diag;
FAILS:
{
if (try { $fails->isa('Data::Rx::FailureSet') }) {
my $fail = $fails->failures;
$want ||= [];
if (@$want > 1) {
if (@$want != @$fail) {
$ok = 0;
push @diag, 'want ' . @$want . ' failures',
'have ' . @$fail . ' failures';
last FAILS;
}
} else {
@$fail = $fail->[0];
}
for (my $i = 0; $i <= $#$want; ++$i) {
my ($tmp_ok, @tmp_diag) =
$self->compare_fail({ %$arg, want => $want->[$i],
fail => $fail->[$i] });
$tmp_ok
or do {
$ok = 0;
push @diag, "want/fail index $i:",
map " $_", @tmp_diag;
};
}
} else {
$ok = 0;
my $desc = Scalar::Util::blessed($fails)
? Scalar::Util::blessed($fails)
: ref($fails)
? "unblessed " . ref($fails)
: "non-ref: $fails";
push @diag, 'want $@: Data::Rx::FailureSet',
'have $@: ' . $desc;
}
}
Test::More::ok($ok, $desc);
Test::More::diag " $_" for @diag;
}
}
sub compare_fail {
my ($self, $arg) = @_;
my ($schema, $schema_desc, $schema_spec, $input, $input_desc, $want, $fail)
= @$arg{ qw(schema schema_desc schema_spec input input_desc want fail) };
my $ok = 1;
my @diag;
if ($want->{data}) {
eq_deeply([$fail->data_path],$want->{data})
or do {
$ok = 0;
my $want = @{ $want->{data} } ? "[ @{ $want->{data} } ]" : '(empty)';
my $have = $fail->data_path ? "[ @{[$fail->data_path]} ]" : '(empty)';
push @diag, "want path to data: $want",
"have path to data: $have";
};
}
if ($want->{check}) {
eq_deeply([$fail->check_path],$want->{check})
or do {
$ok = 0;
my $want = @{ $want->{check} } ? "[ @{ $want->{check} } ]" : '(empty)';
my $have = $fail->check_path ? "[ @{[$fail->check_path]} ]" : '(empty)';
push @diag, "want path to check: $want",
"have path to check: $have";
};
}
if ($want->{error}) {
eq_deeply([sort $fail->error_types],$want->{error})
or do {
$ok = 0;
my $want = @{ $want->{error} } ? "[ @{ $want->{error} } ]" : '(empty)';
my $have = $fail->error_types ? "[ @{[$fail->error_types]} ]" : '(empty)';
push @diag, "want error types: $want",
"have error types: $have";
};
}
if (!$ok) {
unshift @diag, "$fail";
}
return ($ok, @diag);
}
sub run_tests {
my ($self, @spec_names) = @_;
my $spec_data = $self->{spec};
if (!@spec_names) {
@spec_names = sort keys %$spec_data;
}
SPEC: for my $spec_name (@spec_names) {
my $spec = $spec_data->{ $spec_name }
or die "invalid spec name $spec_name";
Test::More::diag "testing $spec_name";
my $rx = Data::Rx->new({ sort_keys => 1 });
if ($spec->{'composedtype'}) {
my $rc =
eval { $rx->learn_type($spec->{'composedtype'}{'uri'},
$spec->{'composedtype'}{'schema'});
1 };
my $error = $@;
if ($spec->{'composedtype'}{'invalid'}) {
Test::More::ok($error && !$rc, "BAD COMPOSED TYPE: $spec_name");
next SPEC;
}
$rx->add_prefix(@{$spec->{'composedtype'}{'prefix'}})
if $spec->{'composedtype'}{'prefix'};
}
my $schema = eval { $rx->make_schema($spec->{schema}) };
my $error = $@;
if ($spec->{invalid}) {
Test::More::ok($error && ! $schema, "$spec_name should be INVALID");
next SPEC;
}
Carp::croak("couldn't produce schema for valid input ($spec_name): $error")
unless $schema;
Carp::croak("rx attribute not set in schema ($spec_name)")
unless $schema->rx;
for my $test_name (sort keys %{ $spec->{test} }) {
my $test_spec = $spec->{test}{$test_name};
my $input = $self->_decode_json("[ $test_spec->{input} ]")->[0];
my $method = @{ $test_spec->{errors} } ? 'assert_fail' : 'assert_pass';
TODO: {
my ($source, $entry) = split m{/}, $test_name, 2;
my $reason = fudge_reason($spec_name, $source, $entry);
local our $TODO = $reason if $reason;
$self->$method({
schema => $schema,
schema_desc => $spec_name,
schema_spec => $spec->{schema},
input => $input,
input_desc => $test_name,
want => $test_spec->{errors},
});
}
}
}
}
1;