view release on metacpan or  search on metacpan

t/lib/Test/RxTester.pm  view on Meta::CPAN

use v5.12.0;
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;