2 package Moose::Meta::Role;
9 use Scalar::Util 'blessed';
10 use B 'svref_2object';
12 use Moose::Meta::Class;
14 our $VERSION = '0.04';
16 use base 'Class::MOP::Module';
22 __PACKAGE__->meta->add_attribute('roles' => (
23 reader => 'get_roles',
29 __PACKAGE__->meta->add_attribute('excluded_roles_map' => (
30 reader => 'get_excluded_roles_map',
36 __PACKAGE__->meta->add_attribute('attribute_map' => (
37 reader => 'get_attribute_map',
43 __PACKAGE__->meta->add_attribute('required_methods' => (
44 reader => 'get_required_methods_map',
50 __PACKAGE__->meta->add_attribute('before_method_modifiers' => (
51 reader => 'get_before_method_modifiers_map',
52 default => sub { {} } # (<name> => [ (CODE) ])
55 __PACKAGE__->meta->add_attribute('after_method_modifiers' => (
56 reader => 'get_after_method_modifiers_map',
57 default => sub { {} } # (<name> => [ (CODE) ])
60 __PACKAGE__->meta->add_attribute('around_method_modifiers' => (
61 reader => 'get_around_method_modifiers_map',
62 default => sub { {} } # (<name> => [ (CODE) ])
65 __PACKAGE__->meta->add_attribute('override_method_modifiers' => (
66 reader => 'get_override_method_modifiers_map',
67 default => sub { {} } # (<name> => CODE)
72 sub method_metaclass { 'Moose::Meta::Role::Method' }
77 my ($self, $role) = @_;
78 (blessed($role) && $role->isa('Moose::Meta::Role'))
79 || confess "Roles must be instances of Moose::Meta::Role";
80 push @{$self->get_roles} => $role;
83 sub calculate_all_roles {
86 grep { !$seen{$_->name}++ } $self, map { $_->calculate_all_roles } @{ $self->get_roles };
90 my ($self, $role_name) = @_;
92 || confess "You must supply a role name to look for";
93 # if we are it,.. then return true
94 return 1 if $role_name eq $self->name;
95 # otherwise.. check our children
96 foreach my $role (@{$self->get_roles}) {
97 return 1 if $role->does_role($role_name);
104 sub add_excluded_roles {
105 my ($self, @excluded_role_names) = @_;
106 $self->get_excluded_roles_map->{$_} = undef foreach @excluded_role_names;
109 sub get_excluded_roles_list {
111 keys %{$self->get_excluded_roles_map};
115 my ($self, $role_name) = @_;
116 exists $self->get_excluded_roles_map->{$role_name} ? 1 : 0;
121 sub add_required_methods {
122 my ($self, @methods) = @_;
123 $self->get_required_methods_map->{$_} = undef foreach @methods;
126 sub remove_required_methods {
127 my ($self, @methods) = @_;
128 delete $self->get_required_methods_map->{$_} foreach @methods;
131 sub get_required_method_list {
133 keys %{$self->get_required_methods_map};
136 sub requires_method {
137 my ($self, $method_name) = @_;
138 exists $self->get_required_methods_map->{$method_name} ? 1 : 0;
141 sub _clean_up_required_methods {
143 foreach my $method ($self->get_required_method_list) {
144 $self->remove_required_methods($method)
145 if $self->has_method($method);
152 # this is an UGLY hack
155 $self->{'%:methods'} ||= {};
156 $self->Moose::Meta::Class::get_method_map()
160 # Yes, this is a really really UGLY hack
161 # but it works, and until I can figure
162 # out a better way, this is gonna be it.
164 sub get_method { (shift)->Moose::Meta::Class::get_method(@_) }
165 sub has_method { (shift)->Moose::Meta::Class::has_method(@_) }
166 sub alias_method { (shift)->Moose::Meta::Class::alias_method(@_) }
167 sub get_method_list {
170 } (shift)->Moose::Meta::Class::get_method_list(@_)
173 sub find_method_by_name { (shift)->has_method(@_) }
175 # ... however the items in statis (attributes & method modifiers)
176 # can be removed and added to through this API
184 if (scalar @_ == 1 && ref($_[0]) eq 'HASH') {
190 $self->get_attribute_map->{$name} = $attr_desc;
194 my ($self, $name) = @_;
195 exists $self->get_attribute_map->{$name} ? 1 : 0;
199 my ($self, $name) = @_;
200 $self->get_attribute_map->{$name}
203 sub remove_attribute {
204 my ($self, $name) = @_;
205 delete $self->get_attribute_map->{$name}
208 sub get_attribute_list {
210 keys %{$self->get_attribute_map};
215 # mimic the metaclass API
216 sub add_before_method_modifier { (shift)->_add_method_modifier('before', @_) }
217 sub add_around_method_modifier { (shift)->_add_method_modifier('around', @_) }
218 sub add_after_method_modifier { (shift)->_add_method_modifier('after', @_) }
220 sub _add_method_modifier {
221 my ($self, $modifier_type, $method_name, $method) = @_;
222 my $accessor = "get_${modifier_type}_method_modifiers_map";
223 $self->$accessor->{$method_name} = []
224 unless exists $self->$accessor->{$method_name};
225 my $modifiers = $self->$accessor->{$method_name};
227 # check to see that we aren't adding the
228 # same code twice. We err in favor of the
229 # first on here, this may not be as expected
230 foreach my $modifier (@{$modifiers}) {
231 return if $modifier == $method;
233 push @{$modifiers} => $method;
236 sub add_override_method_modifier {
237 my ($self, $method_name, $method) = @_;
238 (!$self->has_method($method_name))
239 || confess "Cannot add an override of method '$method_name' " .
240 "because there is a local version of '$method_name'";
241 $self->get_override_method_modifiers_map->{$method_name} = $method;
244 sub has_before_method_modifiers { (shift)->_has_method_modifiers('before', @_) }
245 sub has_around_method_modifiers { (shift)->_has_method_modifiers('around', @_) }
246 sub has_after_method_modifiers { (shift)->_has_method_modifiers('after', @_) }
248 # override just checks for one,..
249 # but we can still re-use stuff
250 sub has_override_method_modifier { (shift)->_has_method_modifiers('override', @_) }
252 sub _has_method_modifiers {
253 my ($self, $modifier_type, $method_name) = @_;
254 my $accessor = "get_${modifier_type}_method_modifiers_map";
256 # for now we assume that if it exists,..
257 # it has at least one modifier in it
258 (exists $self->$accessor->{$method_name}) ? 1 : 0;
261 sub get_before_method_modifiers { (shift)->_get_method_modifiers('before', @_) }
262 sub get_around_method_modifiers { (shift)->_get_method_modifiers('around', @_) }
263 sub get_after_method_modifiers { (shift)->_get_method_modifiers('after', @_) }
265 sub _get_method_modifiers {
266 my ($self, $modifier_type, $method_name) = @_;
267 my $accessor = "get_${modifier_type}_method_modifiers_map";
268 @{$self->$accessor->{$method_name}};
271 sub get_override_method_modifier {
272 my ($self, $method_name) = @_;
273 $self->get_override_method_modifiers_map->{$method_name};
276 sub get_method_modifier_list {
277 my ($self, $modifier_type) = @_;
278 my $accessor = "get_${modifier_type}_method_modifiers_map";
279 keys %{$self->$accessor};
282 ## applying a role to a class ...
284 sub _check_excluded_roles {
285 my ($self, $other) = @_;
286 if ($other->excludes_role($self->name)) {
287 confess "Conflict detected: " . $other->name . " excludes role '" . $self->name . "'";
289 foreach my $excluded_role_name ($self->get_excluded_roles_list) {
290 if ($other->does_role($excluded_role_name)) {
291 confess "The class " . $other->name . " does the excluded role '$excluded_role_name'";
294 if ($other->isa('Moose::Meta::Role')) {
295 $other->add_excluded_roles($excluded_role_name);
297 # else -> ignore it :)
302 sub _check_required_methods {
303 my ($self, $other) = @_;
305 # we might need to move this down below the
306 # the attributes so that we can require any
307 # attribute accessors. However I am thinking
308 # that maybe those are somehow exempt from
309 # the require methods stuff.
310 foreach my $required_method_name ($self->get_required_method_list) {
312 unless ($other->find_method_by_name($required_method_name)) {
313 if ($other->isa('Moose::Meta::Role')) {
314 $other->add_required_methods($required_method_name);
317 confess "'" . $self->name . "' requires the method '$required_method_name' " .
318 "to be implemented by '" . $other->name . "'";
323 # we need to make sure that the method is
324 # not a method modifier, because those do
325 # not satisfy the requirements ...
326 my $method = $other->get_method($required_method_name);
327 # check if it is an override or a generated accessor ..
328 (!$method->isa('Moose::Meta::Method::Overriden') &&
329 !$method->isa('Class::MOP::Attribute::Accessor'))
330 || confess "'" . $self->name . "' requires the method '$required_method_name' " .
331 "to be implemented by '" . $other->name . "', the method is only a method modifier";
332 # before/after/around methods are a little trickier
333 # since we wrap the original local method (if applicable)
334 # so we need to check if the original wrapped method is
335 # from the same package, and not a wrap of the super method
336 if ($method->isa('Class::MOP::Method::Wrapped')) {
337 ($method->get_original_method->package_name eq $other->name)
338 || confess "'" . $self->name . "' requires the method '$required_method_name' " .
339 "to be implemented by '" . $other->name . "', the method is only a method modifier";
345 sub _apply_attributes {
346 my ($self, $other) = @_;
347 foreach my $attribute_name ($self->get_attribute_list) {
348 # it if it has one already
349 if ($other->has_attribute($attribute_name) &&
350 # make sure we haven't seen this one already too
351 $other->get_attribute($attribute_name) != $self->get_attribute($attribute_name)) {
352 # see if we are being composed
354 if ($other->isa('Moose::Meta::Role')) {
355 # all attribute conflicts between roles
356 # result in an immediate fatal error
357 confess "Role '" . $self->name . "' has encountered an attribute conflict " .
358 "during composition. This is fatal error and cannot be disambiguated.";
361 # but if this is a class, we
362 # can safely skip adding the
363 # attribute to the class
368 $other->add_attribute(
370 $self->get_attribute($attribute_name)
377 my ($self, $other) = @_;
378 foreach my $method_name ($self->get_method_list) {
379 # it if it has one already
380 if ($other->has_method($method_name) &&
381 # and if they are not the same thing ...
382 $other->get_method($method_name)->body != $self->get_method($method_name)->body) {
383 # see if we are composing into a role
384 if ($other->isa('Moose::Meta::Role')) {
385 # method conflicts between roles result
386 # in the method becoming a requirement
387 $other->add_required_methods($method_name);
389 # we have to remove the method from our
390 # role, if this is being called from combine()
391 # which means the meta is an anon class
392 # this *may* cause problems later, but it
393 # is probably fairly safe to assume that
394 # anon classes will only be used internally
395 # or by people who know what they are doing
396 $other->Moose::Meta::Class::remove_method($method_name)
397 if $other->name =~ /__COMPOSITE_ROLE_SANDBOX__/;
404 # add it, although it could be overriden
405 $other->alias_method(
407 $self->get_method($method_name)
413 sub _apply_override_method_modifiers {
414 my ($self, $other) = @_;
415 foreach my $method_name ($self->get_method_modifier_list('override')) {
416 # it if it has one already then ...
417 if ($other->has_method($method_name)) {
418 # if it is being composed into another role
419 # we have a conflict here, because you cannot
420 # combine an overriden method with a locally
422 if ($other->isa('Moose::Meta::Role')) {
423 confess "Role '" . $self->name . "' has encountered an 'override' method conflict " .
424 "during composition (A local method of the same name as been found). This " .
428 # if it is a class, then we
429 # just ignore this here ...
434 # if no local method is found, then we
435 # must check if we are a role or class
436 if ($other->isa('Moose::Meta::Role')) {
437 # if we are a role, we need to make sure
438 # we dont have a conflict with the role
439 # we are composing into
440 if ($other->has_override_method_modifier($method_name) &&
441 $other->get_override_method_modifier($method_name) != $self->get_override_method_modifier($method_name)) {
442 confess "Role '" . $self->name . "' has encountered an 'override' method conflict " .
443 "during composition (Two 'override' methods of the same name encountered). " .
444 "This is fatal error.";
447 # if there is no conflict,
448 # just add it to the role
449 $other->add_override_method_modifier(
451 $self->get_override_method_modifier($method_name)
456 # if this is not a role, then we need to
457 # find the original package of the method
458 # so that we can tell the class were to
459 # find the right super() method
460 my $method = $self->get_override_method_modifier($method_name);
461 my $package = svref_2object($method)->GV->STASH->NAME;
462 # if it is a class, we just add it
463 $other->add_override_method_modifier($method_name, $method, $package);
469 sub _apply_method_modifiers {
470 my ($self, $modifier_type, $other) = @_;
471 my $add = "add_${modifier_type}_method_modifier";
472 my $get = "get_${modifier_type}_method_modifiers";
473 foreach my $method_name ($self->get_method_modifier_list($modifier_type)) {
477 ) foreach $self->$get($method_name);
481 sub _apply_before_method_modifiers { (shift)->_apply_method_modifiers('before' => @_) }
482 sub _apply_around_method_modifiers { (shift)->_apply_method_modifiers('around' => @_) }
483 sub _apply_after_method_modifiers { (shift)->_apply_method_modifiers('after' => @_) }
485 my $anon_counter = 0;
488 my ($self, $other) = @_;
490 unless ($other->isa('Moose::Meta::Class') || $other->isa('Moose::Meta::Role')) {
492 # Runtime Role mixins
495 # We really should do this better, and
496 # cache the results of our efforts so
497 # that we don't need to repeat them.
499 my $pkg_name = __PACKAGE__ . "::__RUNTIME_ROLE_ANON_CLASS__::" . $anon_counter++;
500 eval "package " . $pkg_name . "; our \$VERSION = '0.00';";
505 $other = Moose::Meta::Class->initialize($pkg_name);
506 $other->superclasses(blessed($object));
508 bless $object => $pkg_name;
511 $self->_check_excluded_roles($other);
512 $self->_check_required_methods($other);
514 $self->_apply_attributes($other);
515 $self->_apply_methods($other);
517 $self->_apply_override_method_modifiers($other);
518 $self->_apply_before_method_modifiers($other);
519 $self->_apply_around_method_modifiers($other);
520 $self->_apply_after_method_modifiers($other);
522 $other->add_role($self);
526 my ($class, @roles) = @_;
528 my $pkg_name = __PACKAGE__ . "::__COMPOSITE_ROLE_SANDBOX__::" . $anon_counter++;
529 eval "package " . $pkg_name . "; our \$VERSION = '0.00';";
532 my $combined = $class->initialize($pkg_name);
534 foreach my $role (@roles) {
535 $role->apply($combined);
538 $combined->_clean_up_required_methods;
543 package Moose::Meta::Role::Method;
548 our $VERSION = '0.01';
550 use base 'Class::MOP::Method';
560 Moose::Meta::Role - The Moose Role metaclass
564 Moose's Roles are being actively developed, please see L<Moose::Role>
565 for more information. For the most part, this has no user-serviceable
566 parts inside. It's API is still subject to some change (although
567 probably not that much really).
605 =item B<add_excluded_roles>
607 =item B<excludes_role>
609 =item B<get_excluded_roles_list>
611 =item B<get_excluded_roles_map>
613 =item B<calculate_all_roles>
619 =item B<method_metaclass>
621 =item B<find_method_by_name>
627 =item B<alias_method>
629 =item B<get_method_list>
631 =item B<get_method_map>
637 =item B<add_attribute>
639 =item B<has_attribute>
641 =item B<get_attribute>
643 =item B<get_attribute_list>
645 =item B<get_attribute_map>
647 =item B<remove_attribute>
653 =item B<add_required_methods>
655 =item B<remove_required_methods>
657 =item B<get_required_method_list>
659 =item B<get_required_methods_map>
661 =item B<requires_method>
667 =item B<add_after_method_modifier>
669 =item B<add_around_method_modifier>
671 =item B<add_before_method_modifier>
673 =item B<add_override_method_modifier>
679 =item B<has_after_method_modifiers>
681 =item B<has_around_method_modifiers>
683 =item B<has_before_method_modifiers>
685 =item B<has_override_method_modifier>
691 =item B<get_after_method_modifiers>
693 =item B<get_around_method_modifiers>
695 =item B<get_before_method_modifiers>
697 =item B<get_method_modifier_list>
703 =item B<get_override_method_modifier>
705 =item B<get_after_method_modifiers_map>
707 =item B<get_around_method_modifiers_map>
709 =item B<get_before_method_modifiers_map>
711 =item B<get_override_method_modifiers_map>
717 All complex software has bugs lurking in it, and this module is no
718 exception. If you find a bug please either email me, or add the bug
723 Stevan Little E<lt>stevan@iinteractive.comE<gt>
725 =head1 COPYRIGHT AND LICENSE
727 Copyright 2006 by Infinity Interactive, Inc.
729 L<http://www.iinteractive.com>
731 This library is free software; you can redistribute it and/or modify
732 it under the same terms as Perl itself.