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