From: Stevan Little Date: Thu, 11 May 2006 18:49:36 +0000 (+0000) Subject: more-roles X-Git-Tag: 0_09_03~25 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a2eec5e74dfb56aad14be204396be4ee7409b06c;p=gitmo%2FMoose.git more-roles --- diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index 7804b2a..47c32db 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -97,6 +97,22 @@ sub has_method { return $self->SUPER::has_method($method_name); } +sub add_attribute { + my $self = shift; + my $name = shift; + if (scalar @_ == 1 && ref($_[0]) eq 'HASH') { + # NOTE: + # if it is a HASH ref, we de-ref it. + # this will usually mean that it is + # coming from a role + $self->SUPER::add_attribute($name => %{$_[0]}); + } + else { + # otherwise we just pass the args + $self->SUPER::add_attribute($name => @_); + } +} + sub add_override_method_modifier { my ($self, $name, $method, $_super_package) = @_; (!$self->has_method($name)) diff --git a/lib/Moose/Meta/Role.pm b/lib/Moose/Meta/Role.pm index 3b938cd..485ac55 100644 --- a/lib/Moose/Meta/Role.pm +++ b/lib/Moose/Meta/Role.pm @@ -187,8 +187,16 @@ sub get_method_list { # attributes sub add_attribute { - my ($self, $name, %attr_desc) = @_; - $self->get_attribute_map->{$name} = \%attr_desc; + my $self = shift; + my $name = shift; + my $attr_desc; + if (scalar @_ == 1 && ref($_[0]) eq 'HASH') { + $attr_desc = $_[0]; + } + else { + $attr_desc = { @_ }; + } + $self->get_attribute_map->{$name} = $attr_desc; } sub has_attribute { @@ -279,31 +287,26 @@ sub get_method_modifier_list { ## applying a role to a class ... -sub apply { +sub _check_excluded_roles { my ($self, $other) = @_; - if ($other->excludes_role($self->name)) { confess "Conflict detected: " . $other->name . " excludes role '" . $self->name . "'"; } - -# warn "... Checking " . $self->name . " for excluded methods"; foreach my $excluded_role_name ($self->get_excluded_roles_list) { -# warn "... Checking if '$excluded_role_name' is done by " . $other->name . " for " . $self->name; if ($other->does_role($excluded_role_name)) { confess "The class " . $other->name . " does the excluded role '$excluded_role_name'"; } else { if ($other->isa('Moose::Meta::Role')) { -# warn ">>> The role " . $other->name . " does not do the excluded role '$excluded_role_name', so we are adding it in"; $other->add_excluded_roles($excluded_role_name); } - else { -# warn ">>> The class " . $other->name . " does not do the excluded role '$excluded_role_name', so we can just go about our business"; - } + # else -> ignore it :) } } - - +} + +sub _check_required_methods { + my ($self, $other) = @_; # NOTE: # we might need to move this down below the # the attributes so that we can require any @@ -341,21 +344,19 @@ sub apply { "to be implemented by '" . $other->name . "', the method is only a method modifier"; } } - } - + } +} + +sub _apply_attributes { + my ($self, $other) = @_; foreach my $attribute_name ($self->get_attribute_list) { # it if it has one already - if ($other->has_attribute($attribute_name)) { + if ($other->has_attribute($attribute_name) && + # make sure we haven't seen this one already too + $other->get_attribute($attribute_name) != $self->get_attribute($attribute_name)) { # see if we are being composed # into a role or not - if ($other->isa('Moose::Meta::Role')) { - - # FIXME: - # it is possible for these attributes - # to actually both be from the same - # origin (some common ancestor role) - # so we need to find a way to check this - + if ($other->isa('Moose::Meta::Role')) { # all attribute conflicts between roles # result in an immediate fatal error confess "Role '" . $self->name . "' has encountered an attribute conflict " . @@ -369,14 +370,16 @@ sub apply { } } else { - # add it, although it could be overriden $other->add_attribute( $attribute_name, - %{$self->get_attribute($attribute_name)} + $self->get_attribute($attribute_name) ); } - } - + } +} + +sub _apply_methods { + my ($self, $other) = @_; foreach my $method_name ($self->get_method_list) { # it if it has one already if ($other->has_method($method_name) && @@ -409,8 +412,11 @@ sub apply { $self->get_method($method_name) ); } - } - + } +} + +sub _apply_override_method_modifiers { + my ($self, $other) = @_; foreach my $method_name ($self->get_method_modifier_list('override')) { # it if it has one already then ... if ($other->has_method($method_name)) { @@ -463,27 +469,37 @@ sub apply { } } } - - foreach my $method_name ($self->get_method_modifier_list('before')) { - $other->add_before_method_modifier( - $method_name, - $_ - ) foreach $self->get_before_method_modifiers($method_name); - } - - foreach my $method_name ($self->get_method_modifier_list('after')) { - $other->add_after_method_modifier( +} + +sub _apply_method_modifiers { + my ($self, $modifier_type, $other) = @_; + my $add = "add_${modifier_type}_method_modifier"; + my $get = "get_${modifier_type}_method_modifiers"; + foreach my $method_name ($self->get_method_modifier_list($modifier_type)) { + $other->$add( $method_name, $_ - ) foreach $self->get_after_method_modifiers($method_name); + ) foreach $self->$get($method_name); } +} + +sub _apply_before_method_modifiers { (shift)->_apply_method_modifiers('before' => @_) } +sub _apply_around_method_modifiers { (shift)->_apply_method_modifiers('around' => @_) } +sub _apply_after_method_modifiers { (shift)->_apply_method_modifiers('after' => @_) } + +sub apply { + my ($self, $other) = @_; - foreach my $method_name ($self->get_method_modifier_list('around')) { - $other->add_around_method_modifier( - $method_name, - $_ - ) foreach $self->get_around_method_modifiers($method_name); - } + $self->_check_excluded_roles($other); + $self->_check_required_methods($other); + + $self->_apply_attributes($other); + $self->_apply_methods($other); + + $self->_apply_override_method_modifiers($other); + $self->_apply_before_method_modifiers($other); + $self->_apply_around_method_modifiers($other); + $self->_apply_after_method_modifiers($other); $other->add_role($self); } diff --git a/t/047_role_conflict_edge_cases.t b/t/047_role_conflict_edge_cases.t index e1b62ab..f4a2b6f 100644 --- a/t/047_role_conflict_edge_cases.t +++ b/t/047_role_conflict_edge_cases.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 28; +use Test::More tests => 34; use Test::Exception; BEGIN { @@ -180,3 +180,50 @@ isa_ok(My::Test::Class3::Base->meta->get_method('foo'), 'Class::MOP::Method'); is(My::Test::Class3::Base->foo, 'My::Test::Class3::Base', '... got the right value from method'); is(My::Test::Class3->foo, 'Role::Base::foo(My::Test::Class3::Base)', '... got the right value from method'); + +=pod + +Check for repeated inheritence causing +a attr conflict (which is not really +a conflict) + +=cut + +{ + package Role::Base4; + use strict; + use warnings; + use Moose::Role; + + has 'foo' => (is => 'ro', default => 'Role::Base::foo'); + + package Role::Derived7; + use strict; + use warnings; + use Moose::Role; + + with 'Role::Base4'; + + package Role::Derived8; + use strict; + use warnings; + use Moose::Role; + + with 'Role::Base4'; + + package My::Test::Class4; + use strict; + use warnings; + use Moose; + + ::lives_ok { + with 'Role::Derived7', 'Role::Derived8'; + } '... roles composed okay (no conflicts)'; +} + +ok(Role::Base4->meta->has_attribute('foo'), '... have the attribute foo as expected'); +ok(Role::Derived7->meta->has_attribute('foo'), '... have the attribute foo as expected'); +ok(Role::Derived8->meta->has_attribute('foo'), '... have the attribute foo as expected'); +ok(My::Test::Class4->meta->has_attribute('foo'), '... have the attribute foo as expected'); + +is(My::Test::Class4->new->foo, 'Role::Base::foo', '... got the right value from method');