Skip to content

Commit 83cd6b2

Browse files
potatogimpotatogim
committed
support method modifiers for overrided accessors
Signed-off-by: Ji-Hyeon Gim <[email protected]>
1 parent 974c75f commit 83cd6b2

File tree

3 files changed

+242
-10
lines changed

3 files changed

+242
-10
lines changed

‎lib/Moose/Manual/Attributes.pod

-10
Original file line numberDiff line numberDiff line change
@@ -565,16 +565,6 @@ to C<'Bill'>.
565565
We recommend that you exercise caution when changing the type (C<isa>)
566566
of an inherited attribute.
567567

568-
=head2 Attribute Inheritance and Method Modifiers
569-
570-
When an inherited attribute is defined, that creates an entirely new set of
571-
accessors for the attribute (reader, writer, predicate, etc.). This is
572-
necessary because these may be what was changed when inheriting the attribute.
573-
574-
As a consequence, any method modifiers defined on the attribute's accessors in
575-
an ancestor class will effectively be ignored, because the new accessors live
576-
in the child class and do not see the modifiers from the parent class.
577-
578568
=head1 MULTIPLE ATTRIBUTE SHORTCUTS
579569

580570
If you have a number of attributes that differ only by name, you can declare

‎lib/Moose/Meta/Attribute.pm

+23
Original file line numberDiff line numberDiff line change
@@ -1011,8 +1011,31 @@ sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
10111011

10121012
sub install_accessors {
10131013
my $self = shift;
1014+
1015+
my @mods;
1016+
1017+
foreach my $method_meta ( @{ $self->associated_methods } ) {
1018+
my $wrapped = $self->associated_class->find_method_by_name($method_meta->name);
1019+
1020+
next if (!defined($wrapped) || !$wrapped->isa('Class::MOP::Method::Wrapped'));
1021+
1022+
push @mods, map {
1023+
my $type = $_;
1024+
map +[ $wrapped->name, $type, $_ ], $wrapped->${\"${type}_modifiers"};
1025+
} ( qw(after before around) );
1026+
}
1027+
10141028
$self->SUPER::install_accessors(@_);
10151029
$self->install_delegation if $self->has_handles;
1030+
1031+
foreach my $mod ( @mods ) {
1032+
my ($name, $type, $modifier) = @{$mod};
1033+
1034+
my $func = "add_${type}_method_modifier";
1035+
1036+
$self->associated_class->$func($name, $modifier);
1037+
}
1038+
10161039
return;
10171040
}
10181041

‎t/attributes/overrided_accessor_modifier.t

+219
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,219 @@
1+
#!/usr/bin/perl
2+
3+
use strict;
4+
use warnings;
5+
6+
use Test::More;
7+
use Test::Exception;
8+
9+
{
10+
package Foo;
11+
12+
use Moose;
13+
14+
has 'foo' => (
15+
is => 'ro',
16+
writer => 'set_foo',
17+
predicate => 'has_foo',
18+
);
19+
20+
has 'set_foo_arounded' => (
21+
is => 'rw',
22+
isa => 'Int',
23+
default => 0,
24+
);
25+
26+
has 'has_foo_arounded' => (
27+
is => 'rw',
28+
isa => 'Int',
29+
default => 0,
30+
);
31+
32+
around 'has_foo' => sub {
33+
my $orig = shift;
34+
my $self = shift;
35+
36+
$self->has_foo_arounded($self->has_foo_arounded + 1);
37+
38+
$self->$orig(@_);
39+
};
40+
41+
around 'set_foo' => sub {
42+
my $orig = shift;
43+
my $self = shift;
44+
45+
$self->set_foo_arounded($self->set_foo_arounded + 1);
46+
47+
$self->$orig(@_);
48+
};
49+
}
50+
51+
{
52+
package MyFoo;
53+
54+
use Moose;
55+
56+
sub push { return; };
57+
}
58+
59+
{
60+
package Bar;
61+
62+
use Moose;
63+
64+
extends 'Foo';
65+
66+
has '+foo' => (
67+
lazy => 0,
68+
);
69+
70+
has 'bar' => (
71+
is => 'ro',
72+
isa => 'MyFoo',
73+
reader => 'get_bar',
74+
default => sub { MyFoo->new(); },
75+
handles => [qw/push/],
76+
);
77+
78+
has 'get_bar_arounded' => (
79+
is => 'rw',
80+
isa => 'Int',
81+
default => 0,
82+
);
83+
84+
has 'bar_handle_arounded' => (
85+
is => 'rw',
86+
isa => 'Int',
87+
default => 0,
88+
);
89+
90+
around 'has_foo' => sub {
91+
my $orig = shift;
92+
my $self = shift;
93+
94+
$self->has_foo_arounded($self->has_foo_arounded + 1);
95+
96+
$self->$orig(@_);
97+
};
98+
99+
around 'set_foo' => sub
100+
{
101+
my $orig = shift;
102+
my $self = shift;
103+
104+
$self->set_foo_arounded($self->set_foo_arounded + 1);
105+
106+
$self->$orig(@_);
107+
};
108+
109+
around 'get_bar' => sub
110+
{
111+
my $orig = shift;
112+
my $self = shift;
113+
114+
$self->get_bar_arounded($self->get_bar_arounded + 1);
115+
116+
$self->$orig(@_);
117+
};
118+
119+
around 'push' => sub
120+
{
121+
my $orig = shift;
122+
my $self = shift;
123+
124+
$self->bar_handle_arounded($self->bar_handle_arounded + 1);
125+
126+
$self->$orig(@_);
127+
};
128+
}
129+
130+
{
131+
package Baz;
132+
133+
use Moose;
134+
135+
extends 'Bar';
136+
137+
has '+bar' => (
138+
lazy => 0,
139+
);
140+
141+
around 'has_foo' => sub {
142+
my $orig = shift;
143+
my $self = shift;
144+
145+
$self->has_foo_arounded($self->has_foo_arounded + 1);
146+
147+
$self->$orig(@_);
148+
};
149+
150+
around 'get_bar' => sub
151+
{
152+
my $orig = shift;
153+
my $self = shift;
154+
155+
$self->get_bar_arounded($self->get_bar_arounded + 1);
156+
157+
$self->$orig(@_);
158+
};
159+
160+
around 'push' => sub
161+
{
162+
my $orig = shift;
163+
my $self = shift;
164+
165+
$self->bar_handle_arounded($self->bar_handle_arounded + 1);
166+
167+
$self->$orig(@_);
168+
};
169+
}
170+
171+
{
172+
my $foo = Foo->new;
173+
174+
isa_ok($foo, 'Foo');
175+
176+
$foo->has_foo();
177+
$foo->set_foo(1);
178+
179+
is($foo->has_foo_arounded, 1, '... got hte correct value');
180+
is($foo->set_foo_arounded, 1, '... got hte correct value');
181+
182+
my $bar = Bar->new;
183+
184+
isa_ok($bar, 'Bar');
185+
186+
$bar->has_foo();
187+
is($bar->has_foo_arounded, 2, '... got hte correct value');
188+
189+
$bar->set_foo(1);
190+
is($bar->set_foo_arounded, 2, '... got hte correct value');
191+
192+
$bar->get_bar();
193+
is($bar->get_bar_arounded, 1, '... got hte correct value');
194+
195+
$bar->push(1);
196+
# method delegation calls reader internally
197+
# Moose/Meta/Method/Delegation.pm
198+
is($bar->get_bar_arounded, 2, '... got hte correct value');
199+
is($bar->bar_handle_arounded, 1, '... got hte correct value');
200+
201+
my $baz = Baz->new;
202+
203+
isa_ok($baz, 'Baz');
204+
205+
$baz->has_foo();
206+
is($baz->has_foo_arounded, 3, '... got hte correct value');
207+
208+
$baz->set_foo(1);
209+
is($baz->set_foo_arounded, 2, '... got hte correct value');
210+
211+
$baz->get_bar();
212+
is($baz->get_bar_arounded, 2, '... got hte correct value');
213+
214+
$baz->push(1);
215+
is($baz->get_bar_arounded, 4, '... got hte correct value');
216+
is($baz->bar_handle_arounded, 2, '... got hte correct value');
217+
}
218+
219+
done_testing;

0 commit comments

Comments
 (0)