Moose now warns about class implicitly overriding methods from local
[gitmo/Moose.git] / t / 030_roles / 003_apply_role.t
CommitLineData
78cd1d3b 1#!/usr/bin/perl
2
3use strict;
4use warnings;
5
d443cad0 6use Test::More tests => 87;
78cd1d3b 7use Test::Exception;
d443cad0 8use Test::Output;
78cd1d3b 9
78cd1d3b 10{
11 package FooRole;
78cd1d3b 12 use Moose::Role;
0be0b30e 13
14 has 'bar' => ( is => 'rw', isa => 'FooClass' );
15 has 'baz' => ( is => 'ro' );
16
17 sub goo {'FooRole::goo'}
18 sub foo {'FooRole::foo'}
19
20 override 'boo' => sub { 'FooRole::boo -> ' . super() };
21
22 around 'blau' => sub {
0558683c 23 my $c = shift;
24 'FooRole::blau -> ' . $c->();
0be0b30e 25 };
26}
78cd1d3b 27
0be0b30e 28{
3f562dd9 29 package BarRole;
30 use Moose::Role;
0be0b30e 31 sub woot {'BarRole::woot'}
32}
33
34{
78cd1d3b 35 package BarClass;
78cd1d3b 36 use Moose;
8ecb1fa0 37
0be0b30e 38 sub boo {'BarClass::boo'}
39 sub foo {'BarClass::foo'} # << the role overrides this ...
0be0b30e 40}
41
42{
78cd1d3b 43 package FooClass;
78cd1d3b 44 use Moose;
0be0b30e 45
78cd1d3b 46 extends 'BarClass';
d443cad0 47
48 ::stderr_like {
49 with 'FooRole';
50 } qr/The FooClass class has implicitly overridden the method \(goo\) from role FooRole\. If this is intentional, please exclude the method from composition to silence this warning \(see Moose::Cookbook::Roles::Recipe2\)/;
0be0b30e 51
52 sub blau {'FooClass::blau'} # << the role wraps this ...
53
54 sub goo {'FooClass::goo'} # << overrides the one from the role ...
0be0b30e 55}
56
57{
3f562dd9 58 package FooBarClass;
59 use Moose;
0be0b30e 60
3f562dd9 61 extends 'FooClass';
0be0b30e 62 with 'FooRole', 'BarRole';
78cd1d3b 63}
64
65my $foo_class_meta = FooClass->meta;
0be0b30e 66isa_ok( $foo_class_meta, 'Moose::Meta::Class' );
78cd1d3b 67
3f562dd9 68my $foobar_class_meta = FooBarClass->meta;
0be0b30e 69isa_ok( $foobar_class_meta, 'Moose::Meta::Class' );
3f562dd9 70
bbd2fe69 71dies_ok {
0be0b30e 72 $foo_class_meta->does_role();
73}
74'... does_role requires a role name';
bbd2fe69 75
76dies_ok {
e016145b 77 $foo_class_meta->add_role();
0be0b30e 78}
79'... apply_role requires a role';
bbd2fe69 80
81dies_ok {
e016145b 82 $foo_class_meta->add_role( bless( {} => 'Fail' ) );
0be0b30e 83}
84'... apply_role requires a role';
bbd2fe69 85
0be0b30e 86ok( $foo_class_meta->does_role('FooRole'),
87 '... the FooClass->meta does_role FooRole' );
88ok( !$foo_class_meta->does_role('OtherRole'),
89 '... the FooClass->meta !does_role OtherRole' );
ef333f17 90
0be0b30e 91ok( $foobar_class_meta->does_role('FooRole'),
92 '... the FooBarClass->meta does_role FooRole' );
93ok( $foobar_class_meta->does_role('BarRole'),
94 '... the FooBarClass->meta does_role BarRole' );
95ok( !$foobar_class_meta->does_role('OtherRole'),
96 '... the FooBarClass->meta !does_role OtherRole' );
3f562dd9 97
0558683c 98foreach my $method_name (qw(bar baz foo boo blau goo)) {
0be0b30e 99 ok( $foo_class_meta->has_method($method_name),
100 '... FooClass has the method ' . $method_name );
101 ok( $foobar_class_meta->has_method($method_name),
102 '... FooBarClass has the method ' . $method_name );
78cd1d3b 103}
104
0be0b30e 105ok( !$foo_class_meta->has_method('woot'),
106 '... FooClass lacks the method woot' );
107ok( $foobar_class_meta->has_method('woot'),
108 '... FooBarClass has the method woot' );
3f562dd9 109
78cd1d3b 110foreach my $attr_name (qw(bar baz)) {
0be0b30e 111 ok( $foo_class_meta->has_attribute($attr_name),
112 '... FooClass has the attribute ' . $attr_name );
113 ok( $foobar_class_meta->has_attribute($attr_name),
114 '... FooBarClass has the attribute ' . $attr_name );
78cd1d3b 115}
116
0be0b30e 117can_ok( 'FooClass', 'does' );
118ok( FooClass->does('FooRole'), '... the FooClass does FooRole' );
119ok( !FooClass->does('BarRole'), '... the FooClass does not do BarRole' );
120ok( !FooClass->does('OtherRole'), '... the FooClass does not do OtherRole' );
ef333f17 121
0be0b30e 122can_ok( 'FooBarClass', 'does' );
123ok( FooBarClass->does('FooRole'), '... the FooClass does FooRole' );
124ok( FooBarClass->does('BarRole'), '... the FooBarClass does FooBarRole' );
125ok( !FooBarClass->does('OtherRole'),
126 '... the FooBarClass does not do OtherRole' );
3f562dd9 127
78cd1d3b 128my $foo = FooClass->new();
0be0b30e 129isa_ok( $foo, 'FooClass' );
78cd1d3b 130
3f562dd9 131my $foobar = FooBarClass->new();
0be0b30e 132isa_ok( $foobar, 'FooBarClass' );
133
134is( $foo->goo, 'FooClass::goo', '... got the right value of goo' );
135is( $foobar->goo, 'FooRole::goo', '... got the right value of goo' );
136
137is( $foo->boo, 'FooRole::boo -> BarClass::boo',
138 '... got the right value from ->boo' );
139is( $foobar->boo, 'FooRole::boo -> FooRole::boo -> BarClass::boo',
140 '... got the right value from ->boo (double wrapped)' );
141
142is( $foo->blau, 'FooRole::blau -> FooClass::blau',
143 '... got the right value from ->blau' );
144is( $foobar->blau, 'FooRole::blau -> FooRole::blau -> FooClass::blau',
145 '... got the right value from ->blau' );
146
147foreach my $foo ( $foo, $foobar ) {
148 can_ok( $foo, 'does' );
149 ok( $foo->does('FooRole'), '... an instance of FooClass does FooRole' );
150 ok( !$foo->does('OtherRole'),
151 '... and instance of FooClass does not do OtherRole' );
152
153 can_ok( $foobar, 'does' );
154 ok( $foobar->does('FooRole'),
155 '... an instance of FooBarClass does FooRole' );
156 ok( $foobar->does('BarRole'),
157 '... an instance of FooBarClass does BarRole' );
158 ok( !$foobar->does('OtherRole'),
159 '... and instance of FooBarClass does not do OtherRole' );
78cd1d3b 160
fb1e11d5 161 for my $method (qw/bar baz foo boo goo blau/) {
0be0b30e 162 can_ok( $foo, $method );
fb1e11d5 163 }
78cd1d3b 164
0be0b30e 165 is( $foo->foo, 'FooRole::foo', '... got the right value of foo' );
78cd1d3b 166
0be0b30e 167 ok( !defined( $foo->baz ), '... $foo->baz is undefined' );
168 ok( !defined( $foo->bar ), '... $foo->bar is undefined' );
78cd1d3b 169
fb1e11d5 170 dies_ok {
0be0b30e 171 $foo->baz(1);
172 }
173 '... baz is a read-only accessor';
78cd1d3b 174
fb1e11d5 175 dies_ok {
0be0b30e 176 $foo->bar(1);
177 }
178 '... bar is a read-write accessor with a type constraint';
78cd1d3b 179
fb1e11d5 180 my $foo2 = FooClass->new();
0be0b30e 181 isa_ok( $foo2, 'FooClass' );
06b30515 182
fb1e11d5 183 lives_ok {
0be0b30e 184 $foo->bar($foo2);
185 }
186 '... bar is a read-write accessor with a type constraint';
fb1e11d5 187
0be0b30e 188 is( $foo->bar, $foo2, '... got the right value for bar now' );
fb1e11d5 189}