From: Stevan Little Date: Fri, 1 Sep 2006 14:34:11 +0000 (+0000) Subject: putting the method modifiers in roles back in, we have to maintain backwards compat... X-Git-Tag: 0_12~2 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0558683c97fd7290b1ec5c62afe1993df80cb7ec;p=gitmo%2FMoose.git putting the method modifiers in roles back in, we have to maintain backwards compat; they will get fixed eventually, I promise --- diff --git a/Build.PL b/Build.PL index 07afd9b..13c519e 100644 --- a/Build.PL +++ b/Build.PL @@ -8,7 +8,7 @@ my $build = Module::Build->new( requires => { 'Scalar::Util' => '1.18', 'Carp' => '0', - 'Class::MOP' => '0.31', + 'Class::MOP' => '0.34', 'Sub::Name' => '0.02', 'UNIVERSAL::require' => '0.10', 'Sub::Exporter' => '0.954', diff --git a/Changes b/Changes index 5a89f1b..e99db0c 100644 --- a/Changes +++ b/Changes @@ -9,7 +9,8 @@ Revision history for Perl extension Moose - fixed &unimport to not remove the &inner and &super keywords because we need to localize them. - fixed number of spelling/grammer issues, thanks Theory :) - *~~ experimental feature ~~* + + **~~ experimental & undocumented feature ~~** - added the method and self keywords, they are basically just sugar, and they may not stay around. diff --git a/lib/Moose/Meta/Role.pm b/lib/Moose/Meta/Role.pm index 3669b87..d2406b7 100644 --- a/lib/Moose/Meta/Role.pm +++ b/lib/Moose/Meta/Role.pm @@ -45,6 +45,28 @@ __PACKAGE__->meta->add_attribute('required_methods' => ( default => sub { {} } )); +## method modifiers + +__PACKAGE__->meta->add_attribute('before_method_modifiers' => ( + reader => 'get_before_method_modifiers_map', + default => sub { {} } # ( => [ (CODE) ]) +)); + +__PACKAGE__->meta->add_attribute('after_method_modifiers' => ( + reader => 'get_after_method_modifiers_map', + default => sub { {} } # ( => [ (CODE) ]) +)); + +__PACKAGE__->meta->add_attribute('around_method_modifiers' => ( + reader => 'get_around_method_modifiers_map', + default => sub { {} } # ( => [ (CODE) ]) +)); + +__PACKAGE__->meta->add_attribute('override_method_modifiers' => ( + reader => 'get_override_method_modifiers_map', + default => sub { {} } # ( => CODE) +)); + ## Methods sub method_metaclass { 'Moose::Meta::Role::Method' } @@ -180,6 +202,74 @@ sub get_attribute_list { keys %{$self->get_attribute_map}; } +# method modifiers + +# mimic the metaclass API +sub add_before_method_modifier { (shift)->_add_method_modifier('before', @_) } +sub add_around_method_modifier { (shift)->_add_method_modifier('around', @_) } +sub add_after_method_modifier { (shift)->_add_method_modifier('after', @_) } + +sub _add_method_modifier { + my ($self, $modifier_type, $method_name, $method) = @_; + my $accessor = "get_${modifier_type}_method_modifiers_map"; + $self->$accessor->{$method_name} = [] + unless exists $self->$accessor->{$method_name}; + my $modifiers = $self->$accessor->{$method_name}; + # NOTE: + # check to see that we aren't adding the + # same code twice. We err in favor of the + # first on here, this may not be as expected + foreach my $modifier (@{$modifiers}) { + return if $modifier == $method; + } + push @{$modifiers} => $method; +} + +sub add_override_method_modifier { + my ($self, $method_name, $method) = @_; + (!$self->has_method($method_name)) + || confess "Cannot add an override of method '$method_name' " . + "because there is a local version of '$method_name'"; + $self->get_override_method_modifiers_map->{$method_name} = $method; +} + +sub has_before_method_modifiers { (shift)->_has_method_modifiers('before', @_) } +sub has_around_method_modifiers { (shift)->_has_method_modifiers('around', @_) } +sub has_after_method_modifiers { (shift)->_has_method_modifiers('after', @_) } + +# override just checks for one,.. +# but we can still re-use stuff +sub has_override_method_modifier { (shift)->_has_method_modifiers('override', @_) } + +sub _has_method_modifiers { + my ($self, $modifier_type, $method_name) = @_; + my $accessor = "get_${modifier_type}_method_modifiers_map"; + # NOTE: + # for now we assume that if it exists,.. + # it has at least one modifier in it + (exists $self->$accessor->{$method_name}) ? 1 : 0; +} + +sub get_before_method_modifiers { (shift)->_get_method_modifiers('before', @_) } +sub get_around_method_modifiers { (shift)->_get_method_modifiers('around', @_) } +sub get_after_method_modifiers { (shift)->_get_method_modifiers('after', @_) } + +sub _get_method_modifiers { + my ($self, $modifier_type, $method_name) = @_; + my $accessor = "get_${modifier_type}_method_modifiers_map"; + @{$self->$accessor->{$method_name}}; +} + +sub get_override_method_modifier { + my ($self, $method_name) = @_; + $self->get_override_method_modifiers_map->{$method_name}; +} + +sub get_method_modifier_list { + my ($self, $modifier_type) = @_; + my $accessor = "get_${modifier_type}_method_modifiers_map"; + keys %{$self->$accessor}; +} ## applying a role to a class ... @@ -220,6 +310,27 @@ sub _check_required_methods { "to be implemented by '" . $other->name . "'"; } } + else { + # NOTE: + # we need to make sure that the method is + # not a method modifier, because those do + # not satisfy the requirements ... + my $method = $other->get_method($required_method_name); + # check if it is an override or a generated accessor .. + (!$method->isa('Moose::Meta::Method::Overriden') && + !$method->isa('Class::MOP::Attribute::Accessor')) + || confess "'" . $self->name . "' requires the method '$required_method_name' " . + "to be implemented by '" . $other->name . "', the method is only a method modifier"; + # before/after/around methods are a little trickier + # since we wrap the original local method (if applicable) + # so we need to check if the original wrapped method is + # from the same package, and not a wrap of the super method + if ($method->isa('Class::MOP::Method::Wrapped')) { + ($method->get_original_method->package_name eq $other->name) + || confess "'" . $self->name . "' requires the method '$required_method_name' " . + "to be implemented by '" . $other->name . "', the method is only a method modifier"; + } + } } } @@ -291,6 +402,78 @@ sub _apply_methods { } } +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)) { + # if it is being composed into another role + # we have a conflict here, because you cannot + # combine an overriden method with a locally + # defined one + if ($other->isa('Moose::Meta::Role')) { + confess "Role '" . $self->name . "' has encountered an 'override' method conflict " . + "during composition (A local method of the same name as been found). This " . + "is fatal error."; + } + else { + # if it is a class, then we + # just ignore this here ... + next; + } + } + else { + # if no local method is found, then we + # must check if we are a role or class + if ($other->isa('Moose::Meta::Role')) { + # if we are a role, we need to make sure + # we dont have a conflict with the role + # we are composing into + if ($other->has_override_method_modifier($method_name) && + $other->get_override_method_modifier($method_name) != $self->get_override_method_modifier($method_name)) { + confess "Role '" . $self->name . "' has encountered an 'override' method conflict " . + "during composition (Two 'override' methods of the same name encountered). " . + "This is fatal error."; + } + else { + # if there is no conflict, + # just add it to the role + $other->add_override_method_modifier( + $method_name, + $self->get_override_method_modifier($method_name) + ); + } + } + else { + # if this is not a role, then we need to + # find the original package of the method + # so that we can tell the class were to + # find the right super() method + my $method = $self->get_override_method_modifier($method_name); + my $package = svref_2object($method)->GV->STASH->NAME; + # if it is a class, we just add it + $other->add_override_method_modifier($method_name, $method, $package); + } + } + } +} + +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($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) = @_; @@ -301,7 +484,12 @@ sub apply { $self->_check_required_methods($other); $self->_apply_attributes($other); - $self->_apply_methods($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); } @@ -446,6 +634,56 @@ probably not that much really). =back +=over 4 + +=item B + +=item B + +=item B + +=item B + +=over 4 + +=back + +=item B + +=item B + +=item B + +=item B + +=over 4 + +=back + +=item B + +=item B + +=item B + +=item B + +=over 4 + +=back + +=item B + +=item B + +=item B + +=item B + +=item B + +=back + =head1 BUGS All complex software has bugs lurking in it, and this module is no diff --git a/lib/Moose/Role.pm b/lib/Moose/Role.pm index a1e51b8..3ca4710 100644 --- a/lib/Moose/Role.pm +++ b/lib/Moose/Role.pm @@ -96,37 +96,39 @@ use Moose::Util::TypeConstraints; before => sub { my $meta = _find_meta(); return subname 'Moose::Role::before' => sub (@&) { - confess "Moose::Role does not currently support 'before'"; + my $code = pop @_; + $meta->add_before_method_modifier($_, $code) for @_; }; }, after => sub { my $meta = _find_meta(); return subname 'Moose::Role::after' => sub (@&) { - confess "Moose::Role does not currently support 'after'"; + my $code = pop @_; + $meta->add_after_method_modifier($_, $code) for @_; }; }, around => sub { my $meta = _find_meta(); return subname 'Moose::Role::around' => sub (@&) { - confess "Moose::Role does not currently support 'around'"; + my $code = pop @_; + $meta->add_around_method_modifier($_, $code) for @_; }; }, super => sub { my $meta = _find_meta(); - return subname 'Moose::Role::super' => sub { - confess "Moose::Role cannot support 'super'"; - }; + return subname 'Moose::Role::super' => sub {}; }, override => sub { my $meta = _find_meta(); return subname 'Moose::Role::override' => sub ($&) { - confess "Moose::Role cannot support 'override'"; + my ($name, $code) = @_; + $meta->add_override_method_modifier($name, $code); }; }, inner => sub { my $meta = _find_meta(); return subname 'Moose::Role::inner' => sub { - confess "Moose::Role cannot support 'inner'"; + confess "Moose::Role cannot support 'inner'"; }; }, augment => sub { diff --git a/t/040_meta_role.t b/t/040_meta_role.t index df706f3..dfab71b 100644 --- a/t/040_meta_role.t +++ b/t/040_meta_role.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 23; +use Test::More tests => 28; use Test::Exception; BEGIN { @@ -90,3 +90,19 @@ is_deeply( ok(!$foo_role->has_attribute('bar'), '... FooRole does not have the bar attribute'); ok($foo_role->has_attribute('baz'), '... FooRole does still have the baz attribute'); +# method modifiers + +ok(!$foo_role->has_before_method_modifiers('boo'), '... no boo:before modifier'); + +my $method = sub { "FooRole::boo:before" }; +lives_ok { + $foo_role->add_before_method_modifier('boo' => $method); +} '... added a method modifier okay'; + +ok($foo_role->has_before_method_modifiers('boo'), '... now we have a boo:before modifier'); +is(($foo_role->get_before_method_modifiers('boo'))[0], $method, '... got the right method back'); + +is_deeply( + [ $foo_role->get_method_modifier_list('before') ], + [ 'boo' ], + '... got the right list of before method modifiers'); diff --git a/t/041_role.t b/t/041_role.t index b4937e9..2758332 100644 --- a/t/041_role.t +++ b/t/041_role.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 25; +use Test::More tests => 35; use Test::Exception; BEGIN { @@ -31,15 +31,20 @@ words, should 'has_method' return true for them? sub foo { 'FooRole::foo' } sub boo { 'FooRole::boo' } - + + before 'boo' => sub { "FooRole::boo:before" }; + + after 'boo' => sub { "FooRole::boo:after1" }; + after 'boo' => sub { "FooRole::boo:after2" }; + + around 'boo' => sub { "FooRole::boo:around" }; + + override 'bling' => sub { "FooRole::bling:override" }; + override 'fling' => sub { "FooRole::fling:override" }; + ::dies_ok { extends() } '... extends() is not supported'; - ::dies_ok { augment() } '... augment() is not supported'; - ::dies_ok { inner() } '... inner() is not supported'; - ::dies_ok { overrides() } '... overrides() is not supported'; - ::dies_ok { super() } '... super() is not supported'; - ::dies_ok { after() } '... after() is not supported'; - ::dies_ok { before() } '... before() is not supported'; - ::dies_ok { around() } '... around() is not supported'; + ::dies_ok { augment() } '... augment() is not supported'; + ::dies_ok { inner() } '... inner() is not supported'; } my $foo_role = FooRole->meta; @@ -87,3 +92,55 @@ is_deeply( { is => 'ro' }, '... got the correct description of the baz attribute'); +# method modifiers + +ok($foo_role->has_before_method_modifiers('boo'), '... now we have a boo:before modifier'); +is(($foo_role->get_before_method_modifiers('boo'))[0]->(), + "FooRole::boo:before", + '... got the right method back'); + +is_deeply( + [ $foo_role->get_method_modifier_list('before') ], + [ 'boo' ], + '... got the right list of before method modifiers'); + +ok($foo_role->has_after_method_modifiers('boo'), '... now we have a boo:after modifier'); +is(($foo_role->get_after_method_modifiers('boo'))[0]->(), + "FooRole::boo:after1", + '... got the right method back'); +is(($foo_role->get_after_method_modifiers('boo'))[1]->(), + "FooRole::boo:after2", + '... got the right method back'); + +is_deeply( + [ $foo_role->get_method_modifier_list('after') ], + [ 'boo' ], + '... got the right list of after method modifiers'); + +ok($foo_role->has_around_method_modifiers('boo'), '... now we have a boo:around modifier'); +is(($foo_role->get_around_method_modifiers('boo'))[0]->(), + "FooRole::boo:around", + '... got the right method back'); + +is_deeply( + [ $foo_role->get_method_modifier_list('around') ], + [ 'boo' ], + '... got the right list of around method modifiers'); + +## overrides + +ok($foo_role->has_override_method_modifier('bling'), '... now we have a bling:override modifier'); +is($foo_role->get_override_method_modifier('bling')->(), + "FooRole::bling:override", + '... got the right method back'); + +ok($foo_role->has_override_method_modifier('fling'), '... now we have a fling:override modifier'); +is($foo_role->get_override_method_modifier('fling')->(), + "FooRole::fling:override", + '... got the right method back'); + +is_deeply( + [ sort $foo_role->get_method_modifier_list('override') ], + [ 'bling', 'fling' ], + '... got the right list of override method modifiers'); + diff --git a/t/042_apply_role.t b/t/042_apply_role.t index d41ba60..fae8593 100644 --- a/t/042_apply_role.t +++ b/t/042_apply_role.t @@ -3,15 +3,13 @@ use strict; use warnings; -use Test::More tests => 33; +use Test::More tests => 39; use Test::Exception; BEGIN { use_ok('Moose::Role'); } - - { package FooRole; use Moose::Role; @@ -21,6 +19,13 @@ BEGIN { sub goo { 'FooRole::goo' } sub foo { 'FooRole::foo' } + + override 'boo' => sub { 'FooRole::boo -> ' . super() }; + + around 'blau' => sub { + my $c = shift; + 'FooRole::blau -> ' . $c->(); + }; package BarClass; use Moose; @@ -33,6 +38,8 @@ BEGIN { extends 'BarClass'; with 'FooRole'; + + sub blau { 'FooClass::blau' } sub goo { 'FooClass::goo' } # << overrides the one from the role ... } @@ -55,7 +62,7 @@ dies_ok { ok($foo_class_meta->does_role('FooRole'), '... the FooClass->meta does_role FooRole'); ok(!$foo_class_meta->does_role('OtherRole'), '... the FooClass->meta !does_role OtherRole'); -foreach my $method_name (qw(bar baz foo goo)) { +foreach my $method_name (qw(bar baz foo boo blau goo)) { ok($foo_class_meta->has_method($method_name), '... FooClass has the method ' . $method_name); } @@ -77,7 +84,9 @@ ok(!$foo->does('OtherRole'), '... and instance of FooClass does not do OtherRole can_ok($foo, 'bar'); can_ok($foo, 'baz'); can_ok($foo, 'foo'); +can_ok($foo, 'boo'); can_ok($foo, 'goo'); +can_ok($foo, 'blau'); is($foo->foo, 'FooRole::foo', '... got the right value of foo'); is($foo->goo, 'FooClass::goo', '... got the right value of goo'); @@ -102,4 +111,6 @@ lives_ok { is($foo->bar, $foo2, '... got the right value for bar now'); +is($foo->boo, 'FooRole::boo -> BarClass::boo', '... got the right value from ->boo'); +is($foo->blau, 'FooRole::blau -> FooClass::blau', '... got the right value from ->blau'); diff --git a/t/044_role_conflict_detection.t b/t/044_role_conflict_detection.t index 712c491..1295722 100644 --- a/t/044_role_conflict_detection.t +++ b/t/044_role_conflict_detection.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 67; +use Test::More tests => 90; use Test::Exception; BEGIN { @@ -252,3 +252,98 @@ Role override method conflicts =cut +{ + package Role::Plot; + use Moose::Role; + + override 'twist' => sub { + super() . ' -> Role::Plot::twist'; + }; + + package Role::Truth; + use Moose::Role; + + override 'twist' => sub { + super() . ' -> Role::Truth::twist'; + }; +} + +{ + package My::Test::Base; + use Moose; + + sub twist { 'My::Test::Base::twist' } + + package My::Test11; + use Moose; + + extends 'My::Test::Base'; + + ::lives_ok { + with 'Role::Truth'; + } '... composed the role with override okay'; + + package My::Test12; + use Moose; + + extends 'My::Test::Base'; + + ::lives_ok { + with 'Role::Plot'; + } '... composed the role with override okay'; + + package My::Test13; + use Moose; + + ::dies_ok { + with 'Role::Plot'; + } '... cannot compose it because we have no superclass'; + + package My::Test14; + use Moose; + + extends 'My::Test::Base'; + + ::throws_ok { + with 'Role::Plot', 'Role::Truth'; + } qr/Two \'override\' methods of the same name encountered/, + '... cannot compose it because we have no superclass'; +} + +ok(My::Test11->meta->has_method('twist'), '... the twist method has been added'); +ok(My::Test12->meta->has_method('twist'), '... the twist method has been added'); +ok(!My::Test13->meta->has_method('twist'), '... the twist method has not been added'); +ok(!My::Test14->meta->has_method('twist'), '... the twist method has not been added'); + +ok(!My::Test11->does('Role::Plot'), '... our class does() the correct roles'); +ok(My::Test11->does('Role::Truth'), '... our class does() the correct roles'); +ok(!My::Test12->does('Role::Truth'), '... our class does() the correct roles'); +ok(My::Test12->does('Role::Plot'), '... our class does() the correct roles'); +ok(!My::Test13->does('Role::Plot'), '... our class does() the correct roles'); +ok(!My::Test14->does('Role::Truth'), '... our class does() the correct roles'); +ok(!My::Test14->does('Role::Plot'), '... our class does() the correct roles'); + +is(My::Test11->twist(), 'My::Test::Base::twist -> Role::Truth::twist', '... got the right method return'); +is(My::Test12->twist(), 'My::Test::Base::twist -> Role::Plot::twist', '... got the right method return'); +ok(!My::Test13->can('twist'), '... no twist method here at all'); +is(My::Test14->twist(), 'My::Test::Base::twist', '... got the right method return (from superclass)'); + +{ + package Role::Reality; + use Moose::Role; + + ::throws_ok { + with 'Role::Plot'; + } qr/A local method of the same name as been found/, + '... could not compose roles here, it dies'; + + sub twist { + 'Role::Reality::twist'; + } +} + +ok(Role::Reality->meta->has_method('twist'), '... the twist method has not been added'); +ok(!Role::Reality->meta->does_role('Role::Plot'), '... our role does() the correct roles'); +is(Role::Reality->meta->get_method('twist')->(), + 'Role::Reality::twist', + '... the twist method returns the right value'); diff --git a/t/046_roles_and_required_method_edge_cases.t b/t/046_roles_and_required_method_edge_cases.t new file mode 100644 index 0000000..5b4b478 --- /dev/null +++ b/t/046_roles_and_required_method_edge_cases.t @@ -0,0 +1,192 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 17; +use Test::Exception; + +BEGIN { + use_ok('Moose'); + use_ok('Moose::Role'); +} + +=pod + +Role which requires a method implemented +in another role as an override (it does +not remove the requirement) + +=cut + +{ + package Role::RequireFoo; + use strict; + use warnings; + use Moose::Role; + + requires 'foo'; + + package Role::ProvideFoo; + use strict; + use warnings; + use Moose::Role; + + ::lives_ok { + with 'Role::RequireFoo'; + } '... the required "foo" method will not exist yet (but we will live)'; + + override 'foo' => sub { 'Role::ProvideFoo::foo' }; +} + +is_deeply( + [ Role::ProvideFoo->meta->get_required_method_list ], + [ 'foo' ], + '... foo method is still required for Role::ProvideFoo'); + +=pod + +Role which requires a method implemented +in the consuming class as an override. +It will fail since method modifiers are +second class citizens. + +=cut + +{ + package Class::ProvideFoo::Base; + use Moose; + + sub foo { 'Class::ProvideFoo::Base::foo' } + + package Class::ProvideFoo::Override1; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + ::dies_ok { + with 'Role::RequireFoo'; + } '... the required "foo" method will not exist yet (and we will die)'; + + override 'foo' => sub { 'Class::ProvideFoo::foo' }; + + package Class::ProvideFoo::Override2; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + override 'foo' => sub { 'Class::ProvideFoo::foo' }; + + ::dies_ok { + with 'Role::RequireFoo'; + } '... the required "foo" method exists, but it is an override (and we will die)'; + +} + +=pod + +Now same thing, but with a before +method modifier. + +=cut + +{ + package Class::ProvideFoo::Before1; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + ::dies_ok { + with 'Role::RequireFoo'; + } '... the required "foo" method will not exist yet (and we will die)'; + + before 'foo' => sub { 'Class::ProvideFoo::foo:before' }; + + package Class::ProvideFoo::Before2; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + before 'foo' => sub { 'Class::ProvideFoo::foo:before' }; + + ::dies_ok { + with 'Role::RequireFoo'; + } '... the required "foo" method exists, but it is a before (and we will die)'; + + package Class::ProvideFoo::Before3; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + ::lives_ok { + with 'Role::RequireFoo'; + } '... the required "foo" method will not exist yet (and we will die)'; + + sub foo { 'Class::ProvideFoo::foo' } + before 'foo' => sub { 'Class::ProvideFoo::foo:before' }; + + package Class::ProvideFoo::Before4; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + sub foo { 'Class::ProvideFoo::foo' } + before 'foo' => sub { 'Class::ProvideFoo::foo:before' }; + + ::isa_ok(__PACKAGE__->meta->get_method('foo'), 'Class::MOP::Method::Wrapped'); + ::is(__PACKAGE__->meta->get_method('foo')->get_original_method->package_name, __PACKAGE__, + '... but the original method is from our package'); + + ::lives_ok { + with 'Role::RequireFoo'; + } '... the required "foo" method exists in the symbol table (and we will live)'; + + package Class::ProvideFoo::Before5; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + before 'foo' => sub { 'Class::ProvideFoo::foo:before' }; + + ::isa_ok(__PACKAGE__->meta->get_method('foo'), 'Class::MOP::Method::Wrapped'); + ::isnt(__PACKAGE__->meta->get_method('foo')->get_original_method->package_name, __PACKAGE__, + '... but the original method is not from our package'); + + ::dies_ok { + with 'Role::RequireFoo'; + } '... the required "foo" method exists, but it is a before wrapping the super (and we will die)'; +} + +=pod + +Now same thing, but with a method from an attribute +method modifier. + +=cut + +{ + + package Class::ProvideFoo::Attr1; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + ::dies_ok { + with 'Role::RequireFoo'; + } '... the required "foo" method will not exist yet (and we will die)'; + + has 'foo' => (is => 'ro'); + + package Class::ProvideFoo::Attr2; + use Moose; + + extends 'Class::ProvideFoo::Base'; + + has 'foo' => (is => 'ro'); + + ::dies_ok { + with 'Role::RequireFoo'; + } '... the required "foo" method exists, but it is a before (and we will die)'; +} + + \ No newline at end of file diff --git a/t/047_role_conflict_edge_cases.t b/t/047_role_conflict_edge_cases.t index fae06a7..9d31847 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 => 14; +use Test::More tests => 34; use Test::Exception; BEGIN { @@ -53,6 +53,109 @@ is(My::Test::Class1->foo, 'Role::Base::foo', '... got the right value from metho =pod Check for repeated inheritence causing +a method conflict with method modifiers +(which is not really a conflict) + +=cut + +{ + package Role::Base2; + use Moose::Role; + + override 'foo' => sub { super() . ' -> Role::Base::foo' }; + + package Role::Derived3; + use Moose::Role; + + with 'Role::Base2'; + + package Role::Derived4; + use Moose::Role; + + with 'Role::Base2'; + + package My::Test::Class2::Base; + use Moose; + + sub foo { 'My::Test::Class2::Base' } + + package My::Test::Class2; + use Moose; + + extends 'My::Test::Class2::Base'; + + ::lives_ok { + with 'Role::Derived3', 'Role::Derived4'; + } '... roles composed okay (no conflicts)'; +} + +ok(Role::Base2->meta->has_override_method_modifier('foo'), '... have the method foo as expected'); +ok(Role::Derived3->meta->has_override_method_modifier('foo'), '... have the method foo as expected'); +ok(Role::Derived4->meta->has_override_method_modifier('foo'), '... have the method foo as expected'); +ok(My::Test::Class2->meta->has_method('foo'), '... have the method foo as expected'); +isa_ok(My::Test::Class2->meta->get_method('foo'), 'Moose::Meta::Method::Overriden'); +ok(My::Test::Class2::Base->meta->has_method('foo'), '... have the method foo as expected'); +isa_ok(My::Test::Class2::Base->meta->get_method('foo'), 'Class::MOP::Method'); + +is(My::Test::Class2::Base->foo, 'My::Test::Class2::Base', '... got the right value from method'); +is(My::Test::Class2->foo, 'My::Test::Class2::Base -> Role::Base::foo', '... got the right value from method'); + +=pod + +Check for repeated inheritence of the +same code. There are no conflicts with +before/around/after method modifiers. + +This tests around, but should work the +same for before/afters as well + +=cut + +{ + package Role::Base3; + use Moose::Role; + + around 'foo' => sub { 'Role::Base::foo(' . (shift)->() . ')' }; + + package Role::Derived5; + use Moose::Role; + + with 'Role::Base3'; + + package Role::Derived6; + use Moose::Role; + + with 'Role::Base3'; + + package My::Test::Class3::Base; + use Moose; + + sub foo { 'My::Test::Class3::Base' } + + package My::Test::Class3; + use Moose; + + extends 'My::Test::Class3::Base'; + + ::lives_ok { + with 'Role::Derived5', 'Role::Derived6'; + } '... roles composed okay (no conflicts)'; +} + +ok(Role::Base3->meta->has_around_method_modifiers('foo'), '... have the method foo as expected'); +ok(Role::Derived5->meta->has_around_method_modifiers('foo'), '... have the method foo as expected'); +ok(Role::Derived6->meta->has_around_method_modifiers('foo'), '... have the method foo as expected'); +ok(My::Test::Class3->meta->has_method('foo'), '... have the method foo as expected'); +isa_ok(My::Test::Class3->meta->get_method('foo'), 'Class::MOP::Method::Wrapped'); +ok(My::Test::Class3::Base->meta->has_method('foo'), '... have the method foo as expected'); +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) diff --git a/t/048_more_role_edge_cases.t b/t/048_more_role_edge_cases.t index d7a1166..b0ff552 100644 --- a/t/048_more_role_edge_cases.t +++ b/t/048_more_role_edge_cases.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 10; +use Test::More tests => 77; use Test::Exception; BEGIN { @@ -54,3 +54,205 @@ BEGIN { is($foo_rv, "RootA::foo", "... got the right foo rv"); } +{ + # NOTE: + # this edge cases shows the application of + # an after modifier over a method which + # was added during role composotion. + # The way this will work is as follows: + # role SubBA will consume RootB and + # get a local copy of RootB::foo, it + # will also store a deferred after modifier + # to be applied to whatever class SubBA is + # composed into. + # When class SubBB comsumed role SubBA, the + # RootB::foo method is added to SubBB, then + # the deferred after modifier from SubBA is + # applied to it. + # It is important to note that the application + # of the after modifier does not happen until + # role SubBA is composed into SubAA. + + { + package RootB; + use Moose::Role; + + sub foo { "RootB::foo" } + + package SubBA; + use Moose::Role; + + with "RootB"; + + has counter => ( + isa => "Num", + is => "rw", + default => 0, + ); + + after foo => sub { + $_[0]->counter( $_[0]->counter + 1 ); + }; + + package SubBB; + use Moose; + + ::lives_ok { + with "SubBA"; + } '... composed the role successfully'; + } + + ok( SubBB->does("SubBA"), "BB does SubBA" ); + ok( SubBB->does("RootB"), "BB does RootB" ); + + isa_ok( my $i = SubBB->new, "SubBB" ); + + can_ok( $i, "foo" ); + + my $foo_rv; + lives_ok { + $foo_rv = $i->foo + } '... called foo successfully'; + is( $foo_rv, "RootB::foo", "foo rv" ); + is( $i->counter, 1, "after hook called" ); + + lives_ok { $i->foo } '... called foo successfully (again)'; + is( $i->counter, 2, "after hook called (again)" ); + + can_ok('SubBA', 'foo'); + my $subba_foo_rv; + lives_ok { + $subba_foo_rv = SubBA::foo(); + } '... called the sub as a function correctly'; + is($subba_foo_rv, 'RootB::foo', '... the SubBA->foo is still the RootB version'); +} + +{ + # NOTE: + # this checks that an override method + # does not try to trample over a locally + # composed in method. In this case the + # RootC::foo, which is composed into + # SubCA cannot be trampled with an + # override of 'foo' + { + package RootC; + use Moose::Role; + + sub foo { "RootC::foo" } + + package SubCA; + use Moose::Role; + + with "RootC"; + + ::dies_ok { + override foo => sub { "overridden" }; + } '... cannot compose an override over a local method'; + } +} + +# NOTE: +# need to talk to Yuval about the motivation behind +# this test, I am not sure we are testing anything +# useful here (although more tests cant hurt) + +{ + use List::Util qw/shuffle/; + + { + package Abstract; + use Moose::Role; + + requires "method"; + requires "other"; + + sub another { "abstract" } + + package ConcreteA; + use Moose::Role; + with "Abstract"; + + sub other { "concrete a" } + + package ConcreteB; + use Moose::Role; + with "Abstract"; + + sub method { "concrete b" } + + package ConcreteC; + use Moose::Role; + with "ConcreteA"; + + # NOTE: + # this was originally override, but + # that wont work (see above set of tests) + # so I switched it to around. + # However, this may not be testing the + # same thing that was originally intended + around other => sub { + return ( (shift)->() . " + c" ); + }; + + package SimpleClassWithSome; + use Moose; + + eval { with ::shuffle qw/ConcreteA ConcreteB/ }; + ::ok( !$@, "simple composition without abstract" ) || ::diag $@; + + package SimpleClassWithAll; + use Moose; + + eval { with ::shuffle qw/ConcreteA ConcreteB Abstract/ }; + ::ok( !$@, "simple composition with abstract" ) || ::diag $@; + } + + foreach my $class (qw/SimpleClassWithSome SimpleClassWithAll/) { + foreach my $role (qw/Abstract ConcreteA ConcreteB/) { + ok( $class->does($role), "$class does $role"); + } + + foreach my $method (qw/method other another/) { + can_ok( $class, $method ); + } + + is( eval { $class->another }, "abstract", "provided by abstract" ); + is( eval { $class->other }, "concrete a", "provided by concrete a" ); + is( eval { $class->method }, "concrete b", "provided by concrete b" ); + } + + { + package ClassWithSome; + use Moose; + + eval { with ::shuffle qw/ConcreteC ConcreteB/ }; + ::ok( !$@, "composition without abstract" ) || ::diag $@; + + package ClassWithAll; + use Moose; + + eval { with ::shuffle qw/ConcreteC Abstract ConcreteB/ }; + ::ok( !$@, "composition with abstract" ) || ::diag $@; + + package ClassWithEverything; + use Moose; + + eval { with ::shuffle qw/ConcreteC Abstract ConcreteA ConcreteB/ }; # this should clash + ::ok( !$@, "can compose ConcreteA and ConcreteC together" ); + } + + foreach my $class (qw/ClassWithSome ClassWithAll ClassWithEverything/) { + foreach my $role (qw/Abstract ConcreteA ConcreteB ConcreteC/) { + ok( $class->does($role), "$class does $role"); + } + + foreach my $method (qw/method other another/) { + can_ok( $class, $method ); + } + + is( eval { $class->another }, "abstract", "provided by abstract" ); + is( eval { $class->other }, "concrete a + c", "provided by concrete c + a" ); + is( eval { $class->method }, "concrete b", "provided by concrete b" ); + } +} diff --git a/t/201_example.t b/t/201_example.t index e253ffa..33f9058 100644 --- a/t/201_example.t +++ b/t/201_example.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 1; +use Test::More tests => 21; use Test::Exception; BEGIN { @@ -12,8 +12,6 @@ BEGIN { ## Roles -=begin nonsense - { package Constraint; use Moose::Role; @@ -130,4 +128,3 @@ ok($at_least_10_chars->does('Constraint::OnLength'), '... Constraint::LengthAtLe ok(!defined($at_least_10_chars->validate('barrrrrrrrr')), '... validated correctly'); is($at_least_10_chars->validate('bar'), 'must be at least 10 chars', '... validation failed correctly'); -=cut