diff --git a/lib/Moose/Manual/Attributes.pod b/lib/Moose/Manual/Attributes.pod index e4c1a3bad..440986280 100644 --- a/lib/Moose/Manual/Attributes.pod +++ b/lib/Moose/Manual/Attributes.pod @@ -565,16 +565,6 @@ to C<'Bill'>. We recommend that you exercise caution when changing the type (C) of an inherited attribute. -=head2 Attribute Inheritance and Method Modifiers - -When an inherited attribute is defined, that creates an entirely new set of -accessors for the attribute (reader, writer, predicate, etc.). This is -necessary because these may be what was changed when inheriting the attribute. - -As a consequence, any method modifiers defined on the attribute's accessors in -an ancestor class will effectively be ignored, because the new accessors live -in the child class and do not see the modifiers from the parent class. - =head1 MULTIPLE ATTRIBUTE SHORTCUTS If you have a number of attributes that differ only by name, you can declare diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index 3a0e795ef..7e19080a7 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -1011,8 +1011,31 @@ sub accessor_metaclass { 'Moose::Meta::Method::Accessor' } sub install_accessors { my $self = shift; + + my @mods; + + foreach my $method_meta ( @{ $self->associated_methods } ) { + my $wrapped = $self->associated_class->find_method_by_name($method_meta->name); + + next if (!defined($wrapped) || !$wrapped->isa('Class::MOP::Method::Wrapped')); + + push @mods, map { + my $type = $_; + map +[ $wrapped->name, $type, $_ ], $wrapped->${\"${type}_modifiers"}; + } ( qw(after before around) ); + } + $self->SUPER::install_accessors(@_); $self->install_delegation if $self->has_handles; + + foreach my $mod ( @mods ) { + my ($name, $type, $modifier) = @{$mod}; + + my $func = "add_${type}_method_modifier"; + + $self->associated_class->$func($name, $modifier); + } + return; } diff --git a/t/attributes/overrided_accessor_modifier.t b/t/attributes/overrided_accessor_modifier.t new file mode 100644 index 000000000..084fcbdf7 --- /dev/null +++ b/t/attributes/overrided_accessor_modifier.t @@ -0,0 +1,219 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Exception; + +{ + package Foo; + + use Moose; + + has 'foo' => ( + is => 'ro', + writer => 'set_foo', + predicate => 'has_foo', + ); + + has 'set_foo_arounded' => ( + is => 'rw', + isa => 'Int', + default => 0, + ); + + has 'has_foo_arounded' => ( + is => 'rw', + isa => 'Int', + default => 0, + ); + + around 'has_foo' => sub { + my $orig = shift; + my $self = shift; + + $self->has_foo_arounded($self->has_foo_arounded + 1); + + $self->$orig(@_); + }; + + around 'set_foo' => sub { + my $orig = shift; + my $self = shift; + + $self->set_foo_arounded($self->set_foo_arounded + 1); + + $self->$orig(@_); + }; +} + +{ + package MyFoo; + + use Moose; + + sub push { return; }; +} + +{ + package Bar; + + use Moose; + + extends 'Foo'; + + has '+foo' => ( + lazy => 0, + ); + + has 'bar' => ( + is => 'ro', + isa => 'MyFoo', + reader => 'get_bar', + default => sub { MyFoo->new(); }, + handles => [qw/push/], + ); + + has 'get_bar_arounded' => ( + is => 'rw', + isa => 'Int', + default => 0, + ); + + has 'bar_handle_arounded' => ( + is => 'rw', + isa => 'Int', + default => 0, + ); + + around 'has_foo' => sub { + my $orig = shift; + my $self = shift; + + $self->has_foo_arounded($self->has_foo_arounded + 1); + + $self->$orig(@_); + }; + + around 'set_foo' => sub + { + my $orig = shift; + my $self = shift; + + $self->set_foo_arounded($self->set_foo_arounded + 1); + + $self->$orig(@_); + }; + + around 'get_bar' => sub + { + my $orig = shift; + my $self = shift; + + $self->get_bar_arounded($self->get_bar_arounded + 1); + + $self->$orig(@_); + }; + + around 'push' => sub + { + my $orig = shift; + my $self = shift; + + $self->bar_handle_arounded($self->bar_handle_arounded + 1); + + $self->$orig(@_); + }; +} + +{ + package Baz; + + use Moose; + + extends 'Bar'; + + has '+bar' => ( + lazy => 0, + ); + + around 'has_foo' => sub { + my $orig = shift; + my $self = shift; + + $self->has_foo_arounded($self->has_foo_arounded + 1); + + $self->$orig(@_); + }; + + around 'get_bar' => sub + { + my $orig = shift; + my $self = shift; + + $self->get_bar_arounded($self->get_bar_arounded + 1); + + $self->$orig(@_); + }; + + around 'push' => sub + { + my $orig = shift; + my $self = shift; + + $self->bar_handle_arounded($self->bar_handle_arounded + 1); + + $self->$orig(@_); + }; +} + +{ + my $foo = Foo->new; + + isa_ok($foo, 'Foo'); + + $foo->has_foo(); + $foo->set_foo(1); + + is($foo->has_foo_arounded, 1, '... got hte correct value'); + is($foo->set_foo_arounded, 1, '... got hte correct value'); + + my $bar = Bar->new; + + isa_ok($bar, 'Bar'); + + $bar->has_foo(); + is($bar->has_foo_arounded, 2, '... got hte correct value'); + + $bar->set_foo(1); + is($bar->set_foo_arounded, 2, '... got hte correct value'); + + $bar->get_bar(); + is($bar->get_bar_arounded, 1, '... got hte correct value'); + + $bar->push(1); + # method delegation calls reader internally + # Moose/Meta/Method/Delegation.pm + is($bar->get_bar_arounded, 2, '... got hte correct value'); + is($bar->bar_handle_arounded, 1, '... got hte correct value'); + + my $baz = Baz->new; + + isa_ok($baz, 'Baz'); + + $baz->has_foo(); + is($baz->has_foo_arounded, 3, '... got hte correct value'); + + $baz->set_foo(1); + is($baz->set_foo_arounded, 2, '... got hte correct value'); + + $baz->get_bar(); + is($baz->get_bar_arounded, 2, '... got hte correct value'); + + $baz->push(1); + is($baz->get_bar_arounded, 4, '... got hte correct value'); + is($baz->bar_handle_arounded, 2, '... got hte correct value'); +} + +done_testing;