Move is_valid_class_name into XS

[gitmo/Mouse.git] / t / 001_mouse / 057_subtype_without_where.t

#!/usr/bin/perl -w
use Test::More tests => 4;
use Test::Exception;

use Mouse::Util::TypeConstraints;

{
    package Class;
    sub new {
        my $class = shift;
        return bless { @_ }, $class;
    }
}

subtype 'Class',
    as 'Object',
    where { $_->isa('Class') };

subtype 'C', as 'Class'; # subtyping without "where"

coerce 'C',
    from 'Str',
    via { Class->new(content => $_) },
    from 'HashRef',
    via { Class->new(content => $_->{content}) };

{
    package A;
    use Mouse;

    has foo => (
        is => 'ro',
        isa => 'C',
        coerce => 1,
        required => 1,
    );
}

lives_and{
    my $a = A->new(foo => 'foobar');
    isa_ok $a->foo, 'Class';
    is $a->foo->{content}, 'foobar';
};

lives_and{
    my $a = A->new(foo => { content => 42 });
    isa_ok $a->foo, 'Class';
    is $a->foo->{content}, 42;
};