t/030_roles/failing/032_roles_and_method_cloning.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 17;
   7
   8
   9 {
  10     package Role::Foo;
  11     use Mouse::Role;
  12
  13     sub foo { (caller(0))[3] }
  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 }
  73
  74 isnt( ClassA->foo, "ClassB::foo", "ClassA::foo is not confused with ClassB::foo");
  75
  76 {
  77     local $TODO =
  78       "multiply-consumed roles' subs take on their most recently used name";
  79     is( ClassB->foo, 'ClassB::foo', 'ClassB::foo knows its name' );
  80     is( ClassA->foo, 'ClassA::foo', 'ClassA::foo knows its name' );
  81 }