Commit | Line | Data |
92768c49 |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
a28e50e4 |
6 | use Test::More; |
b10dde3a |
7 | use Test::Fatal; |
e39d707f |
8 | |
7ff56534 |
9 | |
92768c49 |
10 | { |
e39d707f |
11 | # NOTE: |
d03bd989 |
12 | # this tests that repeated role |
13 | # composition will not cause |
e39d707f |
14 | # a conflict between two methods |
15 | # which are actually the same anyway |
d03bd989 |
16 | |
92768c49 |
17 | { |
18 | package RootA; |
19 | use Moose::Role; |
20 | |
e39d707f |
21 | sub foo { "RootA::foo" } |
92768c49 |
22 | |
23 | package SubAA; |
24 | use Moose::Role; |
25 | |
26 | with "RootA"; |
27 | |
e39d707f |
28 | sub bar { "SubAA::bar" } |
92768c49 |
29 | |
30 | package SubAB; |
31 | use Moose; |
32 | |
b10dde3a |
33 | ::is( ::exception { |
d03bd989 |
34 | with "SubAA", "RootA"; |
b10dde3a |
35 | }, undef, '... role was composed as expected' ); |
92768c49 |
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" ); |
e39d707f |
44 | is( $i->bar, "SubAA::bar", "... got thr right bar rv" ); |
92768c49 |
45 | |
46 | can_ok( $i, "foo" ); |
e39d707f |
47 | my $foo_rv; |
b10dde3a |
48 | is( exception { |
d03bd989 |
49 | $foo_rv = $i->foo; |
b10dde3a |
50 | }, undef, '... called foo successfully' ); |
e39d707f |
51 | is($foo_rv, "RootA::foo", "... got the right foo rv"); |
92768c49 |
52 | } |
53 | |
0558683c |
54 | { |
55 | # NOTE: |
d03bd989 |
56 | # this edge cases shows the application of |
57 | # an after modifier over a method which |
0558683c |
58 | # was added during role composotion. |
59 | # The way this will work is as follows: |
d03bd989 |
60 | # role SubBA will consume RootB and |
61 | # get a local copy of RootB::foo, it |
0558683c |
62 | # will also store a deferred after modifier |
d03bd989 |
63 | # to be applied to whatever class SubBA is |
0558683c |
64 | # composed into. |
65 | # When class SubBB comsumed role SubBA, the |
d03bd989 |
66 | # RootB::foo method is added to SubBB, then |
67 | # the deferred after modifier from SubBA is |
0558683c |
68 | # applied to it. |
d03bd989 |
69 | # It is important to note that the application |
70 | # of the after modifier does not happen until |
0558683c |
71 | # role SubBA is composed into SubAA. |
d03bd989 |
72 | |
0558683c |
73 | { |
74 | package RootB; |
75 | use Moose::Role; |
76 | |
77 | sub foo { "RootB::foo" } |
78 | |
79 | package SubBA; |
80 | use Moose::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 Moose; |
96 | |
b10dde3a |
97 | ::is( ::exception { |
0558683c |
98 | with "SubBA"; |
b10dde3a |
99 | }, undef, '... composed the role successfully' ); |
0558683c |
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" ); |
d03bd989 |
108 | |
0558683c |
109 | my $foo_rv; |
b10dde3a |
110 | is( exception { |
d03bd989 |
111 | $foo_rv = $i->foo |
b10dde3a |
112 | }, undef, '... called foo successfully' ); |
0558683c |
113 | is( $foo_rv, "RootB::foo", "foo rv" ); |
114 | is( $i->counter, 1, "after hook called" ); |
d03bd989 |
115 | |
b10dde3a |
116 | is( exception { $i->foo }, undef, '... called foo successfully (again)' ); |
0558683c |
117 | is( $i->counter, 2, "after hook called (again)" ); |
d03bd989 |
118 | |
fb1e11d5 |
119 | ok(SubBA->meta->has_method('foo'), '... this has the foo method'); |
120 | #my $subba_foo_rv; |
53a4d826 |
121 | #lives_ok { |
d03bd989 |
122 | # $subba_foo_rv = SubBA::foo(); |
53a4d826 |
123 | #} '... called the sub as a function correctly'; |
fb1e11d5 |
124 | #is($subba_foo_rv, 'RootB::foo', '... the SubBA->foo is still the RootB version'); |
0558683c |
125 | } |
126 | |
127 | { |
128 | # NOTE: |
129 | # this checks that an override method |
130 | # does not try to trample over a locally |
d03bd989 |
131 | # composed in method. In this case the |
132 | # RootC::foo, which is composed into |
133 | # SubCA cannot be trampled with an |
0558683c |
134 | # override of 'foo' |
135 | { |
136 | package RootC; |
137 | use Moose::Role; |
138 | |
139 | sub foo { "RootC::foo" } |
140 | |
141 | package SubCA; |
142 | use Moose::Role; |
143 | |
144 | with "RootC"; |
145 | |
b10dde3a |
146 | ::isnt( ::exception { |
0558683c |
147 | override foo => sub { "overridden" }; |
b10dde3a |
148 | }, undef, '... cannot compose an override over a local method' ); |
0558683c |
149 | } |
150 | } |
151 | |
152 | # NOTE: |
d03bd989 |
153 | # need to talk to Yuval about the motivation behind |
154 | # this test, I am not sure we are testing anything |
0558683c |
155 | # useful here (although more tests cant hurt) |
156 | |
157 | { |
158 | use List::Util qw/shuffle/; |
159 | |
160 | { |
161 | package Abstract; |
162 | use Moose::Role; |
163 | |
164 | requires "method"; |
165 | requires "other"; |
166 | |
167 | sub another { "abstract" } |
168 | |
169 | package ConcreteA; |
170 | use Moose::Role; |
171 | with "Abstract"; |
172 | |
173 | sub other { "concrete a" } |
174 | |
175 | package ConcreteB; |
176 | use Moose::Role; |
177 | with "Abstract"; |
178 | |
179 | sub method { "concrete b" } |
180 | |
181 | package ConcreteC; |
182 | use Moose::Role; |
183 | with "ConcreteA"; |
184 | |
185 | # NOTE: |
d03bd989 |
186 | # this was originally override, but |
0558683c |
187 | # that wont work (see above set of tests) |
188 | # so I switched it to around. |
d03bd989 |
189 | # However, this may not be testing the |
0558683c |
190 | # same thing that was originally intended |
191 | around other => sub { |
192 | return ( (shift)->() . " + c" ); |
193 | }; |
194 | |
195 | package SimpleClassWithSome; |
196 | use Moose; |
197 | |
198 | eval { with ::shuffle qw/ConcreteA ConcreteB/ }; |
199 | ::ok( !$@, "simple composition without abstract" ) || ::diag $@; |
200 | |
201 | package SimpleClassWithAll; |
202 | use Moose; |
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" ); |
d03bd989 |
220 | } |
0558683c |
221 | |
222 | { |
223 | package ClassWithSome; |
224 | use Moose; |
d03bd989 |
225 | |
0558683c |
226 | eval { with ::shuffle qw/ConcreteC ConcreteB/ }; |
227 | ::ok( !$@, "composition without abstract" ) || ::diag $@; |
228 | |
229 | package ClassWithAll; |
230 | use Moose; |
231 | |
232 | eval { with ::shuffle qw/ConcreteC Abstract ConcreteB/ }; |
233 | ::ok( !$@, "composition with abstract" ) || ::diag $@; |
234 | |
235 | package ClassWithEverything; |
236 | use Moose; |
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 | } |
a28e50e4 |
256 | |
257 | done_testing; |