From cb711b9ada25b26edaa41f2f870554028294017f Mon Sep 17 00:00:00 2001 From: Ji-Hyeon Gim Date: Fri, 10 May 2019 19:12:05 +0900 Subject: [PATCH] support method modifiers for overrided accessor Signed-off-by: Ji-Hyeon Gim --- lib/Mouse/Meta/Class.pm | 50 ++++ .../037_overrided_accessor_modifier.t | 219 ++++++++++++++++++ 2 files changed, 269 insertions(+) create mode 100644 t/020_attributes/037_overrided_accessor_modifier.t diff --git a/lib/Mouse/Meta/Class.pm b/lib/Mouse/Meta/Class.pm index b2ad6d63..ec4b9bb0 100644 --- a/lib/Mouse/Meta/Class.pm +++ b/lib/Mouse/Meta/Class.pm @@ -250,6 +250,56 @@ sub add_attribute { # install accessors first $attr->install_accessors(); + foreach my $isa ($self->linearized_isa) + { + my $meta = Mouse::Util::get_metaclass_by_name($isa); + my $modifiers = $meta->{modifiers}; + + my @targets; + + # install accessors modifiers + foreach my $type (qw(accessor reader writer predicate clearer)) { + next unless (exists $attr->{$type} + && exists $modifiers->{$attr->{$type}}); + + foreach my $mtype (qw(before around after)) { + foreach my $m ( @{ $modifiers->{$attr->{$type}}->{$mtype} } ) { + push @targets, [$mtype, $attr->{$type}, $m]; + } + } + } + + # install handles modifiers + if (exists $attr->{handles}) + { + my @handles; + + if (ref $attr->{handles} eq 'HASH') + { + @handles = keys %{ $attr->{handles} } + } + elsif (ref $attr->{handles} eq 'ARRAY') + { + @handles = @{ $attr->{handles} }; + } + + foreach my $handle ( @handles ) { + next unless (exists $modifiers->{$handle}); + + foreach my $mtype (qw(before around after)) { + foreach my $m ( @{ $modifiers->{$handle}->{$mtype} } ) { + push @targets, [$mtype, $handle, $m]; + } + } + } + } + + foreach my $mod (@targets) { + my ($mtype, $name, $subroutine) = @{ $mod }; + $self->_install_modifier($mtype, $name, $subroutine); + } + } + # then register the attribute to the metaclass $attr->{insertion_order} = keys %{ $self->{attributes} }; $self->{attributes}{$name} = $attr; diff --git a/t/020_attributes/037_overrided_accessor_modifier.t b/t/020_attributes/037_overrided_accessor_modifier.t new file mode 100644 index 00000000..a8ef0330 --- /dev/null +++ b/t/020_attributes/037_overrided_accessor_modifier.t @@ -0,0 +1,219 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Exception; + +{ + package Foo; + + use Mouse; + + 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 Mouse; + + sub push { return; }; +} + +{ + package Bar; + + use Mouse; + + 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 Mouse; + + 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 + # Mouse/Meta/Method/Delegation.pm:26-51 + 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;