support method modifiers for overrided accessors

Signed-off-by: Ji-Hyeon Gim <[email protected]>

Author: potatogim

lib/Moose/Manual/Attributes.pod

@@ -565,16 +565,6 @@ to C<'Bill'>.
 We recommend that you exercise caution when changing the type (C<isa>)
 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

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;
 }
 

t/attributes/overrided_accessor_modifier.t

@@ -0,0 +1,194 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+{
+    package Foo;
+    use Moose;
+
+    has 'foo' => (
+        is        => 'ro',
+        writer    => 'set_foo',
+        predicate => 'has_foo',
+    );
+
+    has '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->foo_arounded($self->foo_arounded + 1);
+
+        $self->$orig(@_);
+    };
+}
+
+{
+    package Bar;
+
+    use Moose;
+
+    extends 'Foo';
+
+    has '+foo' => (
+        lazy => 0,
+    );
+
+    has 'bar' => (
+        traits  => ['Array'],
+        is      => 'ro',
+        writer  => 'set_bar',
+        reader  => 'get_bar',
+        default => sub { [] },
+        handles => {
+            add_bar => 'push',
+        }
+    );
+
+    has 'bar_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->foo_arounded($self->foo_arounded + 1);
+
+        $self->$orig(@_);
+    };
+
+    around 'get_bar' => sub
+    {
+        my $orig = shift;
+        my $self = shift;
+
+        $self->bar_arounded($self->bar_arounded + 1);
+
+        $self->$orig(@_);
+    };
+
+    around 'add_bar' => sub
+    {
+        my $orig = shift;
+        my $self = shift;
+
+        $self->bar_arounded($self->bar_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->bar_arounded($self->bar_arounded + 1);
+
+        $self->$orig(@_);
+    };
+
+    around 'add_bar' => sub
+    {
+        my $orig = shift;
+        my $self = shift;
+
+        $self->bar_arounded($self->bar_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->foo_arounded, 1, '... got hte correct value');
+
+    my $bar = Bar->new;
+
+    isa_ok($bar, 'Bar');
+
+    $foo->has_foo();
+    $bar->set_foo(1);
+    $bar->get_bar();
+
+    is($foo->has_foo_arounded, 2, '... got hte correct value');
+    is($bar->foo_arounded, 2, '... got hte correct value');
+    is($bar->bar_arounded, 1, '... got hte correct value');
+
+    my $baz = Baz->new;
+
+    isa_ok($baz, 'Baz');
+
+    $foo->has_foo();
+    $baz->set_foo(1);
+    $baz->get_bar();
+
+    is($foo->has_foo_arounded, 3, '... got hte correct value');
+    is($baz->foo_arounded, 2, '... got hte correct value');
+    is($baz->bar_arounded, 2, '... got hte correct value');
+}
+
+done_testing;