2 package Moose::Meta::Role;
9 use Scalar::Util 'blessed';
10 use B 'svref_2object';
12 our $VERSION = '0.07';
13 our $AUTHORITY = 'cpan:STEVAN';
15 use Moose::Meta::Class;
16 use Moose::Meta::Role::Method;
18 use base 'Class::MOP::Module';
24 __PACKAGE__->meta->add_attribute('roles' => (
25 reader => 'get_roles',
31 __PACKAGE__->meta->add_attribute('excluded_roles_map' => (
32 reader => 'get_excluded_roles_map',
38 __PACKAGE__->meta->add_attribute('attribute_map' => (
39 reader => 'get_attribute_map',
45 __PACKAGE__->meta->add_attribute('required_methods' => (
46 reader => 'get_required_methods_map',
52 __PACKAGE__->meta->add_attribute('before_method_modifiers' => (
53 reader => 'get_before_method_modifiers_map',
54 default => sub { {} } # (<name> => [ (CODE) ])
57 __PACKAGE__->meta->add_attribute('after_method_modifiers' => (
58 reader => 'get_after_method_modifiers_map',
59 default => sub { {} } # (<name> => [ (CODE) ])
62 __PACKAGE__->meta->add_attribute('around_method_modifiers' => (
63 reader => 'get_around_method_modifiers_map',
64 default => sub { {} } # (<name> => [ (CODE) ])
67 __PACKAGE__->meta->add_attribute('override_method_modifiers' => (
68 reader => 'get_override_method_modifiers_map',
69 default => sub { {} } # (<name> => CODE)
74 sub method_metaclass { 'Moose::Meta::Role::Method' }
79 my ($self, $role) = @_;
80 (blessed($role) && $role->isa('Moose::Meta::Role'))
81 || confess "Roles must be instances of Moose::Meta::Role";
82 push @{$self->get_roles} => $role;
85 sub calculate_all_roles {
88 grep { !$seen{$_->name}++ } $self, map { $_->calculate_all_roles } @{ $self->get_roles };
92 my ($self, $role_name) = @_;
94 || confess "You must supply a role name to look for";
95 # if we are it,.. then return true
96 return 1 if $role_name eq $self->name;
97 # otherwise.. check our children
98 foreach my $role (@{$self->get_roles}) {
99 return 1 if $role->does_role($role_name);
106 sub add_excluded_roles {
107 my ($self, @excluded_role_names) = @_;
108 $self->get_excluded_roles_map->{$_} = undef foreach @excluded_role_names;
111 sub get_excluded_roles_list {
113 keys %{$self->get_excluded_roles_map};
117 my ($self, $role_name) = @_;
118 exists $self->get_excluded_roles_map->{$role_name} ? 1 : 0;
123 sub add_required_methods {
124 my ($self, @methods) = @_;
125 $self->get_required_methods_map->{$_} = undef foreach @methods;
128 sub remove_required_methods {
129 my ($self, @methods) = @_;
130 delete $self->get_required_methods_map->{$_} foreach @methods;
133 sub get_required_method_list {
135 keys %{$self->get_required_methods_map};
138 sub requires_method {
139 my ($self, $method_name) = @_;
140 exists $self->get_required_methods_map->{$method_name} ? 1 : 0;
143 sub _clean_up_required_methods {
145 foreach my $method ($self->get_required_method_list) {
146 $self->remove_required_methods($method)
147 if $self->has_method($method);
154 # this is an UGLY hack
157 $self->{'%!methods'} ||= {};
158 $self->Moose::Meta::Class::get_method_map()
162 # Yes, this is a really really UGLY hack
163 # but it works, and until I can figure
164 # out a better way, this is gonna be it.
166 sub get_method { (shift)->Moose::Meta::Class::get_method(@_) }
167 sub has_method { (shift)->Moose::Meta::Class::has_method(@_) }
168 sub alias_method { (shift)->Moose::Meta::Class::alias_method(@_) }
169 sub get_method_list {
172 } (shift)->Moose::Meta::Class::get_method_list(@_)
175 sub find_method_by_name { (shift)->has_method(@_) }
177 # ... however the items in statis (attributes & method modifiers)
178 # can be removed and added to through this API
186 if (scalar @_ == 1 && ref($_[0]) eq 'HASH') {
192 $self->get_attribute_map->{$name} = $attr_desc;
196 my ($self, $name) = @_;
197 exists $self->get_attribute_map->{$name} ? 1 : 0;
201 my ($self, $name) = @_;
202 $self->get_attribute_map->{$name}
205 sub remove_attribute {
206 my ($self, $name) = @_;
207 delete $self->get_attribute_map->{$name}
210 sub get_attribute_list {
212 keys %{$self->get_attribute_map};
217 # mimic the metaclass API
218 sub add_before_method_modifier { (shift)->_add_method_modifier('before', @_) }
219 sub add_around_method_modifier { (shift)->_add_method_modifier('around', @_) }
220 sub add_after_method_modifier { (shift)->_add_method_modifier('after', @_) }
222 sub _add_method_modifier {
223 my ($self, $modifier_type, $method_name, $method) = @_;
224 my $accessor = "get_${modifier_type}_method_modifiers_map";
225 $self->$accessor->{$method_name} = []
226 unless exists $self->$accessor->{$method_name};
227 my $modifiers = $self->$accessor->{$method_name};
229 # check to see that we aren't adding the
230 # same code twice. We err in favor of the
231 # first on here, this may not be as expected
232 foreach my $modifier (@{$modifiers}) {
233 return if $modifier == $method;
235 push @{$modifiers} => $method;
238 sub add_override_method_modifier {
239 my ($self, $method_name, $method) = @_;
240 (!$self->has_method($method_name))
241 || confess "Cannot add an override of method '$method_name' " .
242 "because there is a local version of '$method_name'";
243 $self->get_override_method_modifiers_map->{$method_name} = $method;
246 sub has_before_method_modifiers { (shift)->_has_method_modifiers('before', @_) }
247 sub has_around_method_modifiers { (shift)->_has_method_modifiers('around', @_) }
248 sub has_after_method_modifiers { (shift)->_has_method_modifiers('after', @_) }
250 # override just checks for one,..
251 # but we can still re-use stuff
252 sub has_override_method_modifier { (shift)->_has_method_modifiers('override', @_) }
254 sub _has_method_modifiers {
255 my ($self, $modifier_type, $method_name) = @_;
256 my $accessor = "get_${modifier_type}_method_modifiers_map";
258 # for now we assume that if it exists,..
259 # it has at least one modifier in it
260 (exists $self->$accessor->{$method_name}) ? 1 : 0;
263 sub get_before_method_modifiers { (shift)->_get_method_modifiers('before', @_) }
264 sub get_around_method_modifiers { (shift)->_get_method_modifiers('around', @_) }
265 sub get_after_method_modifiers { (shift)->_get_method_modifiers('after', @_) }
267 sub _get_method_modifiers {
268 my ($self, $modifier_type, $method_name) = @_;
269 my $accessor = "get_${modifier_type}_method_modifiers_map";
270 @{$self->$accessor->{$method_name}};
273 sub get_override_method_modifier {
274 my ($self, $method_name) = @_;
275 $self->get_override_method_modifiers_map->{$method_name};
278 sub get_method_modifier_list {
279 my ($self, $modifier_type) = @_;
280 my $accessor = "get_${modifier_type}_method_modifiers_map";
281 keys %{$self->$accessor};
284 ## applying a role to a class ...
286 sub _check_excluded_roles {
287 my ($self, $other) = @_;
288 if ($other->excludes_role($self->name)) {
289 confess "Conflict detected: " . $other->name . " excludes role '" . $self->name . "'";
291 foreach my $excluded_role_name ($self->get_excluded_roles_list) {
292 if ($other->does_role($excluded_role_name)) {
293 confess "The class " . $other->name . " does the excluded role '$excluded_role_name'";
296 if ($other->isa('Moose::Meta::Role')) {
297 $other->add_excluded_roles($excluded_role_name);
299 # else -> ignore it :)
304 sub _check_required_methods {
305 my ($self, $other) = @_;
307 # we might need to move this down below the
308 # the attributes so that we can require any
309 # attribute accessors. However I am thinking
310 # that maybe those are somehow exempt from
311 # the require methods stuff.
312 foreach my $required_method_name ($self->get_required_method_list) {
314 unless ($other->find_method_by_name($required_method_name)) {
315 if ($other->isa('Moose::Meta::Role')) {
316 $other->add_required_methods($required_method_name);
319 confess "'" . $self->name . "' requires the method '$required_method_name' " .
320 "to be implemented by '" . $other->name . "'";
325 # we need to make sure that the method is
326 # not a method modifier, because those do
327 # not satisfy the requirements ...
328 my $method = $other->get_method($required_method_name);
329 # check if it is an override or a generated accessor ..
330 (!$method->isa('Moose::Meta::Method::Overriden') &&
331 !$method->isa('Class::MOP::Method::Accessor'))
332 || confess "'" . $self->name . "' requires the method '$required_method_name' " .
333 "to be implemented by '" . $other->name . "', the method is only a method modifier";
334 # before/after/around methods are a little trickier
335 # since we wrap the original local method (if applicable)
336 # so we need to check if the original wrapped method is
337 # from the same package, and not a wrap of the super method
338 if ($method->isa('Class::MOP::Method::Wrapped')) {
339 ($method->get_original_method->package_name eq $other->name)
340 || confess "'" . $self->name . "' requires the method '$required_method_name' " .
341 "to be implemented by '" . $other->name . "', the method is only a method modifier";
347 sub _apply_attributes {
348 my ($self, $other) = @_;
349 foreach my $attribute_name ($self->get_attribute_list) {
350 # it if it has one already
351 if ($other->has_attribute($attribute_name) &&
352 # make sure we haven't seen this one already too
353 $other->get_attribute($attribute_name) != $self->get_attribute($attribute_name)) {
354 # see if we are being composed
356 if ($other->isa('Moose::Meta::Role')) {
357 # all attribute conflicts between roles
358 # result in an immediate fatal error
359 confess "Role '" . $self->name . "' has encountered an attribute conflict " .
360 "during composition. This is fatal error and cannot be disambiguated.";
363 # but if this is a class, we
364 # can safely skip adding the
365 # attribute to the class
371 # this is kinda ugly ...
372 if ($other->isa('Moose::Meta::Class')) {
373 $other->_process_attribute(
375 %{$self->get_attribute($attribute_name)}
379 $other->add_attribute(
381 $self->get_attribute($attribute_name)
389 my ($self, $other) = @_;
390 foreach my $method_name ($self->get_method_list) {
391 # it if it has one already
392 if ($other->has_method($method_name) &&
393 # and if they are not the same thing ...
394 $other->get_method($method_name)->body != $self->get_method($method_name)->body) {
395 # see if we are composing into a role
396 if ($other->isa('Moose::Meta::Role')) {
397 # method conflicts between roles result
398 # in the method becoming a requirement
399 $other->add_required_methods($method_name);
401 # we have to remove the method from our
402 # role, if this is being called from combine()
403 # which means the meta is an anon class
404 # this *may* cause problems later, but it
405 # is probably fairly safe to assume that
406 # anon classes will only be used internally
407 # or by people who know what they are doing
408 $other->Moose::Meta::Class::remove_method($method_name)
409 if $other->name =~ /__COMPOSITE_ROLE_SANDBOX__/;
416 # add it, although it could be overriden
417 $other->alias_method(
419 $self->get_method($method_name)
425 sub _apply_override_method_modifiers {
426 my ($self, $other) = @_;
427 foreach my $method_name ($self->get_method_modifier_list('override')) {
428 # it if it has one already then ...
429 if ($other->has_method($method_name)) {
430 # if it is being composed into another role
431 # we have a conflict here, because you cannot
432 # combine an overriden method with a locally
434 if ($other->isa('Moose::Meta::Role')) {
435 confess "Role '" . $self->name . "' has encountered an 'override' method conflict " .
436 "during composition (A local method of the same name as been found). This " .
440 # if it is a class, then we
441 # just ignore this here ...
446 # if no local method is found, then we
447 # must check if we are a role or class
448 if ($other->isa('Moose::Meta::Role')) {
449 # if we are a role, we need to make sure
450 # we dont have a conflict with the role
451 # we are composing into
452 if ($other->has_override_method_modifier($method_name) &&
453 $other->get_override_method_modifier($method_name) != $self->get_override_method_modifier($method_name)) {
454 confess "Role '" . $self->name . "' has encountered an 'override' method conflict " .
455 "during composition (Two 'override' methods of the same name encountered). " .
456 "This is fatal error.";
459 # if there is no conflict,
460 # just add it to the role
461 $other->add_override_method_modifier(
463 $self->get_override_method_modifier($method_name)
468 # if this is not a role, then we need to
469 # find the original package of the method
470 # so that we can tell the class were to
471 # find the right super() method
472 my $method = $self->get_override_method_modifier($method_name);
473 my $package = svref_2object($method)->GV->STASH->NAME;
474 # if it is a class, we just add it
475 $other->add_override_method_modifier($method_name, $method, $package);
481 sub _apply_method_modifiers {
482 my ($self, $modifier_type, $other) = @_;
483 my $add = "add_${modifier_type}_method_modifier";
484 my $get = "get_${modifier_type}_method_modifiers";
485 foreach my $method_name ($self->get_method_modifier_list($modifier_type)) {
489 ) foreach $self->$get($method_name);
493 sub _apply_before_method_modifiers { (shift)->_apply_method_modifiers('before' => @_) }
494 sub _apply_around_method_modifiers { (shift)->_apply_method_modifiers('around' => @_) }
495 sub _apply_after_method_modifiers { (shift)->_apply_method_modifiers('after' => @_) }
497 my $anon_counter = 0;
500 my ($self, $other) = @_;
502 unless ($other->isa('Moose::Meta::Class') || $other->isa('Moose::Meta::Role')) {
504 # Runtime Role mixins
507 # We really should do this better, and
508 # cache the results of our efforts so
509 # that we don't need to repeat them.
511 my $pkg_name = __PACKAGE__ . "::__RUNTIME_ROLE_ANON_CLASS__::" . $anon_counter++;
512 eval "package " . $pkg_name . "; our \$VERSION = '0.00';";
517 $other = Moose::Meta::Class->initialize($pkg_name);
518 $other->superclasses(blessed($object));
520 bless $object => $pkg_name;
523 $self->_check_excluded_roles($other);
524 $self->_check_required_methods($other);
526 $self->_apply_attributes($other);
527 $self->_apply_methods($other);
529 $self->_apply_override_method_modifiers($other);
530 $self->_apply_before_method_modifiers($other);
531 $self->_apply_around_method_modifiers($other);
532 $self->_apply_after_method_modifiers($other);
534 $other->add_role($self);
538 my ($class, @roles) = @_;
540 my $pkg_name = __PACKAGE__ . "::__COMPOSITE_ROLE_SANDBOX__::" . $anon_counter++;
541 eval "package " . $pkg_name . "; our \$VERSION = '0.00';";
544 my $combined = $class->initialize($pkg_name);
546 foreach my $role (@roles) {
547 $role->apply($combined);
550 $combined->_clean_up_required_methods;
563 Moose::Meta::Role - The Moose Role metaclass
567 Please see L<Moose::Role> for more information about roles.
568 For the most part, this has no user-serviceable parts inside
569 this module. It's API is still subject to some change (although
570 probably not that much really).
608 =item B<add_excluded_roles>
610 =item B<excludes_role>
612 =item B<get_excluded_roles_list>
614 =item B<get_excluded_roles_map>
616 =item B<calculate_all_roles>
622 =item B<method_metaclass>
624 =item B<find_method_by_name>
630 =item B<alias_method>
632 =item B<get_method_list>
634 =item B<get_method_map>
640 =item B<add_attribute>
642 =item B<has_attribute>
644 =item B<get_attribute>
646 =item B<get_attribute_list>
648 =item B<get_attribute_map>
650 =item B<remove_attribute>
656 =item B<add_required_methods>
658 =item B<remove_required_methods>
660 =item B<get_required_method_list>
662 =item B<get_required_methods_map>
664 =item B<requires_method>
670 =item B<add_after_method_modifier>
672 =item B<add_around_method_modifier>
674 =item B<add_before_method_modifier>
676 =item B<add_override_method_modifier>
682 =item B<has_after_method_modifiers>
684 =item B<has_around_method_modifiers>
686 =item B<has_before_method_modifiers>
688 =item B<has_override_method_modifier>
694 =item B<get_after_method_modifiers>
696 =item B<get_around_method_modifiers>
698 =item B<get_before_method_modifiers>
700 =item B<get_method_modifier_list>
706 =item B<get_override_method_modifier>
708 =item B<get_after_method_modifiers_map>
710 =item B<get_around_method_modifiers_map>
712 =item B<get_before_method_modifiers_map>
714 =item B<get_override_method_modifiers_map>
720 All complex software has bugs lurking in it, and this module is no
721 exception. If you find a bug please either email me, or add the bug
726 Stevan Little E<lt>stevan@iinteractive.comE<gt>
728 =head1 COPYRIGHT AND LICENSE
730 Copyright 2006, 2007 by Infinity Interactive, Inc.
732 L<http://www.iinteractive.com>
734 This library is free software; you can redistribute it and/or modify
735 it under the same terms as Perl itself.