File Coverage

blib/lib/Test/Deep/JType.pm

Criterion	Covered	Total	%
statement	85	85	100.0
branch	22	22	100.0
condition	3	4	75.0
subroutine	32	32	100.0
pod	6	6	100.0
total	148	149	99.3

use strict;
use warnings;
package Test::Deep::JType;
# ABSTRACT: Test::Deep helpers for JSON::Typist data
$Test::Deep::JType::VERSION = '0.006';
use JSON::PP ();
use JSON::Typist ();
use Test::Deep 1.126 (); # LeafWrapper, as_test_deep_cmp

use Exporter 'import';
our @EXPORT = qw( jcmp_deeply jstr jnum jbool jtrue jfalse );

#pod =head1 OVERVIEW
#pod
#pod L is a very useful library for testing data structures.
#pod Test::Deep::JType extends it with routines for testing
#pod L-annotated data.
#pod
#pod By default, Test::Deep's C will interpret plain numbers and strings
#pod as shorthand for C tests, meaning that the corresponding input
#pod data will also need to be a plain number or string.  That means that this test
#pod won't work:
#pod
#pod   my $json  = q[ { "key": "value" } ];
#pod   my $data  = decode_json($json);
#pod   my $typed = JSON::Typist->new->apply_types( $data );
#pod
#pod   cmp_deeply($typed, { key => "value" });
#pod
#pod ...because C<"value"> will refuse to match an object.  You I wrap each
#pod string or number to be compared in C or C respectively, but this
#pod can be a hassle, as well as a lot of clutter.
#pod
#pod C is exported by Test::Deep::JType, and behaves just like
#pod C, but plain numbers and strings are wrapped in C tests
#pod rather than shallow ones, so they always compare with C.
#pod
#pod To test that the input data matches the right type, other routines are exported
#pod that check type as well as content.
#pod
#pod =cut

#pod =func jcmp_deeply
#pod
#pod This behaves just like Test::Deep's C but wraps plain scalar and
#pod number expectations in C, meaning they're compared with C only,
#pod instead of also asserting that the found value must not be an object.
#pod
#pod =cut

sub jcmp_deeply {
  local $Test::Builder::Level = $Test::Builder::Level + 1;
  local $Test::Deep::LeafWrapper = sub { Test::Deep::JType::_String->new(@_) },
  Test::Deep::cmp_deeply(@_);
}

#pod =func jstr
#pod
#pod =func jnum
#pod
#pod =func jbool
#pod
#pod =func jtrue
#pod
#pod =func jfalse
#pod
#pod These routines are plain old Test::Deep-style assertions that check not only
#pod for data equivalence, but also that the data is the right type.
#pod
#pod C, C, and C take arguments, which are passed to the non-C
#pod version of the test used in building the C-style version.  In other words,
#pod you can write:
#pod
#pod   jcmp_deeply(
#pod     $got,
#pod     {
#pod       name => jstr("Ricardo"),
#pod       age  => jnum(38.2, 0.01),
#pod       calm => jbool(1),
#pod       cool => jbool(),
#pod       collected => jfalse(),
#pod     },
#pod   );
#pod
#pod If no argument is given, then the wrapped value isn't inspected.  C just
#pod makes sure the value was a JSON string, without comparing it to anything.
#pod
#pod C and C are shorthand for C and C,
#pod respectively.
#pod
#pod As long as they've got a specific value to test for (that is, you called
#pod C and not C, the tests produced by these routines will
#pod serialize via a C-enabled JSON encode into the appropriate
#pod types.  This makes it convenient to use these routines for building JSON as
#pod well as testing it.
#pod
#pod =cut

my $STRING = Test::Deep::obj_isa('JSON::Typist::String');
my $NUMBER = Test::Deep::obj_isa('JSON::Typist::Number');
my $BOOL   = Test::Deep::any(
  Test::Deep::obj_isa('JSON::XS::Boolean'),
  Test::Deep::obj_isa('JSON::PP::Boolean'),
);

sub jstr  { Test::Deep::JType::jstr->new(@_);  }
sub jnum  { Test::Deep::JType::jnum->new(@_);  }
sub jbool { Test::Deep::JType::jbool->new(@_); }

my $TRUE  = jbool(1);
my $FALSE = jbool(0);

sub jtrue  { $TRUE  }
sub jfalse { $FALSE }

{
  package
    Test::Deep::JType::_String;

  use Test::Deep::Cmp;

  sub init
  {
    my $self = shift;

    $self->{val} = shift;
  }

  sub descend
  {
    my $self = shift;
    my $got = shift();

    # If either is undef but not both this is a failure where
    # as Test::Deep::String would just stringify the undef,
    # throw a warning, and pass
    if (defined($got) xor defined($self->{val})) {
      return 0;
    }

    return $got eq $self->{val};
  }

  sub diag_message
  {
    my $self = shift;

    my $where = shift;

    return "Comparing $where as a string";
  }
}

{
  package Test::Deep::JType::jstr;
$Test::Deep::JType::jstr::VERSION = '0.006';
use overload
    '""'    => sub {
      Carp::confess("can't use valueless jstr() as a string")
        unless defined ${ $_[0] };
      return ${ $_[0] };
    },
    fallback => 1;

  BEGIN { our @ISA = 'JSON::Typist::String'; }
  sub TO_JSON {
    Carp::confess("can't use valueless jstr() test as JSON data")
      unless defined ${ $_[0] };
    return "${ $_[0] }";
  }

  sub as_test_deep_cmp {
    my ($self) = @_;
    my $value = $$self;
    return defined $value ? Test::Deep::all($STRING, Test::Deep::str($value))
                          : $STRING;
  }
}

{
  package Test::Deep::JType::jnum;
$Test::Deep::JType::jnum::VERSION = '0.006';
use overload
    '0+'    => sub {
      Carp::confess("can't use valueless jnum() as a number")
        unless defined ${ $_[0] };
      return ${ $_[0] };
    },
    fallback => 1;

  BEGIN { our @ISA = 'JSON::Typist::Number'; }
  sub TO_JSON {
    Carp::confess("can't use valueless jnum() test as JSON data")
      unless defined ${ $_[0] };
    return 0 + ${ $_[0] };
  }

  sub as_test_deep_cmp {
    my ($self) = @_;
    my $value = $$self;
    return defined $value ? Test::Deep::all($NUMBER, Test::Deep::num($value))
                          : $NUMBER;
  }
}

{
  package Test::Deep::JType::jbool;
$Test::Deep::JType::jbool::VERSION = '0.006';
use overload
    'bool'    => sub {
      Carp::confess("can't use valueless jbool() as a bool")
        unless defined ${ $_[0] };
      return ${ $_[0] };
    },
    fallback => 1;

  sub TO_JSON {
    Carp::confess("can't use valueless jbool() test as JSON data")
      unless defined ${ $_[0] };
    return ${ $_[0] } ? \1 : \0;
  }

  sub new {
    my ($class, $value) = @_;
    bless \$value, $class;
  }

  sub as_test_deep_cmp {
    my ($self) = @_;
    my $value = $$self;
    return defined $value ? Test::Deep::all($BOOL, Test::Deep::bool($value))
                          : $BOOL;
  }
}

1;

__END__