Commit | Line | Data |
6cfa1e5e |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; |
4 | use warnings; |
ad022aac |
5 | use Test::More; |
6 | BEGIN{ |
7056deca |
7 | if(eval{ require Class::Method::Modifiers::Fast } || eval{ require Class::Method::Modifiers }){ |
ad022aac |
8 | plan tests => 74; |
9 | } |
10 | else{ |
11 | plan skip_all => 'This test requires Class::Method::Modifiers(::Fast)?'; |
12 | } |
13 | } |
6cfa1e5e |
14 | |
6cfa1e5e |
15 | use Test::Exception; |
16 | |
17 | |
18 | |
19 | { |
20 | # NOTE: |
21 | # this tests that repeated role |
22 | # composition will not cause |
23 | # a conflict between two methods |
24 | # which are actually the same anyway |
25 | |
26 | { |
27 | package RootA; |
28 | use Mouse::Role; |
29 | |
30 | sub foo { "RootA::foo" } |
31 | |
32 | package SubAA; |
33 | use Mouse::Role; |
34 | |
35 | with "RootA"; |
36 | |
37 | sub bar { "SubAA::bar" } |
38 | |
39 | package SubAB; |
40 | use Mouse; |
41 | |
42 | ::lives_ok { |
43 | with "SubAA", "RootA"; |
44 | } '... role was composed as expected'; |
45 | } |
46 | |
47 | ok( SubAB->does("SubAA"), "does SubAA"); |
48 | ok( SubAB->does("RootA"), "does RootA"); |
49 | |
50 | isa_ok( my $i = SubAB->new, "SubAB" ); |
51 | |
52 | can_ok( $i, "bar" ); |
53 | is( $i->bar, "SubAA::bar", "... got thr right bar rv" ); |
54 | |
55 | can_ok( $i, "foo" ); |
56 | my $foo_rv; |
57 | lives_ok { |
58 | $foo_rv = $i->foo; |
59 | } '... called foo successfully'; |
60 | is($foo_rv, "RootA::foo", "... got the right foo rv"); |
61 | } |
62 | |
63 | { |
64 | # NOTE: |
65 | # this edge cases shows the application of |
66 | # an after modifier over a method which |
67 | # was added during role composotion. |
68 | # The way this will work is as follows: |
69 | # role SubBA will consume RootB and |
70 | # get a local copy of RootB::foo, it |
71 | # will also store a deferred after modifier |
72 | # to be applied to whatever class SubBA is |
73 | # composed into. |
74 | # When class SubBB comsumed role SubBA, the |
75 | # RootB::foo method is added to SubBB, then |
76 | # the deferred after modifier from SubBA is |
77 | # applied to it. |
78 | # It is important to note that the application |
79 | # of the after modifier does not happen until |
80 | # role SubBA is composed into SubAA. |
81 | |
82 | { |
83 | package RootB; |
84 | use Mouse::Role; |
85 | |
86 | sub foo { "RootB::foo" } |
87 | |
88 | package SubBA; |
89 | use Mouse::Role; |
90 | |
91 | with "RootB"; |
92 | |
93 | has counter => ( |
94 | isa => "Num", |
95 | is => "rw", |
96 | default => 0, |
97 | ); |
98 | |
99 | after foo => sub { |
100 | $_[0]->counter( $_[0]->counter + 1 ); |
101 | }; |
102 | |
103 | package SubBB; |
104 | use Mouse; |
105 | |
106 | ::lives_ok { |
107 | with "SubBA"; |
108 | } '... composed the role successfully'; |
109 | } |
110 | |
111 | ok( SubBB->does("SubBA"), "BB does SubBA" ); |
112 | ok( SubBB->does("RootB"), "BB does RootB" ); |
113 | |
114 | isa_ok( my $i = SubBB->new, "SubBB" ); |
115 | |
116 | can_ok( $i, "foo" ); |
117 | |
118 | my $foo_rv; |
119 | lives_ok { |
120 | $foo_rv = $i->foo |
121 | } '... called foo successfully'; |
122 | is( $foo_rv, "RootB::foo", "foo rv" ); |
123 | is( $i->counter, 1, "after hook called" ); |
124 | |
125 | lives_ok { $i->foo } '... called foo successfully (again)'; |
126 | is( $i->counter, 2, "after hook called (again)" ); |
127 | |
128 | ok(SubBA->meta->has_method('foo'), '... this has the foo method'); |
129 | #my $subba_foo_rv; |
130 | #lives_ok { |
131 | # $subba_foo_rv = SubBA::foo(); |
132 | #} '... called the sub as a function correctly'; |
133 | #is($subba_foo_rv, 'RootB::foo', '... the SubBA->foo is still the RootB version'); |
134 | } |
135 | |
136 | { |
137 | # NOTE: |
138 | # this checks that an override method |
139 | # does not try to trample over a locally |
140 | # composed in method. In this case the |
141 | # RootC::foo, which is composed into |
142 | # SubCA cannot be trampled with an |
143 | # override of 'foo' |
144 | { |
145 | package RootC; |
146 | use Mouse::Role; |
147 | |
148 | sub foo { "RootC::foo" } |
149 | |
150 | package SubCA; |
151 | use Mouse::Role; |
152 | |
153 | with "RootC"; |
154 | |
155 | ::dies_ok { |
156 | override foo => sub { "overridden" }; |
157 | } '... cannot compose an override over a local method'; |
158 | } |
159 | } |
160 | |
161 | # NOTE: |
162 | # need to talk to Yuval about the motivation behind |
163 | # this test, I am not sure we are testing anything |
164 | # useful here (although more tests cant hurt) |
165 | |
166 | { |
167 | use List::Util qw/shuffle/; |
168 | |
169 | { |
170 | package Abstract; |
171 | use Mouse::Role; |
172 | |
173 | requires "method"; |
174 | requires "other"; |
175 | |
176 | sub another { "abstract" } |
177 | |
178 | package ConcreteA; |
179 | use Mouse::Role; |
180 | with "Abstract"; |
181 | |
182 | sub other { "concrete a" } |
183 | |
184 | package ConcreteB; |
185 | use Mouse::Role; |
186 | with "Abstract"; |
187 | |
188 | sub method { "concrete b" } |
189 | |
190 | package ConcreteC; |
191 | use Mouse::Role; |
192 | with "ConcreteA"; |
193 | |
194 | # NOTE: |
195 | # this was originally override, but |
196 | # that wont work (see above set of tests) |
197 | # so I switched it to around. |
198 | # However, this may not be testing the |
199 | # same thing that was originally intended |
200 | around other => sub { |
201 | return ( (shift)->() . " + c" ); |
202 | }; |
203 | |
204 | package SimpleClassWithSome; |
205 | use Mouse; |
206 | |
207 | eval { with ::shuffle qw/ConcreteA ConcreteB/ }; |
208 | ::ok( !$@, "simple composition without abstract" ) || ::diag $@; |
209 | |
210 | package SimpleClassWithAll; |
211 | use Mouse; |
212 | |
213 | eval { with ::shuffle qw/ConcreteA ConcreteB Abstract/ }; |
214 | ::ok( !$@, "simple composition with abstract" ) || ::diag $@; |
215 | } |
216 | |
217 | foreach my $class (qw/SimpleClassWithSome SimpleClassWithAll/) { |
218 | foreach my $role (qw/Abstract ConcreteA ConcreteB/) { |
219 | ok( $class->does($role), "$class does $role"); |
220 | } |
221 | |
222 | foreach my $method (qw/method other another/) { |
223 | can_ok( $class, $method ); |
224 | } |
225 | |
226 | is( eval { $class->another }, "abstract", "provided by abstract" ); |
227 | is( eval { $class->other }, "concrete a", "provided by concrete a" ); |
228 | is( eval { $class->method }, "concrete b", "provided by concrete b" ); |
229 | } |
230 | |
231 | { |
232 | package ClassWithSome; |
233 | use Mouse; |
234 | |
235 | eval { with ::shuffle qw/ConcreteC ConcreteB/ }; |
236 | ::ok( !$@, "composition without abstract" ) || ::diag $@; |
237 | |
238 | package ClassWithAll; |
239 | use Mouse; |
240 | |
241 | eval { with ::shuffle qw/ConcreteC Abstract ConcreteB/ }; |
242 | ::ok( !$@, "composition with abstract" ) || ::diag $@; |
243 | |
244 | package ClassWithEverything; |
245 | use Mouse; |
246 | |
247 | eval { with ::shuffle qw/ConcreteC Abstract ConcreteA ConcreteB/ }; # this should clash |
248 | ::ok( !$@, "can compose ConcreteA and ConcreteC together" ); |
249 | } |
250 | |
251 | foreach my $class (qw/ClassWithSome ClassWithAll ClassWithEverything/) { |
252 | foreach my $role (qw/Abstract ConcreteA ConcreteB ConcreteC/) { |
253 | ok( $class->does($role), "$class does $role"); |
254 | } |
255 | |
256 | foreach my $method (qw/method other another/) { |
257 | can_ok( $class, $method ); |
258 | } |
259 | |
260 | is( eval { $class->another }, "abstract", "provided by abstract" ); |
261 | is( eval { $class->other }, "concrete a + c", "provided by concrete c + a" ); |
262 | is( eval { $class->method }, "concrete b", "provided by concrete b" ); |
263 | } |
264 | } |