File Coverage

blib/lib/Test/Deep/Type.pm

Criterion	Covered	Total	%
statement	51	51	100.0
branch	15	16	93.7
condition	5	5	100.0
subroutine	17	17	100.0
pod	1	1	100.0
total	89	90	98.8

use strict;
use warnings;
package Test::Deep::Type; # git description: v0.007-3-g1a9faf7
# vim: set ts=8 sts=4 sw=4 tw=115 et :
# ABSTRACT: A Test::Deep plugin for validating type constraints
# KEYWORDS: testing tests plugin types

our $VERSION = '0.008';

use Exporter 5.57 'import';
our @EXPORT = qw(is_type);

sub is_type($)
{
    return Test::Deep::Type::Object->new($_[0]);
}

package # hide from PAUSE
    Test::Deep::Type::Object;

our $VERSION = '0.008';

use parent 'Test::Deep::Cmp';
use Scalar::Util ();
use Try::Tiny ();

sub init
{
    my ($self, $type) = @_;
    $self->{type} = $type;
}

sub descend
{
    my ($self, $got) = @_;
    return $self->_is_type($self->{type}, $got);
}

sub diag_message
{
    my ($self, $where) = @_;
    my $name = $self->_type_name($self->{type});
    return 'Validating ' . $where . ' as a'
        . (defined $name ? ' ' . $name : 'n unknown')
        . ' type';
}

# we do not define a diagnostics sub, so we get the one produced by deep_diag
# showing exactly what part of the data structure failed. This calls renderGot
# and renderVal:

sub renderGot
{
    my $self = shift;   # my $got = shift;
    return defined $self->{error_message} ? $self->{error_message} : 'failed';
}

sub renderExp
{
    my $self = shift;
    return 'no error';
}

sub _is_type
{
    my ($self, $type, $got) = @_;

    if (eval { $type->can('validate') })
    {
        $self->{error_message} = $type->validate($got);
        return !defined($self->{error_message});
    }

    # last ditch effort - use the type as a coderef
    if (__isa_coderef($type))
    {
        return Try::Tiny::try {
            $type->($got)
        } Try::Tiny::catch {
            chomp($self->{error_message} = $_);
            undef;
        };
    }

    # for now, stringy types are not supported. If a known Moose type, use
    # Moose::Util::TypeConstraints::find_type_constraint('typename').

    $self->{error_message} = "Can't figure out how to use '$type' as a type";
    return;
}

sub _type_name
{
    my ($self, $type) = @_;

    # use $type->name if we can
    my $name = eval { $type->name };
    return $name if $name;

    # ...or stringify, if possible
    return "$type" if overload::Method($type, '""');

    # ...or its package name, if it has one
    my $class = Scalar::Util::blessed($type);
    return $class if defined $class;

    # plain old subref perhaps?
    return;
}

sub __isa_coderef
{
    ref $_[0] eq 'CODE'
        or (Scalar::Util::reftype($_[0]) || '') eq 'CODE'
        or overload::Method($_[0], '&{}')
}

1;

__END__