Commit | Line | Data |
bbc9f1c6 |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
6 | use Test::More 'no_plan'; |
7 | use Test::Exception; |
8 | |
9 | sub req_or_has ($$) { |
10 | my ( $role, $method ) = @_; |
11 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
12 | if ( $role ) { |
68b6146c |
13 | ok( |
14 | $role->has_method($method) || $role->requires_method($method), |
15 | $role->name . " has or requires method $method" |
16 | ); |
bbc9f1c6 |
17 | } else { |
18 | fail("role has or requires method $method"); |
19 | } |
20 | } |
21 | |
1344fd47 |
22 | { |
23 | package Bar; |
24 | use Moose::Role; |
bbc9f1c6 |
25 | |
26 | # this role eventually adds three methods, qw(foo bar xxy), but only one is |
27 | # known when it's still a role |
28 | |
1344fd47 |
29 | has foo => ( is => "rw" ); |
bbc9f1c6 |
30 | |
31 | has gorch => ( reader => "bar" ); |
32 | |
33 | sub xxy { "BAAAD" } |
34 | |
35 | package Gorch; |
36 | use Moose::Role; |
37 | |
38 | # similarly this role gives attr and gorch_method |
39 | |
40 | has attr => ( is => "rw" ); |
41 | |
42 | sub gorch_method { "gorch method" } |
43 | |
44 | around dandy => sub { shift->(@_) . "bar" }; |
45 | |
46 | package Quxx; |
47 | use Moose; |
48 | |
49 | sub dandy { "foo" } |
50 | |
51 | # this object will be used in an attr of Foo to test that Foo can do the |
52 | # Gorch interface |
53 | |
54 | with qw(Gorch); |
55 | |
56 | package Dancer; |
57 | use Moose::Role; |
58 | |
59 | requires "twist"; |
60 | |
61 | package Dancer::Ballerina; |
62 | use Moose; |
63 | |
64 | with qw(Dancer); |
65 | |
66 | sub twist { } |
67 | |
68 | sub pirouette { } |
69 | |
70 | package Dancer::Robot; |
71 | use Moose::Role; |
72 | |
73 | # this doesn't fail but it produces a requires in the role |
74 | # the order doesn't matter |
75 | has twist => ( is => "rw" ); |
76 | ::lives_ok { with qw(Dancer) }; |
77 | |
78 | package Dancer::Something; |
79 | use Moose; |
80 | |
81 | # this fail even though the method already exists |
82 | |
83 | has twist => ( is => "rw" ); |
84 | |
85 | { |
86 | local our $TODO = "accessors don't satisfy role requires"; |
87 | ::lives_ok { with qw(Dancer) }; |
88 | } |
89 | |
90 | package Dancer::80s; |
91 | use Moose; |
92 | |
93 | # this should pass because ::Robot has the attribute to fill in the requires |
94 | # but due to the deferrence logic that doesn't actually work |
95 | { |
96 | local our $TODO = "attribute accessor in role doesn't satisfy role requires"; |
97 | ::lives_ok { with qw(Dancer::Robot) }; |
98 | } |
99 | |
1344fd47 |
100 | package Foo; |
101 | use Moose; |
bbc9f1c6 |
102 | |
1344fd47 |
103 | with qw(Bar); |
bbc9f1c6 |
104 | |
105 | has oink => ( |
106 | is => "rw", |
107 | handles => "Gorch", # should handles take the same arguments as 'with'? Meta::Role::Application::Delegation? |
108 | default => sub { Quxx->new }, |
109 | ); |
110 | |
111 | has dancer => ( |
112 | is => "rw", |
113 | does => "Dancer", |
114 | handles => "Dancer", |
115 | default => sub { Dancer::Ballerina->new }, |
116 | ); |
117 | |
1344fd47 |
118 | sub foo { 42 } |
bbc9f1c6 |
119 | |
120 | sub bar { 33 } |
121 | |
122 | sub xxy { 7 } |
e953aaf5 |
123 | |
124 | package Tree; |
125 | use Moose::Role; |
126 | |
127 | has bark => ( is => "rw" ); |
128 | |
129 | package Dog; |
130 | use Moose::Role; |
131 | |
132 | sub bark { warn "woof!" }; |
133 | |
134 | package EntPuppy; |
135 | use Moose; |
136 | |
137 | { |
138 | local our $TODO = "attrs and methods from a role should clash"; |
139 | ::dies_ok { with qw(Tree Dog) } |
140 | } |
bbc9f1c6 |
141 | } |
142 | |
143 | # these fail because of the deferral logic winning over actual methods |
144 | # this might be tricky to fix due to the 'sub foo {}; has foo => ( )' hack |
145 | # we've been doing for a long while, though I doubt people relied on it for |
146 | # anything other than fulfilling 'requires' |
147 | { |
148 | local $TODO = "attributes from role overwrite class methods"; |
149 | is( Foo->new->foo, 42, "attr did not zap overriding method" ); |
150 | is( Foo->new->bar, 33, "attr did not zap overriding method" ); |
151 | } |
152 | is( Foo->new->xxy, 7, "method did not zap overriding method" ); # duh |
153 | |
154 | # these pass, simple delegate |
155 | # mostly they are here to contrast the next blck |
156 | can_ok( Foo->new->oink, "dandy" ); |
157 | can_ok( Foo->new->oink, "attr" ); |
158 | can_ok( Foo->new->oink, "gorch_method" ); |
159 | |
160 | ok( Foo->new->oink->does("Gorch"), "Quxx does Gorch" ); |
161 | |
162 | |
163 | # these are broken because 'attr' is not technically part of the interface |
164 | can_ok( Foo->new, "gorch_method" ); |
165 | { |
166 | local $TODO = "accessor methods from a role are omitted in handles role"; |
167 | can_ok( Foo->new, "attr" ); |
168 | } |
169 | |
170 | { |
171 | local $TODO = "handles role doesn't add the role to the ->does of the delegate's parent class"; |
172 | ok( Foo->new->does("Gorch"), "Foo does Gorch" ); |
173 | } |
174 | |
175 | |
176 | # these work |
177 | can_ok( Foo->new->dancer, "pirouette" ); |
178 | can_ok( Foo->new->dancer, "twist" ); |
179 | |
180 | can_ok( Foo->new, "twist" ); |
181 | ok( !Foo->new->can("pirouette"), "can't pirouette, not part of the iface" ); |
182 | |
183 | { |
184 | local $TODO = "handles role doesn't add the role to the ->does of the delegate's parent class"; |
185 | ok( Foo->new->does("Dancer") ); |
186 | } |
187 | |
188 | |
189 | |
190 | |
191 | my $gorch = Gorch->meta; |
192 | |
193 | isa_ok( $gorch, "Moose::Meta::Role" ); |
194 | |
195 | ok( $gorch->has_attribute("attr"), "has attribute 'attr'" ); |
196 | |
197 | { |
198 | local $TODO = "role attribute isn't a meta attribute yet"; |
199 | isa_ok( $gorch->get_attribute("attr"), "Moose::Meta::Attribute" ); |
200 | } |
201 | |
202 | req_or_has($gorch, "gorch_method"); |
203 | ok( $gorch->has_method("gorch_method"), "has_method gorch_method" ); |
204 | ok( !$gorch->requires_method("gorch_method"), "requires gorch method" ); |
205 | |
206 | { |
207 | local $TODO = "role method isn't a meta object yet"; |
208 | isa_ok( $gorch->get_method("gorch_method"), "Moose::Meta::Method" ); |
209 | } |
210 | |
211 | { |
212 | local $TODO = "method modifier doesn't yet create a method requirement or meta object"; |
213 | req_or_has($gorch, "dandy" ); |
214 | |
215 | # this specific test is maybe not backwards compat, but in theory it *does* |
216 | # require that method to exist |
217 | ok( $gorch->requires_method("dandy"), "requires the dandy method for the modifier" ); |
218 | } |
219 | |
220 | { |
221 | local $TODO = "attribute related methods are not yet known by the role"; |
222 | # we want this to be a part of the interface, somehow |
223 | req_or_has($gorch, "attr"); |
224 | ok( $gorch->has_method("attr"), "has_method attr" ); |
225 | isa_ok( $gorch->get_method("attr"), "Moose::Meta::Method" ); |
226 | isa_ok( $gorch->get_method("attr"), "Moose::Meta::Method::Accessor" ); |
227 | } |
228 | |
229 | my $robot = Dancer::Robot->meta; |
230 | |
231 | isa_ok( $robot, "Moose::Meta::Role" ); |
232 | |
233 | ok( $robot->has_attribute("twist"), "has attr 'twist'" ); |
234 | |
235 | { |
236 | local $TODO = "role attribute isn't a meta attribute yet"; |
237 | isa_ok( $robot->get_attribute("twist"), "Moose::Meta::Attribute" ); |
238 | } |
239 | |
240 | { |
bbc9f1c6 |
241 | req_or_has($robot, "twist"); |
a632beb5 |
242 | |
243 | local $TODO = "attribute related methods are not yet known by the role"; |
bbc9f1c6 |
244 | ok( $robot->has_method("twist"), "has twist method" ); |
245 | isa_ok( $robot->get_method("twist"), "Moose::Meta::Method" ); |
246 | isa_ok( $robot->get_method("twist"), "Moose::Meta::Method::Accessor" ); |
247 | } |
248 | |
249 | __END__ |
250 | |
251 | I think Attribute needs to be refactored in some way to better support roles. |
252 | |
253 | There are several possible ways to do this, all of them seem plausible to me. |
254 | |
255 | The first approach would be to change the attribute class to allow it to be |
256 | queried about the methods it would install. |
257 | |
258 | Then we instantiate the attribute in the role, and instead of deferring the |
259 | arguments, we just make an C<unpack>ish method. |
260 | |
261 | Then we can interrogate the attr when adding it to the role, and generate stub |
262 | methods for all the methods it would produce. |
263 | |
264 | A second approach is kinda like the Immutable hack: wrap the attr in an |
265 | anonmyous class that disables part of its interface. |
266 | |
267 | A third method would be to create an Attribute::Partial object that would |
268 | provide a more role-ish behavior, and to do this independently of the actual |
269 | Attribute class. |
270 | |
271 | Something similar can be done for method modifiers, but I think that's even simpler. |
272 | |
273 | |
274 | |
275 | The benefits of doing this are: |
276 | |
277 | * Much better introspection of roles |
278 | |
279 | * More correctness in many cases (in my opinion anyway) |
280 | |
281 | * More roles are more usable as interface declarations, without having to split |
282 | them into two pieces (one for the interface with a bunch of requires(), and |
283 | another for the actual impl with the problematic attrs (and stub methods to |
284 | fix the accessors) and method modifiers (dunno if this can even work at all) |
285 | |
286 | |