Commit | Line | Data |
e185c027 |
1 | |
2 | package Moose::Meta::Role; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | use metaclass; |
7 | |
bdabd620 |
8 | use Carp 'confess'; |
9 | use Scalar::Util 'blessed'; |
d30bc041 |
10 | use B 'svref_2object'; |
bdabd620 |
11 | |
12 | use Moose::Meta::Class; |
e185c027 |
13 | |
e39d707f |
14 | our $VERSION = '0.04'; |
e185c027 |
15 | |
bdabd620 |
16 | ## Attributes |
17 | |
80572233 |
18 | ## the meta for the role package |
19 | |
bdabd620 |
20 | __PACKAGE__->meta->add_attribute('_role_meta' => ( |
21 | reader => '_role_meta', |
22 | init_arg => ':role_meta' |
80572233 |
23 | )); |
24 | |
25 | ## roles |
26 | |
27 | __PACKAGE__->meta->add_attribute('roles' => ( |
28 | reader => 'get_roles', |
29 | default => sub { [] } |
e185c027 |
30 | )); |
31 | |
d79e62fd |
32 | ## excluded roles |
33 | |
34 | __PACKAGE__->meta->add_attribute('excluded_roles_map' => ( |
35 | reader => 'get_excluded_roles_map', |
36 | default => sub { {} } |
37 | )); |
38 | |
80572233 |
39 | ## attributes |
40 | |
e185c027 |
41 | __PACKAGE__->meta->add_attribute('attribute_map' => ( |
42 | reader => 'get_attribute_map', |
43 | default => sub { {} } |
44 | )); |
45 | |
1331430a |
46 | ## required methods |
47 | |
48 | __PACKAGE__->meta->add_attribute('required_methods' => ( |
49 | reader => 'get_required_methods_map', |
50 | default => sub { {} } |
51 | )); |
52 | |
bdabd620 |
53 | ## Methods |
80572233 |
54 | |
e185c027 |
55 | sub new { |
56 | my $class = shift; |
57 | my %options = @_; |
bdabd620 |
58 | $options{':role_meta'} = Moose::Meta::Class->initialize( |
a7d0cd00 |
59 | $options{role_name}, |
60 | ':method_metaclass' => 'Moose::Meta::Role::Method' |
db1ab48d |
61 | ) unless defined $options{':role_meta'} && |
62 | $options{':role_meta'}->isa('Moose::Meta::Class'); |
e185c027 |
63 | my $self = $class->meta->new_object(%options); |
64 | return $self; |
65 | } |
66 | |
80572233 |
67 | ## subroles |
68 | |
69 | sub add_role { |
70 | my ($self, $role) = @_; |
71 | (blessed($role) && $role->isa('Moose::Meta::Role')) |
72 | || confess "Roles must be instances of Moose::Meta::Role"; |
73 | push @{$self->get_roles} => $role; |
74 | } |
75 | |
b8aeb4dc |
76 | sub calculate_all_roles { |
77 | my $self = shift; |
78 | my %seen; |
79 | grep { !$seen{$_->name}++ } $self, map { $_->calculate_all_roles } @{ $self->get_roles }; |
80 | } |
81 | |
80572233 |
82 | sub does_role { |
83 | my ($self, $role_name) = @_; |
84 | (defined $role_name) |
85 | || confess "You must supply a role name to look for"; |
bdabd620 |
86 | # if we are it,.. then return true |
87 | return 1 if $role_name eq $self->name; |
88 | # otherwise.. check our children |
80572233 |
89 | foreach my $role (@{$self->get_roles}) { |
bdabd620 |
90 | return 1 if $role->does_role($role_name); |
80572233 |
91 | } |
92 | return 0; |
93 | } |
94 | |
d79e62fd |
95 | ## excluded roles |
96 | |
97 | sub add_excluded_roles { |
98 | my ($self, @excluded_role_names) = @_; |
99 | $self->get_excluded_roles_map->{$_} = undef foreach @excluded_role_names; |
100 | } |
101 | |
102 | sub get_excluded_roles_list { |
103 | my ($self) = @_; |
104 | keys %{$self->get_excluded_roles_map}; |
105 | } |
106 | |
107 | sub excludes_role { |
108 | my ($self, $role_name) = @_; |
109 | exists $self->get_excluded_roles_map->{$role_name} ? 1 : 0; |
110 | } |
111 | |
1331430a |
112 | ## required methods |
113 | |
114 | sub add_required_methods { |
115 | my ($self, @methods) = @_; |
116 | $self->get_required_methods_map->{$_} = undef foreach @methods; |
117 | } |
118 | |
38f1204c |
119 | sub remove_required_methods { |
120 | my ($self, @methods) = @_; |
121 | delete $self->get_required_methods_map->{$_} foreach @methods; |
122 | } |
123 | |
1331430a |
124 | sub get_required_method_list { |
125 | my ($self) = @_; |
126 | keys %{$self->get_required_methods_map}; |
127 | } |
128 | |
129 | sub requires_method { |
130 | my ($self, $method_name) = @_; |
131 | exists $self->get_required_methods_map->{$method_name} ? 1 : 0; |
132 | } |
133 | |
db1ab48d |
134 | sub _clean_up_required_methods { |
135 | my $self = shift; |
136 | foreach my $method ($self->get_required_method_list) { |
38f1204c |
137 | $self->remove_required_methods($method) |
db1ab48d |
138 | if $self->has_method($method); |
139 | } |
140 | } |
141 | |
80572233 |
142 | ## methods |
143 | |
e185c027 |
144 | # NOTE: |
145 | # we delegate to some role_meta methods for convience here |
146 | # the Moose::Meta::Role is meant to be a read-only interface |
147 | # to the underlying role package, if you want to manipulate |
148 | # that, just use ->role_meta |
149 | |
bdabd620 |
150 | sub name { (shift)->_role_meta->name } |
151 | sub version { (shift)->_role_meta->version } |
e185c027 |
152 | |
be4427d0 |
153 | sub get_method { (shift)->_role_meta->get_method(@_) } |
154 | sub find_method_by_name { (shift)->_role_meta->find_method_by_name(@_) } |
155 | sub has_method { (shift)->_role_meta->has_method(@_) } |
156 | sub alias_method { (shift)->_role_meta->alias_method(@_) } |
e185c027 |
157 | sub get_method_list { |
158 | my ($self) = @_; |
bdabd620 |
159 | grep { |
160 | # NOTE: |
161 | # this is a kludge for now,... these functions |
162 | # should not be showing up in the list at all, |
163 | # but they do, so we need to switch Moose::Role |
164 | # and Moose to use Sub::Exporter to prevent this |
1331430a |
165 | !/^(meta|has|extends|blessed|confess|augment|inner|override|super|before|after|around|with|requires)$/ |
bdabd620 |
166 | } $self->_role_meta->get_method_list; |
e185c027 |
167 | } |
168 | |
169 | # ... however the items in statis (attributes & method modifiers) |
170 | # can be removed and added to through this API |
171 | |
172 | # attributes |
173 | |
174 | sub add_attribute { |
a2eec5e7 |
175 | my $self = shift; |
176 | my $name = shift; |
177 | my $attr_desc; |
178 | if (scalar @_ == 1 && ref($_[0]) eq 'HASH') { |
179 | $attr_desc = $_[0]; |
180 | } |
181 | else { |
182 | $attr_desc = { @_ }; |
183 | } |
184 | $self->get_attribute_map->{$name} = $attr_desc; |
e185c027 |
185 | } |
186 | |
187 | sub has_attribute { |
188 | my ($self, $name) = @_; |
189 | exists $self->get_attribute_map->{$name} ? 1 : 0; |
190 | } |
191 | |
192 | sub get_attribute { |
193 | my ($self, $name) = @_; |
194 | $self->get_attribute_map->{$name} |
195 | } |
196 | |
197 | sub remove_attribute { |
198 | my ($self, $name) = @_; |
199 | delete $self->get_attribute_map->{$name} |
200 | } |
201 | |
202 | sub get_attribute_list { |
203 | my ($self) = @_; |
204 | keys %{$self->get_attribute_map}; |
205 | } |
206 | |
e185c027 |
207 | |
bdabd620 |
208 | ## applying a role to a class ... |
209 | |
a2eec5e7 |
210 | sub _check_excluded_roles { |
bdabd620 |
211 | my ($self, $other) = @_; |
d79e62fd |
212 | if ($other->excludes_role($self->name)) { |
213 | confess "Conflict detected: " . $other->name . " excludes role '" . $self->name . "'"; |
214 | } |
d79e62fd |
215 | foreach my $excluded_role_name ($self->get_excluded_roles_list) { |
9c429218 |
216 | if ($other->does_role($excluded_role_name)) { |
d79e62fd |
217 | confess "The class " . $other->name . " does the excluded role '$excluded_role_name'"; |
218 | } |
219 | else { |
220 | if ($other->isa('Moose::Meta::Role')) { |
d79e62fd |
221 | $other->add_excluded_roles($excluded_role_name); |
222 | } |
a2eec5e7 |
223 | # else -> ignore it :) |
d79e62fd |
224 | } |
225 | } |
a2eec5e7 |
226 | } |
227 | |
228 | sub _check_required_methods { |
229 | my ($self, $other) = @_; |
1331430a |
230 | # NOTE: |
231 | # we might need to move this down below the |
232 | # the attributes so that we can require any |
233 | # attribute accessors. However I am thinking |
234 | # that maybe those are somehow exempt from |
235 | # the require methods stuff. |
236 | foreach my $required_method_name ($self->get_required_method_list) { |
8c835eba |
237 | |
be4427d0 |
238 | unless ($other->find_method_by_name($required_method_name)) { |
fa1be058 |
239 | if ($other->isa('Moose::Meta::Role')) { |
240 | $other->add_required_methods($required_method_name); |
241 | } |
242 | else { |
243 | confess "'" . $self->name . "' requires the method '$required_method_name' " . |
244 | "to be implemented by '" . $other->name . "'"; |
245 | } |
246 | } |
a2eec5e7 |
247 | } |
248 | } |
249 | |
250 | sub _apply_attributes { |
251 | my ($self, $other) = @_; |
bdabd620 |
252 | foreach my $attribute_name ($self->get_attribute_list) { |
db1ab48d |
253 | # it if it has one already |
a2eec5e7 |
254 | if ($other->has_attribute($attribute_name) && |
255 | # make sure we haven't seen this one already too |
256 | $other->get_attribute($attribute_name) != $self->get_attribute($attribute_name)) { |
db1ab48d |
257 | # see if we are being composed |
258 | # into a role or not |
a2eec5e7 |
259 | if ($other->isa('Moose::Meta::Role')) { |
db1ab48d |
260 | # all attribute conflicts between roles |
261 | # result in an immediate fatal error |
262 | confess "Role '" . $self->name . "' has encountered an attribute conflict " . |
263 | "during composition. This is fatal error and cannot be disambiguated."; |
264 | } |
265 | else { |
266 | # but if this is a class, we |
267 | # can safely skip adding the |
268 | # attribute to the class |
269 | next; |
270 | } |
271 | } |
272 | else { |
db1ab48d |
273 | $other->add_attribute( |
274 | $attribute_name, |
a2eec5e7 |
275 | $self->get_attribute($attribute_name) |
db1ab48d |
276 | ); |
277 | } |
a2eec5e7 |
278 | } |
279 | } |
280 | |
281 | sub _apply_methods { |
282 | my ($self, $other) = @_; |
bdabd620 |
283 | foreach my $method_name ($self->get_method_list) { |
db1ab48d |
284 | # it if it has one already |
d30bc041 |
285 | if ($other->has_method($method_name) && |
286 | # and if they are not the same thing ... |
287 | $other->get_method($method_name) != $self->get_method($method_name)) { |
db1ab48d |
288 | # see if we are composing into a role |
289 | if ($other->isa('Moose::Meta::Role')) { |
290 | # method conflicts between roles result |
291 | # in the method becoming a requirement |
292 | $other->add_required_methods($method_name); |
293 | # NOTE: |
294 | # we have to remove the method from our |
295 | # role, if this is being called from combine() |
296 | # which means the meta is an anon class |
297 | # this *may* cause problems later, but it |
298 | # is probably fairly safe to assume that |
299 | # anon classes will only be used internally |
300 | # or by people who know what they are doing |
301 | $other->_role_meta->remove_method($method_name) |
302 | if $other->_role_meta->name =~ /__ANON__/; |
303 | } |
304 | else { |
305 | next; |
306 | } |
307 | } |
308 | else { |
309 | # add it, although it could be overriden |
310 | $other->alias_method( |
311 | $method_name, |
312 | $self->get_method($method_name) |
313 | ); |
314 | } |
a2eec5e7 |
315 | } |
316 | } |
317 | |
a2eec5e7 |
318 | sub apply { |
319 | my ($self, $other) = @_; |
bdabd620 |
320 | |
d7c04559 |
321 | ($other->isa('Moose::Meta::Class') || $other->isa('Moose::Meta::Role')) |
322 | || confess "You must apply a role to a metaclass, not ($other)"; |
323 | |
a2eec5e7 |
324 | $self->_check_excluded_roles($other); |
325 | $self->_check_required_methods($other); |
326 | |
327 | $self->_apply_attributes($other); |
328 | $self->_apply_methods($other); |
d63f8289 |
329 | |
bdabd620 |
330 | $other->add_role($self); |
331 | } |
332 | |
db1ab48d |
333 | sub combine { |
334 | my ($class, @roles) = @_; |
335 | |
336 | my $combined = $class->new( |
337 | ':role_meta' => Moose::Meta::Class->create_anon_class() |
338 | ); |
339 | |
340 | foreach my $role (@roles) { |
341 | $role->apply($combined); |
342 | } |
343 | |
d05cd563 |
344 | $combined->_clean_up_required_methods; |
db1ab48d |
345 | |
346 | return $combined; |
347 | } |
348 | |
a7d0cd00 |
349 | package Moose::Meta::Role::Method; |
350 | |
351 | use strict; |
352 | use warnings; |
353 | |
354 | our $VERSION = '0.01'; |
355 | |
356 | use base 'Class::MOP::Method'; |
e185c027 |
357 | |
358 | 1; |
359 | |
360 | __END__ |
361 | |
362 | =pod |
363 | |
364 | =head1 NAME |
365 | |
366 | Moose::Meta::Role - The Moose Role metaclass |
367 | |
368 | =head1 DESCRIPTION |
369 | |
79592a54 |
370 | Moose's Roles are being actively developed, please see L<Moose::Role> |
02a0fb52 |
371 | for more information. For the most part, this has no user-serviceable |
372 | parts inside. It's API is still subject to some change (although |
373 | probably not that much really). |
79592a54 |
374 | |
e185c027 |
375 | =head1 METHODS |
376 | |
377 | =over 4 |
378 | |
379 | =item B<meta> |
380 | |
381 | =item B<new> |
382 | |
78cd1d3b |
383 | =item B<apply> |
384 | |
db1ab48d |
385 | =item B<combine> |
386 | |
e185c027 |
387 | =back |
388 | |
389 | =over 4 |
390 | |
391 | =item B<name> |
392 | |
393 | =item B<version> |
394 | |
395 | =item B<role_meta> |
396 | |
397 | =back |
398 | |
399 | =over 4 |
400 | |
80572233 |
401 | =item B<get_roles> |
402 | |
403 | =item B<add_role> |
404 | |
405 | =item B<does_role> |
406 | |
407 | =back |
408 | |
409 | =over 4 |
410 | |
d79e62fd |
411 | =item B<add_excluded_roles> |
412 | |
413 | =item B<excludes_role> |
414 | |
415 | =item B<get_excluded_roles_list> |
416 | |
417 | =item B<get_excluded_roles_map> |
418 | |
2b14ac61 |
419 | =item B<calculate_all_roles> |
420 | |
d79e62fd |
421 | =back |
422 | |
423 | =over 4 |
424 | |
be4427d0 |
425 | =item B<find_method_by_name> |
426 | |
e185c027 |
427 | =item B<get_method> |
428 | |
429 | =item B<has_method> |
430 | |
bdabd620 |
431 | =item B<alias_method> |
432 | |
e185c027 |
433 | =item B<get_method_list> |
434 | |
435 | =back |
436 | |
437 | =over 4 |
438 | |
439 | =item B<add_attribute> |
440 | |
441 | =item B<has_attribute> |
442 | |
443 | =item B<get_attribute> |
444 | |
445 | =item B<get_attribute_list> |
446 | |
447 | =item B<get_attribute_map> |
448 | |
449 | =item B<remove_attribute> |
450 | |
451 | =back |
452 | |
453 | =over 4 |
454 | |
1331430a |
455 | =item B<add_required_methods> |
456 | |
38f1204c |
457 | =item B<remove_required_methods> |
458 | |
1331430a |
459 | =item B<get_required_method_list> |
460 | |
461 | =item B<get_required_methods_map> |
462 | |
463 | =item B<requires_method> |
464 | |
465 | =back |
466 | |
e185c027 |
467 | =head1 BUGS |
468 | |
469 | All complex software has bugs lurking in it, and this module is no |
470 | exception. If you find a bug please either email me, or add the bug |
471 | to cpan-RT. |
472 | |
473 | =head1 AUTHOR |
474 | |
475 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
476 | |
477 | =head1 COPYRIGHT AND LICENSE |
478 | |
479 | Copyright 2006 by Infinity Interactive, Inc. |
480 | |
481 | L<http://www.iinteractive.com> |
482 | |
483 | This library is free software; you can redistribute it and/or modify |
484 | it under the same terms as Perl itself. |
485 | |
b8aeb4dc |
486 | =cut |