Commit | Line | Data |
67199842 |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; |
4 | use warnings; |
49a56bba |
5 | use Test::More; |
6 | BEGIN { |
7 | plan skip_all => |
8 | "This test requires Class::Method::Modifiers or Class::Method::Modifiers::Fast" |
9 | unless eval { |
10 | require Class::Method::Modifiers::Fast; |
11 | } or eval { |
12 | require Class::Method::Modifiers; |
13 | }; |
14 | } |
67199842 |
15 | |
49a56bba |
16 | plan tests => 86; |
67199842 |
17 | use Test::Exception; |
18 | |
19 | { |
20 | package FooRole; |
21 | use Mouse::Role; |
22 | |
23 | has 'bar' => ( is => 'rw', isa => 'FooClass' ); |
24 | has 'baz' => ( is => 'ro' ); |
25 | |
26 | sub goo {'FooRole::goo'} |
27 | sub foo {'FooRole::foo'} |
28 | |
29 | override 'boo' => sub { 'FooRole::boo -> ' . super() }; |
30 | # sub boo { 'FooRole::boo -> ' . shift->SUPER::boo() } |
31 | |
32 | around 'blau' => sub { |
33 | my $c = shift; |
34 | 'FooRole::blau -> ' . $c->(); |
35 | }; |
36 | } |
37 | |
38 | { |
39 | package BarRole; |
40 | use Mouse::Role; |
41 | sub woot {'BarRole::woot'} |
42 | } |
43 | |
44 | { |
45 | package BarClass; |
46 | use Mouse; |
47 | |
48 | sub boo {'BarClass::boo'} |
49 | sub foo {'BarClass::foo'} # << the role overrides this ... |
50 | } |
51 | |
52 | { |
53 | package FooClass; |
54 | use Mouse; |
55 | |
56 | extends 'BarClass'; |
57 | with 'FooRole'; |
58 | |
59 | sub blau {'FooClass::blau'} # << the role wraps this ... |
60 | |
61 | sub goo {'FooClass::goo'} # << overrides the one from the role ... |
62 | } |
63 | |
64 | { |
65 | package FooBarClass; |
66 | use Mouse; |
67 | |
68 | extends 'FooClass'; |
69 | with 'FooRole', 'BarRole'; |
70 | } |
71 | |
72 | my $foo_class_meta = FooClass->meta; |
73 | isa_ok( $foo_class_meta, 'Mouse::Meta::Class' ); |
74 | |
75 | my $foobar_class_meta = FooBarClass->meta; |
76 | isa_ok( $foobar_class_meta, 'Mouse::Meta::Class' ); |
77 | |
78 | dies_ok { |
79 | $foo_class_meta->does_role(); |
80 | } |
81 | '... does_role requires a role name'; |
82 | |
83 | dies_ok { |
84 | $foo_class_meta->add_role(); |
85 | } |
86 | '... apply_role requires a role'; |
87 | |
88 | dies_ok { |
89 | $foo_class_meta->add_role( bless( {} => 'Fail' ) ); |
90 | } |
91 | '... apply_role requires a role'; |
92 | |
93 | ok( $foo_class_meta->does_role('FooRole'), |
94 | '... the FooClass->meta does_role FooRole' ); |
95 | ok( !$foo_class_meta->does_role('OtherRole'), |
96 | '... the FooClass->meta !does_role OtherRole' ); |
97 | |
98 | ok( $foobar_class_meta->does_role('FooRole'), |
99 | '... the FooBarClass->meta does_role FooRole' ); |
100 | ok( $foobar_class_meta->does_role('BarRole'), |
101 | '... the FooBarClass->meta does_role BarRole' ); |
102 | ok( !$foobar_class_meta->does_role('OtherRole'), |
103 | '... the FooBarClass->meta !does_role OtherRole' ); |
104 | |
105 | foreach my $method_name (qw(bar baz foo boo blau goo)) { |
106 | # ok( $foo_class_meta->has_method($method_name), ## Mouse: no ->has_method |
107 | ok( FooClass->can($method_name), |
108 | '... FooClass has the method ' . $method_name ); |
109 | # ok( $foobar_class_meta->has_method($method_name), ## Mouse: no ->has_method |
110 | ok( FooClass->can($method_name), |
111 | '... FooBarClass has the method ' . $method_name ); |
112 | } |
113 | |
114 | #ok( !$foo_class_meta->has_method('woot'), ## Mouse: no ->has_method |
115 | ok( !FooClass->can('woot'), |
116 | '... FooClass lacks the method woot' ); |
117 | #ok( $foobar_class_meta->has_method('woot'), ## Mouse: no ->has_method |
118 | ok( FooBarClass->can('woot'), |
119 | '... FooBarClass has the method woot' ); |
120 | |
121 | foreach my $attr_name (qw(bar baz)) { |
122 | ok( $foo_class_meta->has_attribute($attr_name), |
123 | '... FooClass has the attribute ' . $attr_name ); |
124 | ok( $foobar_class_meta->has_attribute($attr_name), |
125 | '... FooBarClass has the attribute ' . $attr_name ); |
126 | } |
127 | |
128 | can_ok( 'FooClass', 'does' ); |
129 | ok( FooClass->does('FooRole'), '... the FooClass does FooRole' ); |
130 | ok( !FooClass->does('BarRole'), '... the FooClass does not do BarRole' ); |
131 | ok( !FooClass->does('OtherRole'), '... the FooClass does not do OtherRole' ); |
132 | |
133 | can_ok( 'FooBarClass', 'does' ); |
134 | ok( FooBarClass->does('FooRole'), '... the FooClass does FooRole' ); |
135 | ok( FooBarClass->does('BarRole'), '... the FooBarClass does FooBarRole' ); |
136 | ok( !FooBarClass->does('OtherRole'), |
137 | '... the FooBarClass does not do OtherRole' ); |
138 | |
139 | my $foo = FooClass->new(); |
140 | isa_ok( $foo, 'FooClass' ); |
141 | |
142 | my $foobar = FooBarClass->new(); |
143 | isa_ok( $foobar, 'FooBarClass' ); |
144 | |
145 | is( $foo->goo, 'FooClass::goo', '... got the right value of goo' ); |
146 | is( $foobar->goo, 'FooRole::goo', '... got the right value of goo' ); |
147 | |
148 | is( $foo->boo, 'FooRole::boo -> BarClass::boo', |
149 | '... got the right value from ->boo' ); |
150 | is( $foobar->boo, 'FooRole::boo -> FooRole::boo -> BarClass::boo', |
151 | '... got the right value from ->boo (double wrapped)' ); |
152 | |
153 | is( $foo->blau, 'FooRole::blau -> FooClass::blau', |
154 | '... got the right value from ->blau' ); |
155 | is( $foobar->blau, 'FooRole::blau -> FooRole::blau -> FooClass::blau', |
156 | '... got the right value from ->blau' ); |
157 | |
158 | foreach my $foo ( $foo, $foobar ) { |
159 | can_ok( $foo, 'does' ); |
160 | ok( $foo->does('FooRole'), '... an instance of FooClass does FooRole' ); |
161 | ok( !$foo->does('OtherRole'), |
162 | '... and instance of FooClass does not do OtherRole' ); |
163 | |
164 | can_ok( $foobar, 'does' ); |
165 | ok( $foobar->does('FooRole'), |
166 | '... an instance of FooBarClass does FooRole' ); |
167 | ok( $foobar->does('BarRole'), |
168 | '... an instance of FooBarClass does BarRole' ); |
169 | ok( !$foobar->does('OtherRole'), |
170 | '... and instance of FooBarClass does not do OtherRole' ); |
171 | |
172 | for my $method (qw/bar baz foo boo goo blau/) { |
173 | can_ok( $foo, $method ); |
174 | } |
175 | |
176 | is( $foo->foo, 'FooRole::foo', '... got the right value of foo' ); |
177 | |
178 | ok( !defined( $foo->baz ), '... $foo->baz is undefined' ); |
179 | ok( !defined( $foo->bar ), '... $foo->bar is undefined' ); |
180 | |
181 | dies_ok { |
182 | $foo->baz(1); |
183 | } |
184 | '... baz is a read-only accessor'; |
185 | |
186 | dies_ok { |
187 | $foo->bar(1); |
188 | } |
189 | '... bar is a read-write accessor with a type constraint'; |
190 | |
191 | my $foo2 = FooClass->new(); |
192 | isa_ok( $foo2, 'FooClass' ); |
193 | |
194 | lives_ok { |
195 | $foo->bar($foo2); |
196 | } |
197 | '... bar is a read-write accessor with a type constraint'; |
198 | |
199 | is( $foo->bar, $foo2, '... got the right value for bar now' ); |
200 | } |