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);
151 sub get_method { (shift)->Moose::Meta::Class::get_method(@_) }
152 sub find_method_by_name { (shift)->Moose::Meta::Class::find_method_by_name(@_) }
153 sub has_method { (shift)->Moose::Meta::Class::has_method(@_) }
154 sub alias_method { (shift)->Moose::Meta::Class::alias_method(@_) }
155 sub get_method_list {
159 # this is a kludge for now,... these functions
160 # should not be showing up in the list at all,
161 # but they do, so we need to switch Moose::Role
162 # and Moose to use Sub::Exporter to prevent this
163 !/^(meta|has|extends|blessed|confess|augment|inner|override|super|before|after|around|with|requires)$/
164 } $self->Moose::Meta::Class::get_method_list;
167 # ... however the items in statis (attributes & method modifiers)
168 # can be removed and added to through this API
176 if (scalar @_ == 1 && ref($_[0]) eq 'HASH') {
182 $self->get_attribute_map->{$name} = $attr_desc;
186 my ($self, $name) = @_;
187 exists $self->get_attribute_map->{$name} ? 1 : 0;
191 my ($self, $name) = @_;
192 $self->get_attribute_map->{$name}
195 sub remove_attribute {
196 my ($self, $name) = @_;
197 delete $self->get_attribute_map->{$name}
200 sub get_attribute_list {
202 keys %{$self->get_attribute_map};
207 # mimic the metaclass API
208 sub add_before_method_modifier { (shift)->_add_method_modifier('before', @_) }
209 sub add_around_method_modifier { (shift)->_add_method_modifier('around', @_) }
210 sub add_after_method_modifier { (shift)->_add_method_modifier('after', @_) }
212 sub _add_method_modifier {
213 my ($self, $modifier_type, $method_name, $method) = @_;
214 my $accessor = "get_${modifier_type}_method_modifiers_map";
215 $self->$accessor->{$method_name} = []
216 unless exists $self->$accessor->{$method_name};
217 my $modifiers = $self->$accessor->{$method_name};
219 # check to see that we aren't adding the
220 # same code twice. We err in favor of the
221 # first on here, this may not be as expected
222 foreach my $modifier (@{$modifiers}) {
223 return if $modifier == $method;
225 push @{$modifiers} => $method;
228 sub add_override_method_modifier {
229 my ($self, $method_name, $method) = @_;
230 (!$self->has_method($method_name))
231 || confess "Cannot add an override of method '$method_name' " .
232 "because there is a local version of '$method_name'";
233 $self->get_override_method_modifiers_map->{$method_name} = $method;
236 sub has_before_method_modifiers { (shift)->_has_method_modifiers('before', @_) }
237 sub has_around_method_modifiers { (shift)->_has_method_modifiers('around', @_) }
238 sub has_after_method_modifiers { (shift)->_has_method_modifiers('after', @_) }
240 # override just checks for one,..
241 # but we can still re-use stuff
242 sub has_override_method_modifier { (shift)->_has_method_modifiers('override', @_) }
244 sub _has_method_modifiers {
245 my ($self, $modifier_type, $method_name) = @_;
246 my $accessor = "get_${modifier_type}_method_modifiers_map";
248 # for now we assume that if it exists,..
249 # it has at least one modifier in it
250 (exists $self->$accessor->{$method_name}) ? 1 : 0;
253 sub get_before_method_modifiers { (shift)->_get_method_modifiers('before', @_) }
254 sub get_around_method_modifiers { (shift)->_get_method_modifiers('around', @_) }
255 sub get_after_method_modifiers { (shift)->_get_method_modifiers('after', @_) }
257 sub _get_method_modifiers {
258 my ($self, $modifier_type, $method_name) = @_;
259 my $accessor = "get_${modifier_type}_method_modifiers_map";
260 @{$self->$accessor->{$method_name}};
263 sub get_override_method_modifier {
264 my ($self, $method_name) = @_;
265 $self->get_override_method_modifiers_map->{$method_name};
268 sub get_method_modifier_list {
269 my ($self, $modifier_type) = @_;
270 my $accessor = "get_${modifier_type}_method_modifiers_map";
271 keys %{$self->$accessor};
274 ## applying a role to a class ...
276 sub _check_excluded_roles {
277 my ($self, $other) = @_;
278 if ($other->excludes_role($self->name)) {
279 confess "Conflict detected: " . $other->name . " excludes role '" . $self->name . "'";
281 foreach my $excluded_role_name ($self->get_excluded_roles_list) {
282 if ($other->does_role($excluded_role_name)) {
283 confess "The class " . $other->name . " does the excluded role '$excluded_role_name'";
286 if ($other->isa('Moose::Meta::Role')) {
287 $other->add_excluded_roles($excluded_role_name);
289 # else -> ignore it :)
294 sub _check_required_methods {
295 my ($self, $other) = @_;
297 # we might need to move this down below the
298 # the attributes so that we can require any
299 # attribute accessors. However I am thinking
300 # that maybe those are somehow exempt from
301 # the require methods stuff.
302 foreach my $required_method_name ($self->get_required_method_list) {
304 unless ($other->find_method_by_name($required_method_name)) {
305 if ($other->isa('Moose::Meta::Role')) {
306 $other->add_required_methods($required_method_name);
309 confess "'" . $self->name . "' requires the method '$required_method_name' " .
310 "to be implemented by '" . $other->name . "'";
315 # we need to make sure that the method is
316 # not a method modifier, because those do
317 # not satisfy the requirements ...
318 my $method = $other->get_method($required_method_name);
319 # check if it is an override or a generated accessor ..
320 (!$method->isa('Moose::Meta::Method::Overriden') &&
321 !$method->isa('Class::MOP::Attribute::Accessor'))
322 || confess "'" . $self->name . "' requires the method '$required_method_name' " .
323 "to be implemented by '" . $other->name . "', the method is only a method modifier";
324 # before/after/around methods are a little trickier
325 # since we wrap the original local method (if applicable)
326 # so we need to check if the original wrapped method is
327 # from the same package, and not a wrap of the super method
328 if ($method->isa('Class::MOP::Method::Wrapped')) {
329 ($method->get_original_method->package_name eq $other->name)
330 || confess "'" . $self->name . "' requires the method '$required_method_name' " .
331 "to be implemented by '" . $other->name . "', the method is only a method modifier";
337 sub _apply_attributes {
338 my ($self, $other) = @_;
339 foreach my $attribute_name ($self->get_attribute_list) {
340 # it if it has one already
341 if ($other->has_attribute($attribute_name) &&
342 # make sure we haven't seen this one already too
343 $other->get_attribute($attribute_name) != $self->get_attribute($attribute_name)) {
344 # see if we are being composed
346 if ($other->isa('Moose::Meta::Role')) {
347 # all attribute conflicts between roles
348 # result in an immediate fatal error
349 confess "Role '" . $self->name . "' has encountered an attribute conflict " .
350 "during composition. This is fatal error and cannot be disambiguated.";
353 # but if this is a class, we
354 # can safely skip adding the
355 # attribute to the class
360 $other->add_attribute(
362 $self->get_attribute($attribute_name)
369 my ($self, $other) = @_;
370 foreach my $method_name ($self->get_method_list) {
371 # it if it has one already
372 if ($other->has_method($method_name) &&
373 # and if they are not the same thing ...
374 $other->get_method($method_name) != $self->get_method($method_name)) {
375 # see if we are composing into a role
376 if ($other->isa('Moose::Meta::Role')) {
377 # method conflicts between roles result
378 # in the method becoming a requirement
379 $other->add_required_methods($method_name);
381 # we have to remove the method from our
382 # role, if this is being called from combine()
383 # which means the meta is an anon class
384 # this *may* cause problems later, but it
385 # is probably fairly safe to assume that
386 # anon classes will only be used internally
387 # or by people who know what they are doing
388 $other->Moose::Meta::Class::remove_method($method_name)
389 if $other->name =~ /__ANON__/;
396 # add it, although it could be overriden
397 $other->alias_method(
399 $self->get_method($method_name)
405 sub _apply_override_method_modifiers {
406 my ($self, $other) = @_;
407 foreach my $method_name ($self->get_method_modifier_list('override')) {
408 # it if it has one already then ...
409 if ($other->has_method($method_name)) {
410 # if it is being composed into another role
411 # we have a conflict here, because you cannot
412 # combine an overriden method with a locally
414 if ($other->isa('Moose::Meta::Role')) {
415 confess "Role '" . $self->name . "' has encountered an 'override' method conflict " .
416 "during composition (A local method of the same name as been found). This " .
420 # if it is a class, then we
421 # just ignore this here ...
426 # if no local method is found, then we
427 # must check if we are a role or class
428 if ($other->isa('Moose::Meta::Role')) {
429 # if we are a role, we need to make sure
430 # we dont have a conflict with the role
431 # we are composing into
432 if ($other->has_override_method_modifier($method_name) &&
433 $other->get_override_method_modifier($method_name) != $self->get_override_method_modifier($method_name)) {
434 confess "Role '" . $self->name . "' has encountered an 'override' method conflict " .
435 "during composition (Two 'override' methods of the same name encountered). " .
436 "This is fatal error.";
439 # if there is no conflict,
440 # just add it to the role
441 $other->add_override_method_modifier(
443 $self->get_override_method_modifier($method_name)
448 # if this is not a role, then we need to
449 # find the original package of the method
450 # so that we can tell the class were to
451 # find the right super() method
452 my $method = $self->get_override_method_modifier($method_name);
453 my $package = svref_2object($method)->GV->STASH->NAME;
454 # if it is a class, we just add it
455 $other->add_override_method_modifier($method_name, $method, $package);
461 sub _apply_method_modifiers {
462 my ($self, $modifier_type, $other) = @_;
463 my $add = "add_${modifier_type}_method_modifier";
464 my $get = "get_${modifier_type}_method_modifiers";
465 foreach my $method_name ($self->get_method_modifier_list($modifier_type)) {
469 ) foreach $self->$get($method_name);
473 sub _apply_before_method_modifiers { (shift)->_apply_method_modifiers('before' => @_) }
474 sub _apply_around_method_modifiers { (shift)->_apply_method_modifiers('around' => @_) }
475 sub _apply_after_method_modifiers { (shift)->_apply_method_modifiers('after' => @_) }
478 my ($self, $other) = @_;
480 ($other->isa('Moose::Meta::Class') || $other->isa('Moose::Meta::Role'))
481 || confess "You must apply a role to a metaclass, not ($other)";
483 $self->_check_excluded_roles($other);
484 $self->_check_required_methods($other);
486 $self->_apply_attributes($other);
487 $self->_apply_methods($other);
489 $self->_apply_override_method_modifiers($other);
490 $self->_apply_before_method_modifiers($other);
491 $self->_apply_around_method_modifiers($other);
492 $self->_apply_after_method_modifiers($other);
494 $other->add_role($self);
497 my $anon_counter = 0;
500 my ($class, @roles) = @_;
502 my $pkg_name = __PACKAGE__ . "::__ANON__::" . $anon_counter++;
503 eval "package " . $pkg_name . "; our \$VERSION = '0.00';";
506 my $combined = $class->initialize($pkg_name);
508 foreach my $role (@roles) {
509 $role->apply($combined);
512 $combined->_clean_up_required_methods;
517 package Moose::Meta::Role::Method;
522 our $VERSION = '0.01';
524 use base 'Class::MOP::Method';
534 Moose::Meta::Role - The Moose Role metaclass
538 Moose's Roles are being actively developed, please see L<Moose::Role>
539 for more information. For the most part, this has no user-serviceable
540 parts inside. It's API is still subject to some change (although
541 probably not that much really).
579 =item B<add_excluded_roles>
581 =item B<excludes_role>
583 =item B<get_excluded_roles_list>
585 =item B<get_excluded_roles_map>
587 =item B<calculate_all_roles>
593 =item B<method_metaclass>
595 =item B<find_method_by_name>
601 =item B<alias_method>
603 =item B<get_method_list>
609 =item B<add_attribute>
611 =item B<has_attribute>
613 =item B<get_attribute>
615 =item B<get_attribute_list>
617 =item B<get_attribute_map>
619 =item B<remove_attribute>
625 =item B<add_required_methods>
627 =item B<remove_required_methods>
629 =item B<get_required_method_list>
631 =item B<get_required_methods_map>
633 =item B<requires_method>
639 =item B<add_after_method_modifier>
641 =item B<add_around_method_modifier>
643 =item B<add_before_method_modifier>
645 =item B<add_override_method_modifier>
651 =item B<has_after_method_modifiers>
653 =item B<has_around_method_modifiers>
655 =item B<has_before_method_modifiers>
657 =item B<has_override_method_modifier>
663 =item B<get_after_method_modifiers>
665 =item B<get_around_method_modifiers>
667 =item B<get_before_method_modifiers>
669 =item B<get_method_modifier_list>
675 =item B<get_override_method_modifier>
677 =item B<get_after_method_modifiers_map>
679 =item B<get_around_method_modifiers_map>
681 =item B<get_before_method_modifiers_map>
683 =item B<get_override_method_modifiers_map>
689 All complex software has bugs lurking in it, and this module is no
690 exception. If you find a bug please either email me, or add the bug
695 Stevan Little E<lt>stevan@iinteractive.comE<gt>
697 =head1 COPYRIGHT AND LICENSE
699 Copyright 2006 by Infinity Interactive, Inc.
701 L<http://www.iinteractive.com>
703 This library is free software; you can redistribute it and/or modify
704 it under the same terms as Perl itself.