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 # Yes, this is a really really UGLY hack
153 # but it works, and until I can figure
154 # out a better way, this is gonna be it.
156 sub get_method { (shift)->Moose::Meta::Class::get_method(@_) }
157 sub find_method_by_name { (shift)->Moose::Meta::Class::find_method_by_name(@_) }
158 sub has_method { (shift)->Moose::Meta::Class::has_method(@_) }
159 sub alias_method { (shift)->Moose::Meta::Class::alias_method(@_) }
160 sub get_method_list {
164 # this is a kludge for now,... these functions
165 # should not be showing up in the list at all,
166 # but they do, so we need to switch Moose::Role
167 # and Moose to use Sub::Exporter to prevent this
168 !/^(meta|has|extends|blessed|confess|augment|inner|override|super|before|after|around|with|requires)$/
169 } $self->Moose::Meta::Class::get_method_list;
172 # ... however the items in statis (attributes & method modifiers)
173 # can be removed and added to through this API
181 if (scalar @_ == 1 && ref($_[0]) eq 'HASH') {
187 $self->get_attribute_map->{$name} = $attr_desc;
191 my ($self, $name) = @_;
192 exists $self->get_attribute_map->{$name} ? 1 : 0;
196 my ($self, $name) = @_;
197 $self->get_attribute_map->{$name}
200 sub remove_attribute {
201 my ($self, $name) = @_;
202 delete $self->get_attribute_map->{$name}
205 sub get_attribute_list {
207 keys %{$self->get_attribute_map};
212 # mimic the metaclass API
213 sub add_before_method_modifier { (shift)->_add_method_modifier('before', @_) }
214 sub add_around_method_modifier { (shift)->_add_method_modifier('around', @_) }
215 sub add_after_method_modifier { (shift)->_add_method_modifier('after', @_) }
217 sub _add_method_modifier {
218 my ($self, $modifier_type, $method_name, $method) = @_;
219 my $accessor = "get_${modifier_type}_method_modifiers_map";
220 $self->$accessor->{$method_name} = []
221 unless exists $self->$accessor->{$method_name};
222 my $modifiers = $self->$accessor->{$method_name};
224 # check to see that we aren't adding the
225 # same code twice. We err in favor of the
226 # first on here, this may not be as expected
227 foreach my $modifier (@{$modifiers}) {
228 return if $modifier == $method;
230 push @{$modifiers} => $method;
233 sub add_override_method_modifier {
234 my ($self, $method_name, $method) = @_;
235 (!$self->has_method($method_name))
236 || confess "Cannot add an override of method '$method_name' " .
237 "because there is a local version of '$method_name'";
238 $self->get_override_method_modifiers_map->{$method_name} = $method;
241 sub has_before_method_modifiers { (shift)->_has_method_modifiers('before', @_) }
242 sub has_around_method_modifiers { (shift)->_has_method_modifiers('around', @_) }
243 sub has_after_method_modifiers { (shift)->_has_method_modifiers('after', @_) }
245 # override just checks for one,..
246 # but we can still re-use stuff
247 sub has_override_method_modifier { (shift)->_has_method_modifiers('override', @_) }
249 sub _has_method_modifiers {
250 my ($self, $modifier_type, $method_name) = @_;
251 my $accessor = "get_${modifier_type}_method_modifiers_map";
253 # for now we assume that if it exists,..
254 # it has at least one modifier in it
255 (exists $self->$accessor->{$method_name}) ? 1 : 0;
258 sub get_before_method_modifiers { (shift)->_get_method_modifiers('before', @_) }
259 sub get_around_method_modifiers { (shift)->_get_method_modifiers('around', @_) }
260 sub get_after_method_modifiers { (shift)->_get_method_modifiers('after', @_) }
262 sub _get_method_modifiers {
263 my ($self, $modifier_type, $method_name) = @_;
264 my $accessor = "get_${modifier_type}_method_modifiers_map";
265 @{$self->$accessor->{$method_name}};
268 sub get_override_method_modifier {
269 my ($self, $method_name) = @_;
270 $self->get_override_method_modifiers_map->{$method_name};
273 sub get_method_modifier_list {
274 my ($self, $modifier_type) = @_;
275 my $accessor = "get_${modifier_type}_method_modifiers_map";
276 keys %{$self->$accessor};
279 ## applying a role to a class ...
281 sub _check_excluded_roles {
282 my ($self, $other) = @_;
283 if ($other->excludes_role($self->name)) {
284 confess "Conflict detected: " . $other->name . " excludes role '" . $self->name . "'";
286 foreach my $excluded_role_name ($self->get_excluded_roles_list) {
287 if ($other->does_role($excluded_role_name)) {
288 confess "The class " . $other->name . " does the excluded role '$excluded_role_name'";
291 if ($other->isa('Moose::Meta::Role')) {
292 $other->add_excluded_roles($excluded_role_name);
294 # else -> ignore it :)
299 sub _check_required_methods {
300 my ($self, $other) = @_;
302 # we might need to move this down below the
303 # the attributes so that we can require any
304 # attribute accessors. However I am thinking
305 # that maybe those are somehow exempt from
306 # the require methods stuff.
307 foreach my $required_method_name ($self->get_required_method_list) {
309 unless ($other->find_method_by_name($required_method_name)) {
310 if ($other->isa('Moose::Meta::Role')) {
311 $other->add_required_methods($required_method_name);
314 confess "'" . $self->name . "' requires the method '$required_method_name' " .
315 "to be implemented by '" . $other->name . "'";
320 # we need to make sure that the method is
321 # not a method modifier, because those do
322 # not satisfy the requirements ...
323 my $method = $other->get_method($required_method_name);
324 # check if it is an override or a generated accessor ..
325 (!$method->isa('Moose::Meta::Method::Overriden') &&
326 !$method->isa('Class::MOP::Attribute::Accessor'))
327 || confess "'" . $self->name . "' requires the method '$required_method_name' " .
328 "to be implemented by '" . $other->name . "', the method is only a method modifier";
329 # before/after/around methods are a little trickier
330 # since we wrap the original local method (if applicable)
331 # so we need to check if the original wrapped method is
332 # from the same package, and not a wrap of the super method
333 if ($method->isa('Class::MOP::Method::Wrapped')) {
334 ($method->get_original_method->package_name eq $other->name)
335 || confess "'" . $self->name . "' requires the method '$required_method_name' " .
336 "to be implemented by '" . $other->name . "', the method is only a method modifier";
342 sub _apply_attributes {
343 my ($self, $other) = @_;
344 foreach my $attribute_name ($self->get_attribute_list) {
345 # it if it has one already
346 if ($other->has_attribute($attribute_name) &&
347 # make sure we haven't seen this one already too
348 $other->get_attribute($attribute_name) != $self->get_attribute($attribute_name)) {
349 # see if we are being composed
351 if ($other->isa('Moose::Meta::Role')) {
352 # all attribute conflicts between roles
353 # result in an immediate fatal error
354 confess "Role '" . $self->name . "' has encountered an attribute conflict " .
355 "during composition. This is fatal error and cannot be disambiguated.";
358 # but if this is a class, we
359 # can safely skip adding the
360 # attribute to the class
365 $other->add_attribute(
367 $self->get_attribute($attribute_name)
374 my ($self, $other) = @_;
375 foreach my $method_name ($self->get_method_list) {
376 # it if it has one already
377 if ($other->has_method($method_name) &&
378 # and if they are not the same thing ...
379 $other->get_method($method_name) != $self->get_method($method_name)) {
380 # see if we are composing into a role
381 if ($other->isa('Moose::Meta::Role')) {
382 # method conflicts between roles result
383 # in the method becoming a requirement
384 $other->add_required_methods($method_name);
386 # we have to remove the method from our
387 # role, if this is being called from combine()
388 # which means the meta is an anon class
389 # this *may* cause problems later, but it
390 # is probably fairly safe to assume that
391 # anon classes will only be used internally
392 # or by people who know what they are doing
393 $other->Moose::Meta::Class::remove_method($method_name)
394 if $other->name =~ /__COMPOSITE_ROLE_SANDBOX__/;
401 # add it, although it could be overriden
402 $other->alias_method(
404 $self->get_method($method_name)
410 sub _apply_override_method_modifiers {
411 my ($self, $other) = @_;
412 foreach my $method_name ($self->get_method_modifier_list('override')) {
413 # it if it has one already then ...
414 if ($other->has_method($method_name)) {
415 # if it is being composed into another role
416 # we have a conflict here, because you cannot
417 # combine an overriden method with a locally
419 if ($other->isa('Moose::Meta::Role')) {
420 confess "Role '" . $self->name . "' has encountered an 'override' method conflict " .
421 "during composition (A local method of the same name as been found). This " .
425 # if it is a class, then we
426 # just ignore this here ...
431 # if no local method is found, then we
432 # must check if we are a role or class
433 if ($other->isa('Moose::Meta::Role')) {
434 # if we are a role, we need to make sure
435 # we dont have a conflict with the role
436 # we are composing into
437 if ($other->has_override_method_modifier($method_name) &&
438 $other->get_override_method_modifier($method_name) != $self->get_override_method_modifier($method_name)) {
439 confess "Role '" . $self->name . "' has encountered an 'override' method conflict " .
440 "during composition (Two 'override' methods of the same name encountered). " .
441 "This is fatal error.";
444 # if there is no conflict,
445 # just add it to the role
446 $other->add_override_method_modifier(
448 $self->get_override_method_modifier($method_name)
453 # if this is not a role, then we need to
454 # find the original package of the method
455 # so that we can tell the class were to
456 # find the right super() method
457 my $method = $self->get_override_method_modifier($method_name);
458 my $package = svref_2object($method)->GV->STASH->NAME;
459 # if it is a class, we just add it
460 $other->add_override_method_modifier($method_name, $method, $package);
466 sub _apply_method_modifiers {
467 my ($self, $modifier_type, $other) = @_;
468 my $add = "add_${modifier_type}_method_modifier";
469 my $get = "get_${modifier_type}_method_modifiers";
470 foreach my $method_name ($self->get_method_modifier_list($modifier_type)) {
474 ) foreach $self->$get($method_name);
478 sub _apply_before_method_modifiers { (shift)->_apply_method_modifiers('before' => @_) }
479 sub _apply_around_method_modifiers { (shift)->_apply_method_modifiers('around' => @_) }
480 sub _apply_after_method_modifiers { (shift)->_apply_method_modifiers('after' => @_) }
483 my ($self, $other) = @_;
485 ($other->isa('Moose::Meta::Class') || $other->isa('Moose::Meta::Role'))
486 || confess "You must apply a role to a metaclass, not ($other)";
488 $self->_check_excluded_roles($other);
489 $self->_check_required_methods($other);
491 $self->_apply_attributes($other);
492 $self->_apply_methods($other);
494 $self->_apply_override_method_modifiers($other);
495 $self->_apply_before_method_modifiers($other);
496 $self->_apply_around_method_modifiers($other);
497 $self->_apply_after_method_modifiers($other);
499 $other->add_role($self);
502 my $anon_counter = 0;
505 my ($class, @roles) = @_;
507 my $pkg_name = __PACKAGE__ . "::__COMPOSITE_ROLE_SANDBOX__::" . $anon_counter++;
508 eval "package " . $pkg_name . "; our \$VERSION = '0.00';";
511 my $combined = $class->initialize($pkg_name);
513 foreach my $role (@roles) {
514 $role->apply($combined);
517 $combined->_clean_up_required_methods;
522 package Moose::Meta::Role::Method;
527 our $VERSION = '0.01';
529 use base 'Class::MOP::Method';
539 Moose::Meta::Role - The Moose Role metaclass
543 Moose's Roles are being actively developed, please see L<Moose::Role>
544 for more information. For the most part, this has no user-serviceable
545 parts inside. It's API is still subject to some change (although
546 probably not that much really).
584 =item B<add_excluded_roles>
586 =item B<excludes_role>
588 =item B<get_excluded_roles_list>
590 =item B<get_excluded_roles_map>
592 =item B<calculate_all_roles>
598 =item B<method_metaclass>
600 =item B<find_method_by_name>
606 =item B<alias_method>
608 =item B<get_method_list>
614 =item B<add_attribute>
616 =item B<has_attribute>
618 =item B<get_attribute>
620 =item B<get_attribute_list>
622 =item B<get_attribute_map>
624 =item B<remove_attribute>
630 =item B<add_required_methods>
632 =item B<remove_required_methods>
634 =item B<get_required_method_list>
636 =item B<get_required_methods_map>
638 =item B<requires_method>
644 =item B<add_after_method_modifier>
646 =item B<add_around_method_modifier>
648 =item B<add_before_method_modifier>
650 =item B<add_override_method_modifier>
656 =item B<has_after_method_modifiers>
658 =item B<has_around_method_modifiers>
660 =item B<has_before_method_modifiers>
662 =item B<has_override_method_modifier>
668 =item B<get_after_method_modifiers>
670 =item B<get_around_method_modifiers>
672 =item B<get_before_method_modifiers>
674 =item B<get_method_modifier_list>
680 =item B<get_override_method_modifier>
682 =item B<get_after_method_modifiers_map>
684 =item B<get_around_method_modifiers_map>
686 =item B<get_before_method_modifiers_map>
688 =item B<get_override_method_modifiers_map>
694 All complex software has bugs lurking in it, and this module is no
695 exception. If you find a bug please either email me, or add the bug
700 Stevan Little E<lt>stevan@iinteractive.comE<gt>
702 =head1 COPYRIGHT AND LICENSE
704 Copyright 2006 by Infinity Interactive, Inc.
706 L<http://www.iinteractive.com>
708 This library is free software; you can redistribute it and/or modify
709 it under the same terms as Perl itself.