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