A tiny tweak
[gitmo/Mouse.git] / t / 030_roles / failing / 032_roles_and_method_cloning.t
CommitLineData
67199842 1#!/usr/bin/perl
2
3use strict;
4use warnings;
5
6use Test::More tests => 14;
7
8
9{
10 package Role::Foo;
11 use Mouse::Role;
12
13 sub foo { }
14}
15
16{
17 package ClassA;
18 use Mouse;
19
20 with 'Role::Foo';
21}
22
23{
24 my $meth = ClassA->meta->get_method('foo');
25 ok( $meth, 'ClassA has a foo method' );
26 isa_ok( $meth, 'Mouse::Meta::Method' );
27 is( $meth->original_method, Role::Foo->meta->get_method('foo'),
28 'ClassA->foo was cloned from Role::Foo->foo' );
29 is( $meth->fully_qualified_name, 'ClassA::foo',
30 'fq name is ClassA::foo' );
31 is( $meth->original_fully_qualified_name, 'Role::Foo::foo',
32 'original fq name is Role::Foo::foo' );
33}
34
35{
36 package Role::Bar;
37 use Mouse::Role;
38 with 'Role::Foo';
39
40 sub bar { }
41}
42
43{
44 my $meth = Role::Bar->meta->get_method('foo');
45 ok( $meth, 'Role::Bar has a foo method' );
46 is( $meth->original_method, Role::Foo->meta->get_method('foo'),
47 'Role::Bar->foo was cloned from Role::Foo->foo' );
48 is( $meth->fully_qualified_name, 'Role::Bar::foo',
49 'fq name is Role::Bar::foo' );
50 is( $meth->original_fully_qualified_name, 'Role::Foo::foo',
51 'original fq name is Role::Foo::foo' );
52}
53
54{
55 package ClassB;
56 use Mouse;
57
58 with 'Role::Bar';
59}
60
61{
62 my $meth = ClassB->meta->get_method('foo');
63 ok( $meth, 'ClassB has a foo method' );
64 is( $meth->original_method, Role::Bar->meta->get_method('foo'),
65 'ClassA->foo was cloned from Role::Bar->foo' );
66 is( $meth->original_method->original_method, Role::Foo->meta->get_method('foo'),
67 '... which in turn was cloned from Role::Foo->foo' );
68 is( $meth->fully_qualified_name, 'ClassB::foo',
69 'fq name is ClassA::foo' );
70 is( $meth->original_fully_qualified_name, 'Role::Foo::foo',
71 'original fq name is Role::Foo::foo' );
72}