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