Move is_valid_class_name into XS

[gitmo/Mouse.git] / t / 001_mouse / 062-duck_type.t

#!perl
use strict;
use warnings;

use Test::More tests => 15;

use Mouse::Util::TypeConstraints qw(duck_type);

{
    package Foo;
    use Mouse;

    sub a {}

    package Bar;
    use Mouse;

    extends qw(Foo);

    sub b {}

    package Baz;
    use Mouse;

    sub can {
        my($class, $method) = @_;
        return $method eq 'b';
    }
}

my $CanA   = duck_type CanA => qw(a);
my $CanB  = duck_type CanB => [qw(b)];
my $CanAB = duck_type [qw(a b)];

is $CanA->name, 'CanA';
is $CanB->name, 'CanB';
is $CanAB->name, '__ANON__';

ok $CanA->check(Foo->new);
ok $CanA->check(Bar->new);
ok!$CanA->check(Baz->new);

ok!$CanB->check(Foo->new);
ok $CanB->check(Bar->new);
ok $CanB->check(Baz->new);

ok!$CanAB->check(Foo->new);
ok $CanAB->check(Bar->new);
ok!$CanAB->check(Baz->new);

ok!$CanA->check(undef);
ok!$CanA->check(1);
ok!$CanA->check({});