Move is_valid_class_name into XS

[gitmo/Mouse.git] / t / 001_mouse / 039-subtype.t

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 14;
use Test::Exception;

use Mouse::Util::TypeConstraints;

do {
    package My::Class;
    use Mouse;
    use Mouse::Util::TypeConstraints;

    subtype 'NonemptyStr'
        => as 'Str'
        => where { length $_ }
        => message { "The string is empty!" };

    subtype 'MyClass'
        => as 'Object'
        => where { $_->isa(__PACKAGE__) };

    has name => (
        is  => 'ro',
        isa => 'NonemptyStr',
    );
};

ok(My::Class->new(name => 'foo'));

throws_ok { My::Class->new(name => '') } qr/^Attribute \(name\) does not pass the type constraint because: The string is empty!/;

my $st = subtype as 'Str', where{ length };

ok $st->is_a_type_of('Str');
ok!$st->is_a_type_of('NoemptyStr');

ok $st->check('Foo');
ok!$st->check(undef);
ok!$st->check('');

lives_and{
    my $tc = find_type_constraint('MyClass');
    ok $tc->check(My::Class->new());
    ok!$tc->check('My::Class');
    ok!$tc->check([]);
    ok!$tc->check(undef);
};

package Foo;
use Mouse::Util::TypeConstraints;

$st = subtype as 'Int', where{ $_ > 0 };

::ok $st->is_a_type_of('Int');
::ok $st->check(10);
::ok!$st->check(0);