File Coverage

blib/lib/Test/TypeConstraints.pm

Criterion	Covered	Total	%
statement	62	62	100.0
branch	12	14	85.7
condition	5	9	55.5
subroutine	17	17	100.0
pod	4	5	80.0
total	100	107	93.4

package Test::TypeConstraints;
use strict;
use warnings;
use 5.008001;
our $VERSION = '0.07';
use Exporter 'import';
use Test::More;
use Test::Builder;
use Mouse::Util::TypeConstraints ();
use Scalar::Util ();
use Data::Dumper;

our @EXPORT = qw/ type_isa type_does type_isnt type_doesnt /;

sub type_isa {
    my ($got, $type, @rest) = @_;

    my $tc = _make_type_constraint(
        $type,
        \&Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint
    );

    local $Test::Builder::Level = $Test::Builder::Level + 1;
    return _type_constraint_ok( $got, $tc, @rest );
}

sub type_does {
    my ($got, $type, @rest) = @_;

    my $tc = _make_type_constraint(
        $type,
        \&Mouse::Util::TypeConstraints::find_or_create_does_type_constraint
    );

    local $Test::Builder::Level = $Test::Builder::Level + 1;
    return _type_constraint_ok( $got, $tc, @rest );
}

sub type_isnt {
    my ($got, $type, @rest) = @_;

    my $tc = _make_type_constraint(
        $type,
        \&Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint
    );

    local $Test::Builder::Level = $Test::Builder::Level + 1;
    return _type_constraint_not_ok( $got, $tc, @rest );
}

sub type_doesnt {
    my ($got, $type, @rest) = @_;

    my $tc = _make_type_constraint(
        $type,
        \&Mouse::Util::TypeConstraints::find_or_create_does_type_constraint
    );

    local $Test::Builder::Level = $Test::Builder::Level + 1;
    return _type_constraint_not_ok( $got, $tc, @rest );
}

sub _make_type_constraint {
    my($type, $make_constraint) = @_;

    # duck typing for (Mouse|Moose)::Meta::TypeConstraint
    if ( Scalar::Util::blessed($type) && $type->can("check") ) {
        return $type;
    } else {
        return $make_constraint->($type);
    }
}

sub _type_constraint_ok {
    my ($got, $tc, $test_name, %options) = @_;

    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my $ret = ok(check_type($tc, $got, %options), $test_name || ( $tc->name . " types ok" ) )
        or diag(sprintf('type: "%s" expected. but got %s', $tc->name, Dumper($got)));

    return $ret;
}

sub _type_constraint_not_ok {
    my ($got, $tc, $test_name, %options) = @_;

    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my $ret = ok(!check_type($tc, $got, %options), $test_name || ( $tc->name . " types ok" ) )
        or diag(sprintf('%s is not supposed to be of type "%s"', $tc->name, Dumper($got)));

    return $ret;
}

sub check_type {
    my ($tc, $value, %options) = @_;

    return 1 if $tc->check($value);
    if ( my $coerce_check = $options{coerce} ) {
        my $new_val = $tc->coerce($value);
        $coerce_check->($new_val) if ref $coerce_check;
        return 1 if $tc->check($new_val);
    }

    return 0;
}

1;
__END__