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