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