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